Skip to content

Instantly share code, notes, and snippets.

@beemyfriend

beemyfriend/social_judgment_theory.r

Created May 1, 2019 05:55
Show Gist options
  • Save beemyfriend/b1fed1a1cf50ef72a9179baa6d986edf to your computer and use it in GitHub Desktop.
Save beemyfriend/b1fed1a1cf50ef72a9179baa6d986edf to your computer and use it in GitHub Desktop.
Download ZIP
social_judgment_theory
Raw
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' )
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment