Created
February 7, 2019 18:52
-
-
Save beemyfriend/6282204f6e2ad729852c0b018583708d to your computer and use it in GitHub Desktop.
rehab cycle model factoring in relationships
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| library(igraph) | |
| library(animation) | |
| node_clr <- scales::brewer_pal()(6) | |
| ###===============================### | |
| ### initiate full graph influence ### | |
| ###===============================### | |
| addSimAtt <- function(g){ | |
| g %>% | |
| { | |
| set.seed(4321) | |
| V(.)$name = as.character(1:vcount(.)); | |
| V(.)$stubborn = runif(vcount(.)); | |
| V(.)$attitude = runif(vcount(.)) * .5; | |
| E(.)$like = runif(ecount(.)) %>% round() %>% as.logical(); | |
| E(.)$color = ifelse(E(.)$like, 'forestgreen', 'red'); | |
| V(.)$color = map_chr(V(.)$attitude, ~node_clr[round(.x * 10) + 1] ); | |
| V(.)$label = map_chr(V(.),~paste0(.x$name, '\n', round(.x$attitude, 2))); | |
| V(.)$label.color = ifelse(round(V(.)$attitude * 10) + 1 <= 4, 'black', 'white'); | |
| V(.)$label.cex = .5 | |
| E(.)$head = head_of(., E(.))$name | |
| E(.)$head_att = head_of(., E(.))$attitude | |
| E(.)$tail = tail_of(., E(.))$name | |
| E(.)$tail_att = tail_of(., E(.))$attitude | |
| E(.)$id = map2_chr(tail_of(., E(.))$name, head_of(., E(.))$name, function(x,y){ | |
| paste(min(c(x,y)), max(c(x,y))) | |
| }) | |
| E(.)$inWorld = T | |
| V(.)$usingDrugs = F | |
| l <- layout_nicely(.) | |
| V(.)$x = l[,1] | |
| V(.)$y = l[,2] | |
| V(.)$size = 15 | |
| E(.)$width = 2 | |
| . | |
| } | |
| } | |
| g <- igraph::make_full_graph(6) %>% | |
| addSimAtt() | |
| egoEffect <- function(g){ | |
| g_temp <- incident_edges(g, V(g)) %>% | |
| map_lgl(function(x){ | |
| x$like %>% | |
| table %>% | |
| sort(T) %>% | |
| .[1] %>% | |
| names %>% | |
| as.logical() | |
| }) %>% | |
| {V(g)$ego_att = .; g} | |
| g_temp <- V(g_temp)$ego_att %>% | |
| map2(incident_edges(g_temp, V(g_temp)), function(x,y){ | |
| y[[like == x]] | |
| }) %>% | |
| map(function(e){e %>% | |
| length %>% | |
| { | |
| x = e[1:.]; | |
| tibble( | |
| node = c(x$head, x$tail), | |
| att = c(x$head_att, x$tail_att) | |
| ) | |
| }}) %>% | |
| imap_dbl(function(x, n){ | |
| x %>% | |
| filter(node != n) %>% | |
| .$att %>% | |
| mean() | |
| }) %>% | |
| {V(g_temp)$ego_att_mean = .; g_temp}%>% | |
| {V(.)$change = map_dbl(V(.), ~.x$attitude - .x$ego_att_mean)/5; .}%>% | |
| {V(.)$change = ifelse(V(.)$ego_att, V(.)$change * -1, V(.)$change); .} %>% | |
| {V(.)$attitude = map_dbl(V(.), function(v){ | |
| a = v$attitude + v$change; | |
| if(a > .5) return(.5) | |
| if(a < 0) return(0) | |
| return(a) | |
| }); .} | |
| g_temp <- g_temp %>% | |
| { | |
| V(.)$color = map_chr(V(.)$attitude, ~node_clr[round(.x * 10) + 1] ); | |
| V(.)$label = map_chr(V(.),~paste0(.x$name, '\n', round(.x$attitude, 2))); | |
| V(.)$label.color = ifelse(round(V(.)$attitude * 10) + 1 <= 4, 'black', 'white'); | |
| E(.)$head = head_of(., E(.))$name | |
| E(.)$head_att = head_of(., E(.))$attitude | |
| E(.)$tail = tail_of(., E(.))$name | |
| E(.)$tail_att = tail_of(., E(.))$attitude; | |
| . | |
| } | |
| g_temp | |
| } | |
| g_list <- list(g) | |
| for(z in 1:20){ | |
| #get ego info | |
| g_temp <- g_list[[length(g_list)]] | |
| g_temp <- egoEffect(g_temp) | |
| g_list[[length(g_list) + 1]] <- g_temp | |
| } | |
| saveGIF({ | |
| imap(1:length(g_list), function(x, i){ | |
| print(plot(g_list[[x]], main = paste('T =', i), vertex.size = 50, vertex.label.cex = 2)) | |
| }) | |
| }, movie.name = "drug_attitude_influence_example_refa.gif", | |
| ani.width = 600) | |
| ###======================================### | |
| ### Initiate full community and rehab ===### | |
| ###======================================### | |
| # g_reference serves as a dictionary | |
| # for edge (like, dislike) and vertex info | |
| g_reference <- make_full_graph(18) %>% | |
| addSimAtt() | |
| #igraph::sample_islands(3, 6, 1, 0) %>% | |
| # { | |
| # set.seed(4321) | |
| # V(.)$name = paste0('Node ', 1:vcount(.)); | |
| # V(.)$stubborn = runif(vcount(.)); | |
| # V(.)$attitude = runif(vcount(.)) * .49; | |
| # E(.)$like = runif(ecount(.)) %>% round() %>% as.logical(); | |
| # E(.)$color = ifelse(E(.)$like, 'forestgreen', 'red'); | |
| # E(.)$id = map2_chr(tail_of(., E(.))$name, head_of(., E(.))$name, function(x,y){ | |
| # paste(min(c(x,y)), max(c(x,y))) | |
| # }) | |
| # V(.)$color = map_chr(V(.)$attitude, ~node_clr[round(.x * 10) + 1] ); | |
| # # V(.)$label = map_chr(V(.),~paste0(.x$name, '\n', round(.x$attitude, 2))); | |
| # V(.)$label.color = ifelse(round(V(.)$attitude * 10) + 1 <= 4, 'black', 'white'); | |
| # | |
| # E(.)$head = head_of(., E(.))$name | |
| # E(.)$head_att = head_of(., E(.))$attitude | |
| # E(.)$tail = tail_of(., E(.))$name | |
| # E(.)$tail_att = tail_of(., E(.))$attitude | |
| # | |
| # | |
| # E(.)$inWorld = T | |
| # V(.)$usingDrugs = F | |
| # | |
| # l <- layout_nicely(.) | |
| # V(.)$x = l[,1] | |
| # V(.)$y = l[,2] | |
| # V(.)$size = 15 | |
| # V(.)$label.cex = .75 | |
| # E(.)$width = 2 | |
| # . | |
| # } | |
| plot(g_reference, vertex.label.cex = .5) | |
| vAtt <- g_reference %>% | |
| vertex.attributes() %>% | |
| names %>% | |
| .[!. %in% c('x', 'y')] | |
| pullFromGDict <- function(g, dict){ | |
| g %>% | |
| { | |
| tempEgo <<-sample(V(dict)$name, vcount(.), F) %>% | |
| ego(dict, 0, .) | |
| V(.)$name <- map_chr(tempEgo, function(x){x$name}) | |
| V(.)$stubborn <- map_dbl(tempEgo, function(x){x$stubborn}) | |
| V(.)$attitude <- map_dbl(tempEgo, function(x){x$attitude}) | |
| V(.)$color <- map_chr(tempEgo, function(x){x$color}) | |
| V(.)$label.color <- map_chr(tempEgo, function(x){x$label.color}) | |
| V(.)$usingDrugs <- map_lgl(tempEgo, function(x){x$usingDrugs}) | |
| V(.)$size <- map_dbl(tempEgo, function(x){x$size}) | |
| V(.)$label.cex <- map_dbl(tempEgo, function(x){x$label.cex}) | |
| E(.)$id = map2_chr(tail_of(., E(.))$name, head_of(., E(.))$name, function(x,y){ | |
| paste(min(c(x,y)), max(c(x,y))) | |
| }) | |
| edgeList <- map(E(.)$id, function(e){ E(dict)[id == e]}) | |
| E(.)$like <- map_lgl(edgeList, function(e){e$like}) | |
| E(.)$color <- map_chr(edgeList, function(e){e$color}) | |
| E(.)$head <- map_chr(edgeList, function(e){e$head}) | |
| E(.)$head_att <- map_dbl(edgeList, function(e){e$head_att}) | |
| E(.)$tail <- map_chr(edgeList, function(e){e$tail}) | |
| E(.)$tail_att <- map_dbl(edgeList, function(e){e$tail_att}) | |
| E(.)$inWorld <- map_lgl(edgeList, function(e){e$inWorld}) | |
| E(.)$width <- map_dbl(edgeList, function(e){e$width}) | |
| l <- layout_nicely(.) | |
| V(.)$x = l[,1] | |
| V(.)$y = l[,2] | |
| V(.)$size = 15 | |
| V(.)$label.cex = .75 | |
| E(.)$width = 2 | |
| . | |
| } | |
| } | |
| g_population <- sample_islands(3, 6, 1, 0) %>% | |
| pullFromGDict(g_reference) | |
| # { | |
| # set.seed(4321) | |
| # tempEgo <<-sample(V(g_reference)$name, vcount(.), F) %>% | |
| # ego(g_reference, 0, .) | |
| # | |
| # V(.)$name <- map_chr(tempEgo, function(x){x$name}) | |
| # V(.)$stubborn <- map_dbl(tempEgo, function(x){x$stubborn}) | |
| # V(.)$attitude <- map_dbl(tempEgo, function(x){x$attitude}) | |
| # V(.)$color <- map_chr(tempEgo, function(x){x$color}) | |
| # V(.)$label.color <- map_chr(tempEgo, function(x){x$label.color}) | |
| # V(.)$usingDrugs <- map_lgl(tempEgo, function(x){x$usingDrugs}) | |
| # V(.)$size <- map_dbl(tempEgo, function(x){x$size}) | |
| # V(.)$label.cex <- map_dbl(tempEgo, function(x){x$label.cex}) | |
| # | |
| # E(.)$id = map2_chr(tail_of(., E(.))$name, head_of(., E(.))$name, function(x,y){ | |
| # paste(min(c(x,y)), max(c(x,y))) | |
| # }) | |
| # | |
| # edgeList <- map(E(.)$id, function(e){ print(e); print(E(g_reference)); E(g_reference)[id == e]}) | |
| # E(.)$like <- map_lgl(edgeList, function(e){e$like}) | |
| # E(.)$color <- map_chr(edgeList, function(e){e$color}) | |
| # E(.)$head <- map_chr(edgeList, function(e){e$head}) | |
| # E(.)$head_att <- map_dbl(edgeList, function(e){e$head_att}) | |
| # E(.)$tail <- map_chr(edgeList, function(e){e$tail}) | |
| # E(.)$tail_att <- map_dbl(edgeList, function(e){e$tail_att}) | |
| # E(.)$inWorld <- map_lgl(edgeList, function(e){e$inWorld}) | |
| # E(.)$width <- map_dbl(edgeList, function(e){e$width}) | |
| # | |
| # l <- layout_nicely(.) | |
| # V(.)$x = l[,1] | |
| # V(.)$y = l[,2] | |
| # V(.)$size = 15 | |
| # V(.)$label.cex = .75 | |
| # E(.)$width = 2 | |
| # . | |
| # } | |
| plot(g_population) | |
| g_pop_list <- list(g_population) | |
| for(z in 1:20){ | |
| #get ego info | |
| g_temp <- g_pop_list[[length(g_pop_list)]] | |
| g_temp <- egoEffect(g_temp) | |
| g_pop_list[[length(g_pop_list) + 1]] <- g_temp | |
| } | |
| saveGIF({ | |
| imap(1:length(g_pop_list), function(x, i){ | |
| g_pop_list[[x]] %>% | |
| plot( | |
| main = paste('T =', i), | |
| vertex.label = round(V(.)$attitude, 2) | |
| ) %>% | |
| print() | |
| }) | |
| }, movie.name = "drug_attitude_influence_example_commun.gif", | |
| ani.width = 600) | |
| tRehab = list(c()) | |
| g_population %>% | |
| {V(.)$usingDrugs = map_lgl(V(.), function(x){(x$attitude * 2 ) < runif(1)}) ; .} %>% | |
| {tRehab[[length(tRehab) + 1]] <<- V(.)[usingDrugs]; .} %>% | |
| plot( | |
| vertex.shape = map_chr(V(.), function(v){ | |
| if(v$usingDrugs) return('none') | |
| return('circle') | |
| }), | |
| vertex.label = map_chr(V(.), function(v){ | |
| if(v$usingDrugs) return('') | |
| return(v$name) | |
| }), | |
| edge.color = map_chr(E(.), function(e){ | |
| if(T %in% c(head_of(., e)$usingDrugs, tail_of(., e)$usingDrugs)) return('transparent') | |
| return(e$color) | |
| }) | |
| ) | |
| t2rehab_g <- tRehab[[2]]$name %>% | |
| (function(x){ | |
| sample_islands(length(x), ceiling(length(x)/2), 1, 0) %>% | |
| {if(vcount(.) > length(x)){. - V(.)[(length(x) + 1):vcount(.)]}}%>% | |
| {V(.)$name = x; .} | |
| }) %>% | |
| pullFromGDict(g_reference) | |
| ### create new edge if doesn't exist | |
| ### use below as logical | |
| #E(g_reference)['Node 2' %--% 'Node 1'] %>% length() %>% as.logical() | |
| #E(g_reference)['Node 11' %--% 'Node 1'] %>% length() %>% as.logical() | |
| plot(t2rehab_g, asp = 0) | |
| t2g_ref <- g_reference + edges |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment