# Supplementary code for: # Smaldino PE, Aplin LM, Farine DR (2018) Sigmoidal Acquisition Curves Probably Indicate Conformity. Scientific Reports. # Replication of the model of van Leeuwen et al. (2016), with time windowing analysis. # Code written by Damien Farine. N <- 100 max_T <- 10000 repetitions <- 1000 out_frequency_behaviour = matrix(0,nrow=max_T*repetitions,ncol=2) out_frequency_individual = matrix(0,nrow=max_T*repetitions,ncol=2) count <- 1 #act.frequency.window <- matrix(NA,nrow=max_T*repetitions,ncol=2) #windows <- c(10,seq(100,9950,50)) windows <- c(10,20,30,40,50,70,90,110,130,150,180,210,240,270,300,350,400,450,500,580,660,740,820,900,1000,1100,1200,1350,1500,1850,2100,2500,3000,3500,4000,5000,6000,7000,8000,9000,9999) windows.data <- list() total.windows.empty <- list() for (w in 1:length(windows)) { windows.data[[w]] <- matrix(NA,nrow=max_T*repetitions,ncol=2) total.windows.empty[[w]] <- rep(NA,windows[w]) } for (i in 1:repetitions) { print(i) freq_behav <- 0 pop <- sample(c(0,1),N,replace=TRUE) total.windows <- total.windows.empty for (t in 1:max_T) { freq_ind <- sum(pop)/N behaviour <- sample(pop,1) freq_behav <- freq_behav + behaviour # update the windowing and windowed frequency for (w in 1:length(windows)) { total.windows[[w]][1:(windows[w]-1)] <- total.windows[[w]][2:windows[w]] total.windows[[w]][windows[w]] <- behaviour windows.data[[w]][count,] <- c(behaviour,sum(total.windows[[w]],na.rm=T)/sum(!is.na(total.windows[[w]]))) } pop[sample(1:N,1)] <- behaviour out_frequency_individual[count,] <- c(behaviour, freq_ind) out_frequency_behaviour[count,] <- c(behaviour, freq_behav/t) count <- count + 1 } } ## PLOT BASIC quartz(width=12,height=4) par(mfrow=c(1,3), mar=c(4.5,4.5,3,1), mgp=c(3,0.5,0), cex.lab=1.4, cex.axis=1.3, las=1) # Plot 1 x1 <- round(seq(0,1,0.01),2) y1 <- rep(NA,length(x1)) out_frequency_individual[,2] <- round(out_frequency_individual[,2],2) for (i in 1:length(x1)) { y1[i] <- mean(out_frequency_individual[out_frequency_individual[,2]==x1[i],1]) } plot(NULL,xlab=expression("Frequency"[A]),ylab=expression("Probability"["A"]), tck = 0.02, xlim=c(0,1), ylim=c(0,1)) lines(x1,predict(lm(y1~x1),type="response"),col="red",lty=2) lines(x1,predict(glm(y1~x1,family="binomial"),type="response"),col="blue",lty=2) for (i in seq(0,1,0.2)) { abline(v=i, col="lightgrey", lwd=0.4) abline(h=i, col="lightgrey", lwd=0.4) } points(x1,y1,cex=1.3) legend("bottomright",pch=c(21,NA,NA),lty=c(NA,2,2),col=c("black","red","blue"),legend=c("Original data","Linear fit","Sigmoid fit"),bty="n") mtext("A", side=3, outer=TRUE, line=-2.5, adj=0.005, cex=2.2) # Plot 2 x2 <- round(seq(0,1,0.01),2) y2 <- rep(NA,length(x2)) out_frequency_behaviour[,2] <- round(out_frequency_behaviour[,2],2) for (i in 1:length(x2)) { y2[i] <- mean(out_frequency_behaviour[out_frequency_behaviour[,2]==x2[i],1]) } plot(NULL,xlab=expression("Frequency"[A]),ylab=expression("Probability"["A"]), tck = 0.02, xlim=c(0,1), ylim=c(0,1)) for (i in seq(0,1,0.2)) { abline(v=i, col="lightgrey", lwd=0.4) abline(h=i, col="lightgrey", lwd=0.4) } lines(x2,predict(lm(y2~x2),type="response"),col="red",lty=2) lines(x2,predict(glm(y2~x2,family="binomial"),type="response"),col="blue",lty=2) points(x2,y2,cex=1.2) legend("bottomright",pch=c(21,NA,NA),lty=c(NA,2,2),col=c("black","red","blue"),legend=c("Original data","Linear fit","Sigmoid fit"),bty="n") mtext("B", side=3, outer=TRUE, line=-2.5, adj=0.345, cex=2.2) # Plot 3 x3 <- c(0,0.1,0.2,0.3,0.4,0.5,0.6,0.7,0.8,0.9,1.0) y3 <- rep(NA,length(x3)) act.frequency.window <- round(windows.data[[1]],2) #act.frequency.window <- act.frequency.window[which(act.frequency.window[,2] %in% seq(0,1,0.1)),] #act.frequency.window[,2] <- round(act.frequency.window[,2],1) for (i in 1:length(x3)) { y3[i] <- mean(act.frequency.window[act.frequency.window[,2] == x3[i],1]) } plot(NULL,xlab=expression("Frequency"[A]),ylab=expression("Probability"["A"]), tck = 0.02, xlim=c(0,1), ylim=c(0,1)) for (i in seq(0,1,0.2)) { abline(v=i, col="lightgrey", lwd=0.4) abline(h=i, col="lightgrey", lwd=0.4) } lines(x3,predict(lm(y3~x3),type="response"),col="red",lty=2) lines(x3,predict(glm(y3~x3,family="binomial"),type="response"),col="blue",lty=2) points(x3,y3,cex=1.2) legend("bottomright",pch=c(21,NA,NA),lty=c(NA,2,2),col=c("black","red","blue"),legend=c("Original data","Linear fit","Sigmoid fit"),bty="n") mtext("C", side=3, outer=TRUE, line=-2.5, adj=0.685, cex=2.2) ## Windowing b <- rep(NA,length(windows)) l <- rep(NA,length(windows)) windows.data.tmp <- windows.data tolerance = .Machine$double.eps^0.5 for (i in 1:length(windows)) { x <- seq(0,1,0.1) windows.data.tmp[[i]] <- windows.data.tmp[[i]] windows.data.tmp[[i]][,2] <- round(windows.data.tmp[[i]][,2],1) y <- rep(NA,length(x)) for (j in 1:length(x)) { y[j] <- mean(windows.data.tmp[[i]][which(abs(windows.data.tmp[[i]][,2] - x[j]) < tolerance),1]) } x <- x[is.finite(y)] y <- y[is.finite(y)] model.binom <- glm(y~x, family="binomial") y2 <- predict(model.binom,type="response") b[i] <- sum((y2-y)^2)*11/length(x) model.gaus <- glm(y~x, family="gaussian") y2 <- predict(model.gaus,type="response") l[i] <- sum((y2-y)^2)*11/length(x) } quartz(width=5,height=5) par(mar=c(4.5,4.5,1,1), cex.lab=1.4, cex.axis=1.1, las=1, mgp=c(3,0.5,0)) plot(windows,b,ylim=c(0,max(c(b,l))),lty=2,type='l',lwd=2, xlab="Window size (# previous observations)", ylab="Sum of squares (error)", col="blue", tck=0.02) lines(windows,l,lwd=2, col="red") offset <- -100 segments(windows[which.min(abs(b - l))[1]]+offset,b[which.min(abs(b - l))[1]],windows[which.min(abs(b - l))[1]]+offset,0) legend("topleft",lty=c(2,2),col=c("red","blue"),legend=c("Linear fit","Sigmoid fit"),bty="n", lwd=c(2,2))