Skip to content

Instantly share code, notes, and snippets.

@beemyfriend

beemyfriend/circlecolorgame.R

Created September 25, 2018 21:51
Show Gist options
  • Save beemyfriend/2e4e52bc788c0df7d2f798c5ee38bd89 to your computer and use it in GitHub Desktop.
Save beemyfriend/2e4e52bc788c0df7d2f798c5ee38bd89 to your computer and use it in GitHub Desktop.
Download ZIP
Playing around with the color game
Raw
circlecolorgame.R
library(tidyverse)
library(igraph)
library(animation)
library(grid)
library(gridGraphics)
############
## Only working with 3 possible colora
############
chooseColor = c("#e41a1c", "#377eb8", "#4daf4a")
names(chooseColor) <- chooseColor
#############
## If random number is greater than stubbornes of node
## then node changes perceived color to match the majority
## of it's four closest neighbors
##############
checkColors <- function(g){
map_chr(V(g), function(x){
if(runif(1) >= x$stubborn){
newColor <- ego(g, x, order = 1, mindist = 1)[[1]] %>%
.$pColor %>%
table() %>%
.[. == max(.)] %>%
names() %>%
.[ceiling(runif(1, 0, length(.)))]
return(newColor)
}
return(x$pColor)
})
}
##############
## Boolean to detect whether all
## nodes are in agreement or not
##############
hasMultiColor <- function(gList){
gList %>%
.[[length(.)]] %>%
V() %>%
.$pColor %>%
table %>%
length != 1
}
######
## Create concept graph
######
set.seed(4321)
g <- sample_smallworld(1, 25, nei = 2, 0)
#######
## Initialize each node with a perceived color choice
#######
perceivedColor <- runif(vcount(g), 0, length(chooseColor)) %>%
ceiling() %>%
map_chr(function(x){
chooseColor[x]
})
########
## Initialize each node with a stubborness factor
########
stubborness <- runif(vcount(g), .1, .9)
V(g)$pColor <- perceivedColor
V(g)$stubborn <- stubborness
E(g)$label = ''
l <- layout_in_circle(g)
########
## Create a list full of graphs
## to animate
###########
graphIterations = list(g)
while(hasMultiColor(graphIterations) & length(graphIterations) <= 300){
temp <- graphIterations[[length(graphIterations)]]
V(temp)$pColor <- checkColors(temp)
graphIterations[[length(graphIterations) + 1]] <- temp
}
#######
## What colors are perceived at each time T
########
colorSum <- imap(graphIterations, function(x, i){
clr <- table(V(x)$pColor)
map(chooseColor, function(y){
tibble(
iteration = i - 1,
color = y,
amount = ifelse(!is.na(clr[y]), clr[y], 0)
)
}) %>%
bind_rows()
}) %>%
bind_rows()
##############
## Create an animation
## doesn't always work, I think the print statement
## helps by giving it time to think. I need to improve
## grid graphic knowledge
#############
gridAnimPrep <- map(seq(max(colorSum$iteration)), function(i){
print(i)
#######
##circle graph grob
#######
tempG <- graphIterations[[i+1]]
plot(tempG,
layout = l,
vertex.label = round(V(tempG)$stubborn, 2),
vertex.label.cex = .6,
vertex.label.font = 2,
vertex.label.color = 'antiquewhite',
vertex.size = 40,
vertex.color = V(tempG)$pColor,
edge.arrow.size = .1)
grid.echo()
a <- grid.grab()
###########
## linechart grob
##########
b <- ggplot(filter(colorSum, iteration <= i), aes(x=iteration, y = amount/25, color = color)) +
geom_line() +
scale_color_manual(values = chooseColor) +
ylim(0, 1) +
xlim(0, max(colorSum$iteration)) +
theme_bw() +
labs(color = 'Category', x = 'T', y = '% Acceptance')
b <- ggplotGrob(b)
grid.newpage()
pushViewport(viewport(x = .25, y = .5, width=1.25, height= 1.25))
grid.draw(a)
popViewport()
grid.draw(textGrob(str_glue('Color Game: n-degree = 4, T = {i}'),x = .5, y = .1))
grid.draw(textGrob("What color is X?", x = .5, y= .9))
pushViewport(viewport(x = .75, y = .5, width=.5, height=.5))
grid.draw(b)
popViewport()
finalChart <- grid.grab()
grid.draw(finalChart)
})
saveGIF({
ani.options(ani.width = 1000,
ani.width = 1000,
interval = .3)
graphIterations[[1]] %>%
plot(.,
layout = l,
vertex.label = round(V(.)$stubborn, 2),
vertex.label.cex = .7,
vertex.label.font = 2,
vertex.label.color = 'antiquewhite',
vertex.size = 18,
vertex.color = V(.)$pColor,
edge.arrow.size = .1)
title(str_glue("Color Game: n-degree = 4, T = 1"))
map(seq(length(gridAnimPrep)), function(i){
grid.newpage()
grid.draw(gridAnimPrep[[i]])
})
}, movie.name = 'colorgamecircle.gif')
########
## Repeate simulation
## as a functin
###########
colorGameTrial <- function(){
g <- sample_smallworld(1, 25, nei = 2, 0)
perceivedColor <- runif(vcount(g), 0, length(chooseColor)) %>%
ceiling() %>%
map_chr(function(x){
chooseColor[x]
})
stubborness <- runif(vcount(g), .1, .9)
V(g)$pColor <- perceivedColor
V(g)$stubborn <- stubborness
graphIterations = list(g)
while(hasMultiColor(graphIterations) & length(graphIterations) <= 300){
temp <- graphIterations[[length(graphIterations)]]
V(temp)$pColor <- checkColors(temp)
graphIterations[[length(graphIterations) + 1]] <- temp
}
colorSum <- imap(graphIterations, function(x, i){
clr <- table(V(x)$pColor)
map(chooseColor, function(y){
tibble(
iteration = i - 1,
color = y,
amount = ifelse(!is.na(clr[y]), clr[y], 0)
)
}) %>%
bind_rows()
}) %>%
bind_rows()
}
#########
## Repeate simulation 100 times
#########
set.seed(4321)
test <- map(seq(100), function(x){colorGameTrial()})
test2 <- imap(test, function(x, i){
x %>%
mutate(
color_group = str_glue("{color}_{i}"),
test_group = i
)
}) %>%
bind_rows()
test3 <- test2 %>%
group_by(test_group) %>%
nest() %>%
filter(
map_lgl(data, function(x){
max(x$iteration) < 300
})
) %>%
mutate(
data = map(data, function(x){
firstPlace <- x %>%
tail(3) %>%
filter(amount > 0) %>%
.$color %>%
.[[1]]
finalIt <- max(x$iteration)
finalAmnt <- max(x$amount)
secondPlace <- x %>%
filter(color != firstPlace) %>%
filter(amount != 0) %>%
tail(1) %>%
.$color %>%
.[[1]]
winner <- filter(x, color == firstPlace) %>%
mutate(
iteration = iteration/finalIt,
amount = amount/finalAmnt,
position = 'Winner'
) %>%
{rbind(filter(., amount != 0), head(filter(., amount == 0), 1))}
second <- filter(x, color == secondPlace)%>%
mutate(
iteration = iteration/finalIt,
amount = amount/finalAmnt,
position = 'Second'
) %>%
{rbind(filter(., amount != 0), head(filter(., amount == 0), 1))}
third <- filter(x, !color %in% c(firstPlace, secondPlace)) %>%
mutate(
iteration = iteration/finalIt,
amount = amount/finalAmnt,
position = 'Third'
) %>%
{rbind(filter(., amount != 0), head(filter(., amount == 0), 1))}
rbind(winner,second,third) %>%
mutate(position = factor(position, c("Winner", "Second", "Third")))
})
) %>%
unnest()
png("simulation_trials.png", 1200, 800)
ggplot(test3, aes(x=iteration, y = amount)) +
geom_line(aes(group = test_group), alpha = .1) +
ylim(0, 1) +
theme_bw() +
labs(title = str_glue("Simulation Ran {test3$test_group %>% unique %>% length()} Times"),
x = '% T',
y = '% Acceptance',
subtitle = 'Fitted with a quadratic curve') +
facet_wrap(~position) +
stat_smooth(method = "lm", formula = y ~ x + I(x^2))
dev.off()
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment