Replicating ego-alter influence plot

---

This script replicates Figure 3 of the manuscript (Ego-alter influence plots).

Preparation

Clean the working environment

# clean the working environment
rm(list = ls())

Define some functions

{

    fcentring <- function(actors) {
        centored <- actors - mean(actors)
        return(centored)
    }

    fsimij <- function(actors, min, max) {
        # rv <- max(actors) - min(actors)
        rv <- max - min
        mat1 <- matrix(actors, nrow = length(actors), ncol = length(actors), byrow = TRUE)
        mat2 <- t(mat1)
        simij <- 1 - (abs(mat1 - mat2)/rv)
        return(simij)
    }

    flinear <- function(ego, alters, ...) {
        actors <- c(ego, alters)  #define the network
        beh_centered <- fcentring(actors)  #center behavior scores

        statistic <- beh_centered[1]  #the actual statistic

        return(statistic)
    }

    fquad <- function(ego, alters, ...) {
        actors <- c(ego, alters)  #define the network
        beh_centered <- fcentring(actors)  #center behavior scores

        statistic <- (beh_centered[1])^2  #the actual statistic

        return(statistic)
    }

    favSim <- function(ego, alters, min, max) {
        actors <- c(ego, alters)  #define the network
        beh_centered <- fcentring(actors)  #center behavior scores
        simij <- fsimij(beh_centered, min, max)  #calculate the similarity scores
        diag(simij) <- NA
        msimij <- mean(simij, na.rm = TRUE)  #calculate the mean similarity score. only calculate mean on non-diagonal cells??!!
        simij_c <- simij - msimij  #center the similarity scores

        statistic <- sum(simij_c[1, ], na.rm = TRUE)/length(alters)  #the actual statistic

        return(statistic)
    }

    favSim2 <- function(ego, alters, min, max) {
        actors <- c(ego, alters)  #define the network
        beh_centered <- fcentring(actors)  #center behavior scores
        simij <- fsimij(beh_centered, min, max)  #calculate the similarity scores
        diag(simij) <- NA
        # msimij <- mean(simij, na.rm=TRUE) #calculate the mean similarity score. only calculate
        # mean on non-diagonal cells??!!
        simij_c <- simij  # - msimij #center the similarity scores

        statistic <- sum(simij_c[1, ], na.rm = TRUE)/length(alters)  #the actual statistic

        return(statistic)
    }

    favAttHigher <- function(ego, alters, min, max) {
        actors <- c(ego, alters)
        beh_centered <- fcentring(actors)
        simij <- fsimij(beh_centered, min, max)
        diag(simij) <- NA
        # msimij <- mean(simij, na.rm=TRUE) #only calculate mean on non-diagonal cells??!! simij_c
        # <- simij - msimij diag(simij_c) <- NA
        simijH <- simij[1, ]
        simijH[beh_centered <= beh_centered[1]] <- 1
        simijH[1] <- NA
        statistic <- sum(simijH, na.rm = TRUE)/length(alters)

        return(statistic)
    }

    favAttLower <- function(ego, alters, min, max) {
        actors <- c(ego, alters)
        beh_centered <- fcentring(actors)
        simij <- fsimij(beh_centered, min, max)
        diag(simij) <- NA

        simijL <- simij[1, ]
        simijL[beh_centered >= beh_centered[1]] <- 1
        simijL[1] <- NA
        statistic <- sum(simijL, na.rm = TRUE)/length(alters)

        return(statistic)
    }

    favAlt <- function(ego, alters, ...) {
        actors <- c(ego, alters)
        beh_centered <- fcentring(actors)

        statistic <- beh_centered[1] * (sum(beh_centered[-1], na.rm = TRUE)/length(alters))

        return(statistic)
    }

    fAttMean <- function(ego, alters, min, max, ...) {
        rv <- max - min
        actors <- c(ego, alters)
        beh_centered <- fcentring(actors)

        statistic <- 1 - abs(beh_centered[1] - (sum(beh_centered[-1], na.rm = TRUE)/length(alters)))/rv  #thus we strive for a highest local similarity score!

        return(statistic)
    }

    finluenceplot <- function(alters, min, max, fun, params, results = TRUE, plot = TRUE) {
        # check correct number of parameters are given
        if (length(fun) != length(params))
            stop("Please provide one (and only one) parameter for each of the behavioral effects!")

        # calculuate value of evaluation function
        s <- NA
        for (i in min:max) {
            s[i] <- 0
            for (j in 1:length(fun)) {
                s[i] <- s[i] + params[j] * fun[[j]](i, alters, min, max)
            }
        }

        # calculate the probabilities
        p <- NA
        for (i in min:max) {
            p[i] <- exp(s[i])/sum(exp(s))
        }

        # calculate the probabilities of choice set
        p2 <- NA
        for (i in min:max) {
            if (i == min) {
                p2[i] <- exp(s[i])/sum(exp(s[i]) + exp(s[i + 1]))
            } else if (i == max) {
                p2[i] <- exp(s[i])/sum(exp(s[i]) + exp(s[i - 1]))
            } else {
                p2[i] <- exp(s[i])/sum(exp(s[i]) + exp(s[i - 1]) + exp(s[i + 1]))
            }
        }

        # calculate the probability ratio
        r <- NA
        for (i in min:max) {
            r[i] <- p[i]/p[1]
        }

        # some simple plots
        if (plot) {
            name <- deparse(substitute(fun))
            name <- stringr::str_sub(as.character(name), 6, -2)
            par(mfrow = c(2, 2))
            plot(y = s, x = min:max, xlab = "ego behavioral score", ylab = name, type = "b")
            mtext("EVALUATION", line = 1)
            mtext(paste("alters:", paste0(alters, collapse = ",")))
            plot(y = p, x = min:max, xlab = "ego behavioral score", ylab = name, ylim = c(0, 1), type = "b")
            mtext("PROBABILITIES", line = 1)
            mtext(paste("alters:", paste0(alters, collapse = ",")))
            plot(y = p2, x = min:max, xlab = "ego behavioral score", ylab = name, ylim = c(0, 1), type = "b")
            mtext("PROBABILITIES choice set", line = 1)
            mtext(paste("alters:", paste0(alters, collapse = ",")))
            plot(y = r, x = min:max, xlab = "ego behavioral score", ylab = name, type = "b")
            mtext("RATIOS", line = 1)
            mtext(paste("alters:", paste0(alters, collapse = ",")))
        }

        # return results for more fancy plotting
        if (results) {
            x <- min:max
            df <- data.frame(x, s, p, p2, r)
            return(df)
        }

    }
}

We consider different scenarios, where ego’s alters have different running frequency values.

alters1 <- rep(c(2), 6)
alters2 <- rep(c(5), 6)
alters3 <- rep(c(2, 2, 2, 5, 5, 5))
alters4 <- rep(c(1, 2, 3, 4, 5, 6, 7))

Our club estimates:

# frequency
club1 <- c(-0.008, -0.071, 0.017, 4.762)
club2 <- c(-0.077, 0.04, 1.385, 4.413)
club3 <- c(-0.086, -0.009, 1.499, 2.41)
club4 <- c(0.149, -0.201, -4.482, 6.216)
club5 <- c(0.247, 0.062, -0.184, 9.062)

# scenario 1 club1
p1 <- finluenceplot(alters = alters1, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club1)
# club2
p2 <- finluenceplot(alters = alters1, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club2)
# club 3
p3 <- finluenceplot(alters = alters1, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club3)
# club 4
p4 <- finluenceplot(alters = alters1, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club4)
# club 5
p5 <- finluenceplot(alters = alters1, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club5)

plot1 <- rbind(p1, p2, p3, p4, p5)
plot1$Club <- as.character(sort(rep(1:5, 7)))
plot1$scenario <- paste("A) Behavior alters:", paste0(alters1, collapse = ", "))

# scenario 2 club1
p1 <- finluenceplot(alters = alters2, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club1)
# club2
p2 <- finluenceplot(alters = alters2, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club2)
# club 3
p3 <- finluenceplot(alters = alters2, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club3)
# club 4
p4 <- finluenceplot(alters = alters2, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club4)
# club 5
p5 <- finluenceplot(alters = alters2, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club5)

plot2 <- rbind(p1, p2, p3, p4, p5)
plot2$Club <- as.character(sort(rep(1:5, 7)))
plot2$scenario <- paste("B) Behavior alters:", paste0(alters2, collapse = ", "))

# scenario 3 club1
p1 <- finluenceplot(alters = alters3, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club1)
# club2
p2 <- finluenceplot(alters = alters3, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club2)
# club 3
p3 <- finluenceplot(alters = alters3, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club3)
# club 4
p4 <- finluenceplot(alters = alters3, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club4)
# club 5
p5 <- finluenceplot(alters = alters3, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club5)

plot3 <- rbind(p1, p2, p3, p4, p5)
plot3$Club <- as.character(sort(rep(1:5, 7)))
plot3$scenario <- paste("C) Behavior alters:", paste0(alters3, collapse = ", "))

# scenario 4 club1
p1 <- finluenceplot(alters = alters4, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club1)
# club2
p2 <- finluenceplot(alters = alters4, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club2)
# club 3
p3 <- finluenceplot(alters = alters4, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club3)
# club 4
p4 <- finluenceplot(alters = alters4, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club4)
# club 5
p5 <- finluenceplot(alters = alters4, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club5)

plot4 <- rbind(p1, p2, p3, p4, p5)
plot4$Club <- as.character(sort(rep(1:5, 7)))
plot4$scenario <- paste("D) Behavior alters:", paste0(alters4, collapse = ", "))


multiplot <- rbind(plot1, plot2, plot3, plot4)
multiplot$Attribute <- "Frequency"

We do the same for running volume.

# volume
club1 <- c(-0.056, -0.033, 0.277, 3.475)
club2 <- c(-0.22, 0.012, 1.721, 1.227)
club3 <- c(-0.129, -0.008, 1.929, 1.78)
club4 <- c(1.294, -0.409, -18.608, 16.761)
club5 <- c(-0.012, 0.024, 1.915, 8.61)

p1 <- finluenceplot(alters = alters1, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club1)
# club2
p2 <- finluenceplot(alters = alters1, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club2)
# club 3
p3 <- finluenceplot(alters = alters1, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club3)
# club 4
p4 <- finluenceplot(alters = alters1, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club4)
# club 5
p5 <- finluenceplot(alters = alters1, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club5)

plot1 <- rbind(p1, p2, p3, p4, p5)
plot1$Club <- as.character(sort(rep(1:5, 7)))
plot1$scenario <- paste("A) Behavior alters:", paste0(alters1, collapse = ", "))

# scenario 2 club1
p1 <- finluenceplot(alters = alters2, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club1)
# club2
p2 <- finluenceplot(alters = alters2, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club2)
# club 3
p3 <- finluenceplot(alters = alters2, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club3)
# club 4
p4 <- finluenceplot(alters = alters2, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club4)
# club 5
p5 <- finluenceplot(alters = alters2, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club5)

plot2 <- rbind(p1, p2, p3, p4, p5)
plot2$Club <- as.character(sort(rep(1:5, 7)))
plot2$scenario <- paste("B) Behavior alters:", paste0(alters2, collapse = ", "))

# scenario 3 club1
p1 <- finluenceplot(alters = alters3, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club1)
# club2
p2 <- finluenceplot(alters = alters3, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club2)
# club 3
p3 <- finluenceplot(alters = alters3, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club3)
# club 4
p4 <- finluenceplot(alters = alters3, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club4)
# club 5
p5 <- finluenceplot(alters = alters3, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club5)

plot3 <- rbind(p1, p2, p3, p4, p5)
plot3$Club <- as.character(sort(rep(1:5, 7)))
plot3$scenario <- paste("C) Behavior alters:", paste0(alters3, collapse = ", "))

# scenario 4 club1
p1 <- finluenceplot(alters = alters4, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club1)
# club2
p2 <- finluenceplot(alters = alters4, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club2)
# club 3
p3 <- finluenceplot(alters = alters4, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club3)
# club 4
p4 <- finluenceplot(alters = alters4, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club4)
# club 5
p5 <- finluenceplot(alters = alters4, min = 1, max = 7, results = T, plot = F, fun = list(flinear, fquad,
    favAttHigher, favAttLower), params = club5)

plot4 <- rbind(p1, p2, p3, p4, p5)
plot4$Club <- as.character(sort(rep(1:5, 7)))
plot4$scenario <- paste("D) Behavior alters:", paste0(alters4, collapse = ", "))


multiplot2 <- rbind(plot1, plot2, plot3, plot4)
multiplot2$Attribute <- "Volume"

# merge them together
multiplot <- rbind(multiplot, multiplot2)

Plot

We create a nice multipanel plot of the different scenarios:

library(ggplot2)
library(lemon) # for repeating axis labels across facets
library(ggtext)  #for colorizing parts of the title. 

ggplot(
  data = multiplot, 
  aes(x, s, group=Club, color=Club)) + 
  geom_line(size = 1) + geom_point(aes(shape=Club), size = 2) +
  labs(
    title ="<b><span style = 'font-size:18pt'>Influence effects on running frequency</span></b><br><span style = 'font-size:14pt'>Evaluation of prospective behavior based on <i>linear</i> and <i>quadratic</i> shape effects and the <i>average attraction towards higher</i> and <i>lower</i> effects.",
       caption = "Notes: The y-axis represents the evaluation function statistic; the x-axis represents different values for ego’s prospective behavior. Lines represent the predicted ‘attractiveness’ of different behavior values. Panels A-D represent different scenarios with different values for the behavior of ego’s alters. Behavior dynamics presented here would be compounded had the objective function contained more effects (e.g., indegree, gender).") +
  
  scale_y_continuous(breaks = seq(-10, 20, by = 2.5)) +
  scale_x_continuous(breaks = seq(1, 7, by = 1)) +
  scale_shape_manual(values=c(rep(19, 5))) +
  scale_colour_manual(values=c("#E69F00", "#56B4E9", "#000000", "#009E73", "#F0E442")) +
  facet_grid(Attribute~scenario, 
             switch = "y"
  #         , scales = "free_y"
  ) +
  ylab("Evaluation function statistic") + xlab("Ego's prospective behavior") +
  
theme(plot.title = element_textbox_simple(
    padding = margin(5.5, 5.5, 5.5, 5.5),
    margin = margin(0, 0, 5.5, 0),
    fill = "lightsteelblue2",
    lineheight=1,
    r = grid::unit(8, "pt")),
    
    plot.caption = element_textbox_simple(
    padding = margin(2, 2, 2, 2),
    margin = margin(0, 0, 2, 0),
    fill = "lightsteelblue2",
    lineheight=1,
    vjust=1.5,
    r = grid::unit(8, "pt")),
    
    strip.text.x = element_textbox(
          size = 9,
          color = "white", fill = "#5D729D", box.color = "#4A618C",
          halign = 0.5, linetype = 1, r = unit(5, "pt"), width = unit(1, "npc"),
          padding = margin(2, 0, 1, 0), margin = margin(3, 3, 3, 3)
        ),
    
    strip.text.y = element_textbox_simple(
          size=12,
          face="bold",
          vjust=1),

    strip.background = element_blank(),
    strip.placement = "outside",
    
    axis.text.y = element_text(size=9),
        legend.position = "top",
        axis.line.y = element_line(color = "black", size=.6)
)

ggsave("infpl.pdf")

---

Copyright © 2021 Rob Franken