social_judgment_theory

social_judgment_theory.r

library(tidyverse)
library(igraph)
library(animation)

#individual check
#attribute: position (-5 to 5)
#attribute: lattitude of acceptance (range of +-1 )
#attribute: lattitude of noncommitment (range of +- 2)
#Specifically, it predicts that the more discrepant a message is from a listener’s own attitude (the greater the difference between the audience attitude and the position adopted in the message), as long as the message doesn’t fall into the latitude of rejection, the more persuasive that message will be.

position_pal <- colorRampPalette(c("#B58F62", '#FFFFFF', "#5B9C97"))(11)
names(position_pal) <- -5:5

setAttributes <- function(g){
  E(g)$diff <- abs(
    head_of(g, E(g))$position - tail_of(g, E(g))$position
  )
  
  E(g)$sign <- sapply(E(g)$diff, function(d){
    if(d <= 1) return('+')
    if(d <= 2) return('0')
    return('-')
  })
  
  V(g)$color <- sapply(V(g)$position, function(x){
    position_pal[x + 6]
  })
  
  E(g)$color <- sapply(E(g)$sign, function(x){
    eclr <- c('red', 'grey', 'green') #scales::brewer_pal('div', )(3)
    if(x == '-') return(eclr[1])
    if(x == '0') return(eclr[2])
    return(eclr[3])
  })
  
  return(g)
}

discussion <- function(g, e){
  etail <- tail_of(g,e)
  ehead <- head_of(g,e)
  
  direction <- etail$position - ehead$position
  
  direction <- direction/abs(direction)
  
  position <- list(etail = etail, ehead = ehead, direction = direction, sign = e$sign) %>%
    purrr::pmap_dbl(function(etail, ehead, direction, sign = sign){
      if(sign == '0') {
        p <- V(g)[ehead]$position + direction
      }
      
      if(sign == '-') {
        p <- V(g)[ehead]$position - direction
      }
      
      if(sign == '+'){
        p <- V(g)[ehead]$position
      }
      
      if(p > 5){p <- 5}
      if(p < -5){p <- -5}
      return(p)      
    })%>%
    as.integer()
  
  
  V(g)[ehead]$position <- position
  return(setAttributes(g))
}

create_model_full <- function(gSize = 100){
  g <- make_full_graph(gSize, T)
  V(g)$position = runif(vcount(g), -5, 5) %>% round()
  g <- setAttributes(g)
}


create_model_islands <- function(islands.n = 3, islands.size = 50, islands.pin = 1, n.inter = 5){
  g_communities <- igraph::sample_islands(islands.n, islands.size , 1, 5) %>% 
    as.directed() 
  
  tmp_communities <- lapply(1:islands.n, function(i){
    rep(i, islands.size)
  }) %>%
    do.call(c, .)
  
  g_communities <- g_communities %>%
  {V(.)$community <- tmp_communities; .} %>%
  {. - V(.)[degree(.) == 0]}
  
  V(g_communities)$position <- purrr::map_dbl(V(g_communities), function(v){
    if(v$community %% 3 == 0) return(sample(1:5, 1))
    if(v$community %% 2 == 0) return(sample(-2:2, 1))
    return(sample(-5:1, 1))
  }) %>%
    as.integer()
  
  g_communities
}

summarize_changes <- function(collection){
  collection %>% 
    purrr::imap(function(x, i){
      V(x$g)$position %>%
        table %>%
        tibble::as_tibble() %>%
        dplyr::mutate(index = i)
    }) %>%
    dplyr::bind_rows() %>%
    tidyr::spread('.', n) %>% 
    dplyr::mutate_if(is.integer, tidyr::replace_na, replace = 0) %>%
    tidyr::gather('position', n, -index)
}

create_position_change <- function(g, n.iter = 200, edgesPulled = 10, l = layout_nicely){
  g$layout <- l(g) 
  
  g <- setAttributes(g)
  
  collection <- list(
    list(
      g = g, 
      e = NULL
    )
  )
  
  purrr::map(2:n.iter, function(i){
    tmpG <- collection[[i-1]]$g
    
    n1 <- sample(V(tmpG), edgesPulled) %>%
      as.integer()
    n2 = purrr::map(n1, function(v){
      tmpE <- tmpG %>%
      {E(.)[v %->% V(.)]}
      
      head_of(tmpG, tmpE) %>%
        sample(1)
    }) %>%
      do.call(c, .) %>%
      as.integer()
    
    tmpE = purrr::map(1:edgesPulled, function(i){
      E(tmpG)[n1[i] %->% n2[i]]
    }) %>%
      do.call(c, .)
    
    collection[[i]] <<- list(
      g = discussion(tmpG, tmpE),
      e = tmpE,
      v = c(n1, n2)
    )
  })
  
  collection_summary <- summarize_changes(collection)
  
  return(list(collection = collection, summary = collection_summary))
}

animate_changes <- function(collection, filename){
  saveGIF({
    ani.options(ani.width = 800,
                ani.width = 800,
                interval = 1)
    
    purrr::imap(collection, function(x, i){
      if(is.null(x$e)){
        plot(x$g, main = paste0('All Potential Interactions at T = ', i),vertex.size = 5, vertex.label = '')
      } else {
        plot(x$g, 
             edge.color = if_else(E(x$g) %in% x$e, E(x$g)$color, 'transparent'), 
             main = paste('T =', i),
             vertex.size = 5, 
             vertex.label = '',
             vertex.frame.color='lightgrey'
        )
      }
    })
  }, movie.name = filename)
}

visualize_summary <- function(summary, title){
  ggplot2::ggplot(myCollectionSummary, ggplot2::aes(index, n)) +
    ggplot2::geom_path(size = 1, ggplot2::aes(color = position)) +
    ggplot2::scale_color_manual(values = position_pal) +
    ggplot2::theme_dark() +
    ggplot2::labs(title = title)
}


#####
## EXAMPLE
#####
g <- make_full_graph(5,T)
V(g)$position <- c(-3, -1, 1, 2, 3)
g$layout <- layout_in_circle(g)
V(g)$name <- LETTERS[1:vcount(g)]
V(g)$label <- V(g)$name

g1 <- setAttributes(g)

png('social_judge_01.png', 500, 500)
plot(g1, main = 'All Potential Interactions')
legend(1.2, 0, legend = c(-5, -3, 0, 3, 5), title = 'Position',fill = c(position_pal[1], position_pal[3], position_pal[6], position_pal[9], position_pal[11]))
dev.off()

tmpe <- E(g1)[head_of(g1, E(g1)) == 2 & tail_of(g1, E(g1)) == 3]

png('social_judge_02.png', 500, 500)
g1 %>%
  plot(main = 'C (+1) has a discussion with B (-1)', edge.color = if_else(E(.) == tmpe, E(.)$color, 'transparent'))
legend(1.2, 0, legend = c(-5, -3, 0, 3, 5), title = 'Position',fill = c(position_pal[1], position_pal[3], position_pal[6], position_pal[9], position_pal[11]))
dev.off()


############################
## Fully Connected
####################

set.seed(4321); g_medium <- create_model_full(100)

medium_collection <- create_position_change(g_medium, l = layout_in_circle)

animate_changes(medium_collection$collection, 'medium.gif')

visualize_summary(medium_collection$summary, '100 Nodes Fully Connected, 10 Interactions per Iteration ')

############
## Community 
###########

set.seed(4321); g_communities <- create_model_islands()

communities_collection <- create_position_change(g_communities, edgesPulled = 20)

animate_changes(communities_collection$collection, 'community.gif')

visualize_summary(communities_collection$summary, '20 edges per iteration' )