# MIT License # # Copyright (c) 2019 Marco Smolla and Susan Perry # # Permission is hereby granted, free of charge, to any person obtaining a copy # of this software and associated documentation files (the "Software"), to deal # in the Software without restriction, including without limitation the rights # to use, copy, modify, merge, publish, distribute, sublicense, and/or sell # copies of the Software, and to permit persons to whom the Software is # furnished to do so, subject to the following conditions: # # The above copyright notice and this permission notice shall be included in all # copies or substantial portions of the Software. # # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR # IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, # FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE # AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER # LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, # OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE # SOFTWARE. # # # # Programming code to re-create figures and statistics from the publication: # # Explaining capuchin monkey interaction rituals: a Tinbergian approach # # by Susan Perry (Dept. of Anthropology, University of California-Los Angeles, # 341 Haines Hall, 375 Portola Plaza, Los Angeles, CA 90095-1553) and # Marco Smolla (Dept. of Biology, Univ. of Pennsylvania, 433 S. University Ave., # Pennsylvania, PA 19104) # Data File Location (change this to the location of RawData.xlsx on your computer) FILE <- "PATH/TO/RawData.xlsx" # Load libraries ################ ## Data handling library(dplyr) library(reshape2) library(tidyverse) ## I/O: library(readxl) ## Networks: library(igraph) ## Plotting: library(cowplot); theme_set(theme_cowplot()) library(ggplot2) ## Stats: library(lme4) library(ape) # devtools::install_github("wpeterman/ResistanceGA", ref = "julia_dev") # for the latest version of ResistanceGA library(ResistanceGA) # Set Functions ############### # Sets shapes and colours for males, females, and infants in a fiven network if a vector of male and female names is supplied setNetShapes <- function(NET, MALES, FEMALES){ # INFANTS V(NET)$shape <- "csquare" V(NET)$shape_col <- "grey" V(NET)$label_col <- "black" # FEMALES V(NET)[V(NET)$name%in%FEMALES]$shape <- "circle" V(NET)[V(NET)$name%in%FEMALES]$shape_col <- "white" V(NET)[V(NET)$name%in%FEMALES]$label_col <- "black" # MALES V(NET)[V(NET)$name%in%MALES]$shape <- "square" V(NET)[V(NET)$name%in%MALES]$shape_col <- "black" V(NET)[V(NET)$name%in%MALES]$label_col <- "white" return(NET) } # Sets colours based on matriline setNetMatrilines <- function(NET, MATRILINE1, MATRILINE2){ # MATRILINES V(NET)$frame.color <- "black" V(NET)[V(NET)$name%in%MATRILINE1]$frame.color <-"#1874CD" #blue V(NET)[V(NET)$name%in%MATRILINE2]$frame.color <- "#EE2C2C" #red return(NET) } # Turning three columns (m1, m2, value) into a m1 x m2 matrix col2mat <- function(from, to, value, fillWith=NA){ ind <- sort(unique(c(from, to))) m <- matrix(fillWith, ncol=length(ind), nrow=length(ind)) m[cbind(match(from, ind), match(to, ind))] <- value m[cbind(match(to, ind), match(from, ind))] <- value # diag(m) <- 0 dat <- as.data.frame(m, row.names=ind) colnames(dat) <- ind return(dat) } ########### # par(mar=c(0,0,0,0)) # FIGURE 2A ######################## # Load group census data # Read file censusFL <- read_xlsx(path=FILE, range="A1:H54", sheet="censusFL") # Determine males males <- unique(censusFL$MONKEY[which(censusFL$sex=="m")]) #censusFL$father, # Determine females females <- unique(censusFL$MONKEY[which(censusFL$sex=="f")]) # Determine monkeys that are considered part of Flakes Group flMembers <- censusFL$MONKEY[censusFL$`tenure in grp`>=180] # Load PROXIMITY data fl_sri_all <- read_xlsx(path=FILE, range="A1:G763", sheet="proximity_rituals", col_types=c("text", "text","numeric","numeric","numeric","numeric","numeric")) head(fl_sri_all) # Create network net_fl_sri_all <- graph.data.frame(d=data.frame(from=fl_sri_all$m1, to=fl_sri_all$m2, sri=fl_sri_all$SRI), directed=T) %>% igraph::simplify(.,remove.multiple=F,remove.loops=T) # Remove edges with weights below mean net_fl_sri_all <- delete_edges(net_fl_sri_all, E(net_fl_sri_all)[sri<(mean(sri))]) # Remove self-loops E(net_fl_sri_all)$arrow.mode <- 0 # Set shapes for males and females net_fl_sri_all_shapes <- setNetShapes(net_fl_sri_all, males, females) # Set colours for matrilines net_fl_sri_all_shapes<- setNetMatrilines(NET=net_fl_sri_all_shapes, MATRILINE1=unlist(censusFL[censusFL$MATRILINE==1, "MONKEY"]), MATRILINE2=unlist(censusFL[censusFL$MATRILINE==2, "MONKEY"])) # Set coordinates for nodes set.seed(8) coords <- layout.fruchterman.reingold(net_fl_sri_all_shapes) # Plot network based greedy community detection algorithm cfg <- cluster_fast_greedy(as.undirected(net_fl_sri_all_shapes)) plot(cfg, vertex.label.family="sans", (net_fl_sri_all_shapes), layout=coords, vertex.size=9, edge.width=30*E(net_fl_sri_all_shapes)$sri, edge.color="black", mark.groups=NULL ,main="Social network" ) # FIGURE 2B ################### # Read file fl_rq_ritual <- read_xlsx(path=FILE, range="A1:J694", col_types=c("text", "text","text","numeric","numeric","numeric","numeric","numeric","numeric","numeric"), sheet="rqi_rituals") head(fl_rq_ritual) # Create network based on rituals rate net_fl_rq_ritual <- graph.data.frame(d=data.frame(from=fl_rq_ritual$m1, to=fl_rq_ritual$m2, ritualFreq=fl_rq_ritual$ritualcount / fl_rq_ritual$psgstotal, ritualcount=fl_rq_ritual$ritualcount), directed=T) %>% igraph::simplify(.,remove.multiple=F,remove.loops=T) # Remove edges where edge weights are below the mean net_fl_rq_ritual <- delete_edges(net_fl_rq_ritual, E(net_fl_rq_ritual)[ritualFreq<(mean(ritualFreq))]) # Remove self-loops E(net_fl_rq_ritual)$arrow.mode <- 0 # Set shapes for males and females net_fl_rq_ritual_shapes <- setNetShapes(net_fl_rq_ritual, males, females) # Set colours for matrilines net_fl_rq_ritual_shapes<- setNetMatrilines(NET=net_fl_rq_ritual_shapes, MATRILINE1=unlist(censusFL[censusFL$MATRILINE==1, "MONKEY"]), MATRILINE2=unlist(censusFL[censusFL$MATRILINE==2, "MONKEY"])) # Set coordinates for nodes coords_rit <- coords[match(names(V(net_fl_rq_ritual_shapes)), names(V(net_fl_sri_all_shapes))), ] # Plot network plot(net_fl_rq_ritual_shapes, vertex.shape=V(net_fl_rq_ritual_shapes)$shape, vertex.color=V(net_fl_rq_ritual_shapes)$shape_col, vertex.label.color=V(net_fl_rq_ritual_shapes)$label_col, vertex.frame.color=V(net_fl_rq_ritual_shapes)$frame.color, edge.width=3000*E(net_fl_rq_ritual_shapes)$ritualFreq, vertex.label.family="sans", vertex.label.cex=1.1, vertex.size=9, edge.color="black", vertex.label.size=20, layout=coords_rit ,main="Rituals network" ) # FIGURE 2C ################### # Read file detailsByDyad <- read_xlsx(path=FILE, sheet="ritual_details", range="A1:M447") # Individual behaviours behaviours <- c("finger in or on nose", "finger in mouth", "toy game", "hair game", "game_other", "eyepoke", "dental_exam", "backwhack", "suck_chew_kiss", "handholding") # Which columns contain these behaviours? colu <- which(names(detailsByDyad)%in%behaviours) # Turn NA rows into 0's detailsByDyad[,colu][is.na(detailsByDyad[,colu])] <- 0 # Return dyad members detailsByDyad <- detailsByDyad %>% separate(col="dyad", sep="-", into=c("from","to"), remove=F) head(detailsByDyad) %>% as.data.frame() # Only keep games detailsByDyad_games <- detailsByDyad[detailsByDyad$`toy game`==1 | detailsByDyad$`hair game`==1 | detailsByDyad$game_other==1, ] ritualCount <- table(detailsByDyad_games$dyad) allRitualsEver_game <- data.frame(dyad = names(ritualCount), ritualCount = as.numeric(ritualCount)) # rituals/lines of table not indiv. behaviours # use opportunity instead of proximity, because proximity might not always be recorded correctly if a ritual is observed allRitualsEver_game$coocurrence <- unlist(fl_rq_ritual[match(allRitualsEver_game$dyad, fl_rq_ritual$dyad),"psgstotal"]) # Create a from and a to column allRitualsEver_game[,c("m1","m2")] <- do.call("rbind", strsplit(as.character(allRitualsEver_game$dyad),"-")) # Calculate rituals rate allRitualsEver_game$ritualFreq <- allRitualsEver_game$ritualCount / allRitualsEver_game$coocurrence # Set up network allRitualsEver_net <- graph_from_data_frame(allRitualsEver_game[,c("m1","m2","ritualFreq","ritualCount")]) # Set shapes for males and females allRitualsEver_net <- setNetShapes(allRitualsEver_net, males, females) # Set colours for matrilines allRitualsEver_net <- setNetMatrilines(allRitualsEver_net, MATRILINE1=unlist(censusFL[censusFL$MATRILINE==1, "MONKEY"]), MATRILINE2=unlist(censusFL[censusFL$MATRILINE==2, "MONKEY"])) # Remove self-loops E(allRitualsEver_net)$arrow.mode <- 0 # Set coordinates for nodes coords_rit_game <- coords[match(names(V(allRitualsEver_net)), names(V(net_fl_sri_all_shapes))), ] # Plot network plot(allRitualsEver_net, vertex.shape=V(allRitualsEver_net)$shape, vertex.color=V(allRitualsEver_net)$shape_col, vertex.label.color=V(allRitualsEver_net)$label_col, vertex.frame.color=V(allRitualsEver_net)$frame.color, edge.width=7000*E(allRitualsEver_net)$ritualFreq, vertex.label.family="sans", vertex.label.cex=1.1, vertex.size=9, edge.color="black", vertex.label.size=20, layout=coords_rit_game ,main="Games network" ) # FIGURE 3 ################### # Correlating an individual's degree in the rituals network (y-axis) with the degree in the social network (x-axis) # Calculate degree in PROXIMITY network deg_prox <- degree(net_fl_sri_all_shapes) # Calculate degree in RITUALS network deg_rit <- degree(net_fl_rq_ritual_shapes) # Create data frame tmp <- data.frame(monkey = names(deg_prox), deg_prox = deg_prox, deg_rit = 0, row.names = NULL) # Add degree from RITUALS network to said data frame tmp$deg_rit[match(names(deg_rit), names(deg_prox))] <- deg_rit # Convert monkey names into strings tmp$monkey <- as.character(tmp$monkey) # Add matriline information tmp$matriline <- censusFL$MATRILINE[match(tmp$monkey,censusFL$MONKEY)] # Change male names to lowercase tmp$monkey[tmp$monkey%in%males] <- tolower(tmp$monkey[tmp$monkey%in%males]) # Plot network set.seed(5) ggplot(tmp, aes(x=deg_prox, deg_rit)) + stat_smooth(method='lm', col="darkgrey", se=F) + geom_text(aes(label=monkey, col=factor(matriline)), position=position_jitter(width=1,height=1)) + scale_color_manual(values=c("black", "#1874CD", "#EE2C2C")) + xlab("Degree centrality social network") + ylab("Degree centrality ritual network") + theme(axis.line=element_blank(), legend.position="", text=element_text(family="serif")) + panel_border(size=1, colour="black") # Statistical analysis mod <- lm(deg_prox~deg_rit) summary(mod) # Statisitcal Analysis - Mantel Test #################################### ## ## Ritual and Proximity # Set up PROXIMITY matrix fl_sri_all_mat <- col2mat(from = fl_sri_all$m1, to = fl_sri_all$m2, value=fl_sri_all$SRI, fillWith=0)#[!fl_sri_all$m1%in%c("HGL","CHI")]) # Set up RITUALS matrix fl_sri_all_rit_mat <- col2mat(from = fl_sri_all$m1, to = fl_sri_all$m2, value=fl_sri_all$ritualcount/fl_sri_all$psgstotal, fillWith=0) # Calculate Mantel Statistic mantel_sri_rit <- mantel.test(m1=fl_sri_all_mat, m2=fl_sri_all_rit_mat, nperm=5000, graph=T) # Basic Mantel statistic is simply the sum of the products of the corresponding elements of the matrices, and so should be the same as: sum(fl_sri_all$SRI * (fl_sri_all$ritualcount/fl_sri_all$psgstotal)) / 2 # Calculating correlation coefficient x = fl_sri_all$SRI y = (fl_sri_all$ritualcount/fl_sri_all$psgstotal) N = length(x) Sx = sqrt( (sum((x-mean(x))^2) )/N ) # SD of X Sy = sqrt( (sum((y-mean(y))^2) )/N ) # SD of Y r = sum( (x-mean(x)) * (y-mean(y)) ) / (N*Sx*Sy) cat("Correlation coefficient (normalized Mantel coefficient), r =",round(r,3)) # Store information mantel_sri_rit$corrCoef <- round(r,3) ## ## Ritual and RQI # Set up RQI matrix fl_rq_ritual_mat <- col2mat(from = fl_rq_ritual$m1, to = fl_rq_ritual$m2, value=fl_rq_ritual$RQ_SEP, fillWith=0) # Set up RITUALS matrix fl_rq_ritual_rit_mat <- col2mat(from = fl_rq_ritual$m1, to = fl_rq_ritual$m2, value=fl_rq_ritual$ritualcount/fl_rq_ritual$psgstotal, fillWith=0) # Calculate Mantel Statistic mantel_rqi_rit <- mantel.test(m1=fl_rq_ritual_mat, m2=fl_rq_ritual_rit_mat, nperm=5000, graph=T) # Should be the same as: sum(fl_rq_ritual$RQ_SEP * (fl_rq_ritual$ritualcount/fl_rq_ritual$psgstotal)) / 2 # Calculating correlation coefficient x=fl_rq_ritual$RQ_SEP y=fl_rq_ritual$ritualcount/fl_rq_ritual$psgstotal N=length(x) Sx=sqrt( (sum((x-mean(x))^2) )/N ) Sy=sqrt( (sum((y-mean(y))^2) )/N ) r = sum( (x-mean(x)) * (y-mean(y)) ) / (N*Sx*Sy) cat("Correlation coefficient (normalized Mantel coefficient), r =",round(r,3)) # Store information mantel_rqi_rit$corrCoef <- round(r,3) ## ## Ritual and Coalitions # Load data fl_coalitions_ritual <- read_xlsx(path=FILE, col_types=c("text", "text","numeric","numeric","numeric","text","numeric","numeric"), sheet="coalitions_rituals", range="A1:H677") # Set up COALITIONS matrix fl_coalitions_ritual_mat <- col2mat(from = fl_coalitions_ritual$m1, to = fl_coalitions_ritual$m2, value=fl_coalitions_ritual$n_coalitions/(fl_coalitions_ritual$coalitions_offset/1000), fillWith=0) # Set up RITUALS matrix fl_coalitions_ritual_rit_mat <- col2mat(from = fl_coalitions_ritual$m1, to = fl_coalitions_ritual$m2, value=fl_coalitions_ritual$ritual_count/fl_coalitions_ritual$psgstotal, fillWith=0) # Calculate Mantel Statistic mantel_coa_rit <- mantel.test(m1=fl_coalitions_ritual_mat, m2=fl_coalitions_ritual_rit_mat, nperm=5000, graph=T) # Should be the same as sum(fl_coalitions_ritual$coalitions_index * (fl_coalitions_ritual$ritual_count/fl_coalitions_ritual$psgstotal)) / 2 # Calculating correlation coefficient x=fl_coalitions_ritual$coalitions_index y=fl_coalitions_ritual$ritual_count/fl_coalitions_ritual$psgstotal N=length(x) Sx=sd(x) # sqrt( (sum((x-mean(x))^2) )/N ) Sy=sd(y) # sqrt( (sum((y-mean(y))^2) )/N ) r = sum( (x-mean(x)) * (y-mean(y)) ) / (N*Sx*Sy) cat("Correlation coefficient (normalized Mantel coefficient), r =",round(r,3)) # Store information mantel_coa_rit$corrCoef <- round(r,3) # Combine results in a data.frame res <- t(cbind(mantel_sri_rit, mantel_rqi_rit, mantel_coa_rit)) # Round values for the looks res[,1:2] <- round(as.numeric(res[,1:2]),3) # Return results as.data.frame(res, row.names=c("Ritual ~ Proximity","Ritual ~ RQI","Ritual ~ Coalition")) # Statistical Analysis - MLPE & LMER #################################### ## ## Ritual and PROXIMITY # Add ritual rate column fl_sri_all$ritFreq <- (fl_sri_all$ritualcount/fl_sri_all$psgstotal) # Rescaling values fl_sri_all$sri_s <- (fl_sri_all$SRI - mean(fl_sri_all$SRI)) / sd(fl_sri_all$SRI) fl_sri_all$rit_s <- (fl_sri_all$ritFreq - mean(fl_sri_all$ritFreq)) / sd(fl_sri_all$ritFreq) # Create square 'distance' matrices sri <- col2mat(from=fl_sri_all$m1,to=fl_sri_all$m2,value=fl_sri_all$sri_s) rit <- col2mat(from=fl_sri_all$m1,to=fl_sri_all$m2,value=fl_sri_all$rit_s) # Create a vector of observations to 'keep' in the analysis (i.e. remove the NA) keep <- lower(sri) keep <- ifelse(is.na(keep), 0, 1) # The population in this sense is referring to the pop/individual that pairwise comparisons are made between id <- To.From.ID(nrow(sri)) # Create data frame df <- data.frame(sri = lower(sri), rit = lower(rit), individual = id$pop1, keep = keep) # Fit MLPE model out <- mlpe_rga(formula = rit ~ sri + (1 | individual), data = df, keep = keep) # View results summary(out) # Fit LMER model mod2 <- lmer(data=fl_sri_all, formula=rit_s ~ sri_s + (1 | m1)) # View results summary(mod2) ## ## Ritual and RQI # Add ritual rate column fl_rq_ritual$ritFreq <- fl_rq_ritual$ritualcount/fl_rq_ritual$psgstotal # Rescaling values fl_rq_ritual$rq_s <- (fl_rq_ritual$RQ_SEP - mean(fl_rq_ritual$RQ_SEP)) / sd(fl_rq_ritual$RQ_SEP) fl_rq_ritual$rit_s <- (fl_rq_ritual$ritFreq - mean(fl_rq_ritual$ritFreq)) / sd(fl_rq_ritual$ritFreq) # Create square 'distance' matrices rqu <- col2mat(from=fl_rq_ritual$m1,to=fl_rq_ritual$m2,value=fl_rq_ritual$rq_s) rit <- col2mat(from=fl_rq_ritual$m1,to=fl_rq_ritual$m2,value=fl_rq_ritual$rit_s) # Create a vector of observations to 'keep' in the analysis (i.e. remove the NA) keep <- lower(rqu) keep <- ifelse(is.na(keep), 0, 1) # The population in this sense is referring to the pop/individual that pairwise comparisons are made between id <- To.From.ID(nrow(rqu)) # Create data frame df <- data.frame(rqu = lower(rqu), rit = lower(rit), individual = id$pop1, keep = keep) # Fit MLPE model out2 <- mlpe_rga(formula = rit ~ rqu + (1 | individual), data = df, keep = keep) # View results summary(out2) # Fit LMER model mod2 <- lmer(data=fl_rq_ritual, formula=rit_s ~ rq_s + (1 | m1)) # View results summary(mod2) ## ## Rituals ~ Coalitions # Add ritual rate column fl_coalitions_ritual$ritFreq <- fl_coalitions_ritual$ritual_count/fl_coalitions_ritual$psgstotal # Add coalitions rate column fl_coalitions_ritual$coalitions_rate <- fl_coalitions_ritual$n_coalitions/(fl_coalitions_ritual$coalitions_offset/1000) # Rescaling values fl_coalitions_ritual$coa_s <- (fl_coalitions_ritual$coalitions_rate - mean(fl_coalitions_ritual$coalitions_rate)) / sd(fl_coalitions_ritual$coalitions_rate) fl_coalitions_ritual$rit_s <- (fl_coalitions_ritual$ritFreq - mean(fl_coalitions_ritual$ritFreq)) / sd(fl_coalitions_ritual$ritFreq) # Create square 'distance' matrices coa <- col2mat(from=fl_coalitions_ritual$m1,to=fl_coalitions_ritual$m2,value=fl_coalitions_ritual$coa_s) rit <- col2mat(from=fl_coalitions_ritual$m1,to=fl_coalitions_ritual$m2,value=fl_coalitions_ritual$rit_s) # Create a vector of observations to 'keep' in the analysis (i.e. remove the NA) keep <- lower(coa) keep <- ifelse(is.na(keep), 0, 1) # The population in this sense is referring to the pop/individual that pairwise comparisons are made between id <- To.From.ID(nrow(coa)) # Create data frame df <- data.frame(coa = lower(coa), rit = lower(rit), individual = id$pop1, keep = keep) # Fit MLPE model out3 <- mlpe_rga(formula = rit ~ coa + (1 | individual), data = df, keep = keep) # View results summary(out3) # Fit LMER model mod2 <- lmer(data=fl_coalitions_ritual, formula=rit_s ~ coa_s + (1 | m1)) # View results summary(mod2) # FIGURE 1 ################### # Plotting results and regression lines from MLPE pp_sri <- ggplot(fl_sri_all) + geom_abline(slope= summary(out)$coefficients[2,1] * (sd(fl_sri_all$ritFreq)), intercept=summary(out)$coefficients[1,1] * (sd(fl_sri_all$ritFreq)))+ geom_point(aes(x=SRI, y=ritFreq), alpha=.1) + ylab("Ritual rate") + xlab("SRI") + theme(axis.line=element_blank(), text=element_text(family="serif")) + panel_border(size=1, colour="black") pp_rqi <- ggplot(fl_rq_ritual) + geom_abline(slope= summary(out2)$coefficients[2,1] * (sd(fl_rq_ritual$ritFreq)), intercept=summary(out2)$coefficients[1,1] * (sd(fl_rq_ritual$ritFreq)))+ geom_point(aes(x=RQ_SEP, y=ritFreq), alpha=.1) + ylab("Ritual rate") + xlab("RQI") + theme(axis.line=element_blank(), text=element_text(family="serif")) + panel_border(size=1, colour="black") pp_coa <- ggplot(fl_coalitions_ritual) + geom_abline(slope= summary(out3)$coefficients[2,1] * (sd(fl_coalitions_ritual$ritFreq)), intercept=summary(out3)$coefficients[1,1] * (sd(fl_coalitions_ritual$ritFreq)))+ geom_point(aes(x=coalitions_rate, y=ritFreq), alpha=.1) + ylab("Ritual rate") + xlab("Coalition index") + theme(axis.line=element_blank(), text=element_text(family="serif")) + panel_border(size=1, colour="black") cowplot::plot_grid(pp_sri+xlab("Proximity index"), pp_rqi+xlab("Relationship quality index"), pp_coa, nrow=1, labels="auto", label_fontfamily="serif")