###### READS LANDMARK DATA FROM CSV FILES TO THE R ENVIRONMENT #### ##Script for reading bird landmarks used in analyses of Navalon et al. (2022) "Environmental structure in the evolutionary radiation of bird skeletons". Written by Roger Benson 09 November 2021 require( geomorph ) #Needed only to do GPA at end of script, as a test of the data compilation setwd( "C:/Users/Guillermo Navalon/Dropbox/OXFORD (PRDA, 2019-2021)/[TEMPO BIRDS]/[DIMENSIONALITY]/[ANALYSIS]/DATA" ) ##Set as working directory the "Bird_landmarks_Navalon_2022" folder ##Make list ("compiled.bird.landmarks.list") object to receive the data compiled.bird.landmarks.list <- list() length( compiled.bird.landmarks.list ) <- 13 names( compiled.bird.landmarks.list ) <- c( "skull" , "mandible" , "scapula" , "coracoid" , "sternum" , "humerus" , "radius" , "ulna" , "carpometacarpus" , "synsacrum" , "femur" , "tibiotarsus" , "tarsometatarsus" ) ##Loop over the element names, reading landmark data for( element in names( compiled.bird.landmarks.list ) ) { compiled.bird.landmarks.list[[ element ]] <- list() length( compiled.bird.landmarks.list[[ element ]] ) <- 2 names( compiled.bird.landmarks.list[[ element ]] ) <- c( "min" ) for( lm.count in c( "min" ) ) { folder.name <- paste( element , lm.count , "landmarks" , sep = "_" ) csv.list <- list.files( folder.name , full.names = T ) taxon.names <- list.files( folder.name , full.names = F ) taxon.names <- gsub( paste( "_" , element, "_landmarks_" , lm.count , ".csv" , sep = "" ) , "" , taxon.names ) landmark.list <- lapply( csv.list , read.csv ) rownames.temp <- rownames( landmark.list[[ 1 ]] ) landmark.list <- lapply( landmark.list , function(X){X[,2:4]}) output.landmarks.array <- array( unlist( landmark.list ) , dim = c( nrow( landmark.list[[1]] ) , ncol( landmark.list[[1]] ) , length( landmark.list ) ) ) dimnames( output.landmarks.array )[[ 1 ]] <- rownames.temp dimnames( output.landmarks.array )[[ 2 ]] <- c( "x" , "y" , "z" ) dimnames( output.landmarks.array )[[ 3 ]] <- taxon.names sliders <- read.csv( paste( "Sliders_" , element , "_" , lm.count , ".csv" , sep = "" ) , row.name = 1 ) colours <- read.csv( paste( "Colours_" , element , "_" , lm.count , ".csv" , sep = "" ) , row.name = 1 ) colours <- c( colours[,1] ) compiled.bird.landmarks.list[[ element ]][[ lm.count ]] <- list( output.landmarks.array = output.landmarks.array , sliders = sliders , colours = colours ) } } ##Example of GPA element <- "skull" ##Set preferred element lm.count <- "min" ##Set landmark point count (only one option - "min") landmark.array <- compiled.bird.landmarks.list[[ element ]][[ lm.count ]][[ "output.landmarks.array" ]] sliders <- compiled.bird.landmarks.list[[ element ]][[ lm.count ]][[ "sliders" ]] colours <- compiled.bird.landmarks.list[[ element ]][[ lm.count ]][[ "colours" ]] GPA.fit <- gpagen( landmark.array , curves = sliders , approxBE = T ) dimnames( GPA.fit$coords )[[ 1 ]] <- dimnames( landmark.array )[[ 1 ]] ##Put names back onto shape data plot3d( GPA.fit$consensus , col = colours , size = 10 , asp = "iso" ) ##Plot mean shape ###################### ANALYSES CODE STARTS HERE ######################### require( geomorph ) require( ape ) require( geiger ) require( abind ) require( RColorBrewer ) require( cluster ) require( matlib ) require( ggtree ) require( rlang ) require( cowplot ) require( tidytree ) require( dplyr ) require( ggtree ) require( phytools ) require( ggplot2 ) require( gdata ) require( stringdist ) require( Rvcg ) require( treeio ) require( tidytree ) require( tidyjson ) require( hot.dots ) require( Morpho ) require( RPANDA ) require( mvMORPH ) setwd( "C:/Users/Guillermo Navalon/Dropbox/OXFORD (PRDA, 2019-2021)/[TEMPO BIRDS]/[DIMENSIONALITY]/[ANALYSIS]/DATA" ) source('getAvisoData _ updated 13 Sept 2019.R', chdir = TRUE) source ('FUNCTIONS/tree.age.R') source ('FUNCTIONS/tree.age_fun.R') source ('FUNCTIONS/sanitizing.R') source('FUNCTIONS/tree_subset.R') source('FUNCTIONS/GN.FUNCTIONS.R') load('functions_17122019.RData') source("File S4. Custom R functions used in this study.R") load('Bird_landmarks_clean_21Mar2022_reduced taxon set.rds') tree <- read.tree( "Combined_bird_tree 21Mar2022.tre" ) metadata <- read.csv("Table S1. List of specimens used in this study.csv", row.names = 2, sep = ",") bodymasses <- data.frame(metadata[, c("Mass_M_.hbw_alive.", "Mass_F_.hbw_alive.")]) bodymass.averages.temp <- log10(rowMeans(bodymasses)) # calculated mean values per taxon. Female and male values are recorded. bodymass.averages.temp <- bodymass.averages.temp[tree$tip.label] ### For example, to combine landmarks for the skull, mandible and synsacrum, can be read for individual bones as well combined.landmarks.array <- combine.element.landmarks( compiled.bird.landmarks.list , elements = c( "skull") ) # to get the vector of combined CS to be used to generate the skeletal proportions data combined.CS <- combine.element.CS(compiled.bird.landmarks.list, elements = c("sternum","coracoid", "scapula","humerus", "ulna", "radius", "carpometacarpus")) #### FOR ME, ELIMINATE AFTER USE #### write.csv(GPA.fit$coords[,,1], "skull landmarks.csv") test = GPA.fit$coords[c(3:8, 53:74),,] test <- data [,, -which( dimnames( data )[[ 3 ]] == "Smithornis_capensis") ] test.final <-test [,, -which( dimnames( test )[[ 3 ]] == "Corythaeola_cristata") ] plot3d(test[,,"Accipiter_nisus"], size = 0.5 , type = "s", col = "black") ; aspect3d("iso") saveRDS(test, file = "ALL PARTITIONS FINAL/beak.allometry.free.rds") # ALLOMETRY-FREE SHAPE DATA FOR COMBINATIONS OF ELEMENTS OR INDIVIDUAL ELEMENTS tree.temp <- tree combined.allometry.free <- combine.element.allometry.free(bodymass = bodymass.averages.temp, compiled.landmarks = compiled.bird.landmarks.list, elements = c("skull")) ### Can do GPA ignoring slider because sliding was already done within combine.element.landmarks() ### Only use this way for combined sets of bones, not individual bones GPA.fit <- gpagen( combined.allometry.free ) plot3d(skull.proportions.free.final[,,"Accipiter_nisus"], size = 10 , col = "black") ; aspect3d("iso") saveRDS(GPA.fit$coords, file = "ALL PARTITIONS FINAL/ tarsometatarsus allometry free.rds") PCA.fit <- gm.prcomp(GPA.fit$coords) # SKELETAL PROPORTIONS # # generate skeletal proportions data as residuals from a PGLS of the matrix of proportions as a function of the log10 body masses tree.temp <- tree bodymass.averages.temp <- bodymass.averages.temp [ row.names(combined.CS)] # orders bodymasses to match the order of the rest of data proportions.frame <- geomorph.data.frame(CS = combined.CS, BM = bodymass.averages.temp, phy = tree.temp) PGLS.proportions.fit <- procD.pgls(CS ~ BM , phy = phy , data = proportions.frame, iter = 9999) proportions.temp <- PGLS.proportions.fit$pgls.residuals head(proportions.temp) PCA.fit <- prcomp(proportions.temp) # this for skeletal proportional data, we have to use prcomp() # PROPORTIONS NORMALISED SHAPES # ### Note: the following block is the code used to generate the proportions-normalised shape data and the comparisons among PGLS models ## # choose a single bone element = "skull" choose.lm.count <- "min" compiled.landmarks.temp <- compiled.bird.landmarks.list[[ element ]][[ choose.lm.count ]] GPA.fit <- gpagen(compiled.landmarks.temp[[ "output.landmarks.array" ]] , curves = compiled.landmarks.temp[[ "sliders" ]] , ProcD = F ) bodymass.averages.temp <- bodymass.averages.temp [ names (GPA.fit$Csize)] # orders bodymasses to match the order of the rest of data GPA.coords.temp <- GPA.fit$coords data.names <- dimnames( GPA.coords.temp ) [[3]] ## drop.taxa <- tree.temp$tip.label[ ! tree.temp$tip.label %in% data.names ] tree.temp <- drop.tip( tree.temp , drop.taxa ) GPA.coords.temp <- GPA.coords.temp[ , , unlist( tree.temp$tip.label ) ] # this block finds the lengths among pairs of landmarks that are maximum in each axes mean.spec.name <- findMeanSpec(GPA.fit$coords) # finds specimen closest to the mean: most representative mean.spec.coords <- GPA.fit$coords[,,mean.spec.name] # subset the coords of that specimen rownames(mean.spec.coords) <- row.names(compiled.landmarks.temp[[ "output.landmarks.array" ]] ) ==== axis <- 2#3 # select axis, 1 for X, 2 for Y, 3 for Z axis <- mean.spec.coords[,axis] # takes the selected axis distances <- dist(axis, method = "euclidean") # generates matrix of pairwise euclidean distances distances <- as.matrix(distances) distances <- as.data.frame(distances) which.pair <- rownames(distances)[row(distances)[which(distances == max(distances))]] # which two landmarks are most appart in this axis which.pair coords <- GPA.fit$coords #compiled.landmarks.temp[[1]] subsets landmarks from original non-GPAed coordinates as we real want linear distances dimnames(coords)[[1]] <- row.names(distances) # dist() asigns a number to each semilandmark so rownames need to be updated to be able to subset appropriate data landmarks.1 <- t(coords ["SL3_Crista_medialis_hypotarsi.2",,]) # subsets one of the pairs of landmarks landmarks.2 <- t(coords [ "SL1_Medial_cotyle.2",,])# subsets the other landmark in the pair landmark.pair <- cbindX(landmarks.1, landmarks.2) final.distances<- apply(landmark.pair, 1, function(x) dist(matrix(x, nrow = 2, byrow = TRUE))) # calculates vector of final distances to use downstream final.distances.euclidean.Z<- final.distances #Calculates maximum distances in each of the spatial axis (to be used downstream for proportions-normalisation) axis <- "Z" landmarks.1.axis <- landmarks.1[,axis] landmarks.2.axis <- landmarks.2[,axis] landmark.pair.axis <- cbind(landmarks.1.axis, landmarks.2.axis) final.distances.axis<- apply(landmark.pair.axis, 1, function(x) dist(matrix(x, nrow = 2, byrow = TRUE))) # calculates vector of final distances to use downstream final.distances.Z<- final.distances.axis # writes maximum xyz distances in each axis # in superimposed specimens for downstream proportions-normalising write.csv(cbind(final.distances.X , final.distances.Y, final.distances.Z),"xyz distances/Tarsometatarsus xyz maximum Axis distances Birds.csv") # and real distances by multiplying by centroid size write.csv(cbind(final.distances.X * GPA.fit$Csize, final.distances.Y*GPA.fit$Csize, final.distances.Z*GPA.fit$Csize),"xyz distances/Tarsometatarsus xyz maximum Real Axis distances Birds.csv") #writes maximum xyz Euclidean distances in a file write.csv(cbind(final.distances.euclidean.X, final.distances.euclidean.Y, final.distances.euclidean.Z),"xyz Euclidean distances/Tarsometatarsus xyz maximum Euclidean distances Birds.csv") # and real distances by multiplying by centroid size write.csv(cbind(final.distances.euclidean.X * GPA.fit$Csize, final.distances.euclidean.Y*GPA.fit$Csize, final.distances.euclidean.Z*GPA.fit$Csize),"xyz Euclidean distances/Tarsometatarsus xyz maximum Real Euclidean distances Birds.csv") # generates 'proportion' free shape data, intends to correct for proportional expansion/elongation of the element df <- geomorph.data.frame(shape = GPA.fit$coords, BM = bodymass.averages.temp, phy = tree.temp, final.distances.X = final.distances.X, final.distances.Y = final.distances.Y, final.distances.Z = final.distances.Z) # PGLS models for all combinations of xyz lengths bm <- procD.pgls(shape ~ BM, phy = phy , data = df, iter = 9999) x <- procD.pgls(shape ~ BM + df$final.distances.X, phy = phy , data = df, iter = 9999) y <- procD.pgls(shape ~ BM + df$final.distances.Y, phy = phy , data = df, iter = 9999) z <- procD.pgls(shape ~ BM + df$final.distances.Z, phy = phy , data = df, iter = 9999) xy <- procD.pgls(shape ~ BM + df$final.distances.X + df$final.distances.Y, phy = phy , data = df, iter = 9999) xz <- procD.pgls(shape ~ BM + df$final.distances.X + df$final.distances.Z, phy = phy , data = df, iter = 9999) yz <- procD.pgls(shape ~ BM + df$final.distances.Y + df$final.distances.Z, phy = phy , data = df, iter = 9999) xyz <- procD.pgls(shape ~ BM + df$final.distances.X + df$final.distances.Y + df$final.distances.Z, phy = phy , data = df, iter = 9999) # stores all ANOVA tables from PGLS models procD.list <-list(x$aov.table, y$aov.table, z$aov.table, xy$aov.table, xz$aov.table, yz$aov.table, xyz$aov.table) results.table <- do.call( rbind , procD.list ) write.csv(results.table, "Proportions normalising model comparisons/Tarsometatarsus Proc.D ANOVAs Birds.csv") # makes explicit comparisons among PGLS models stores the ANOVA table of the comparisons # Null model : shape ~ BM model.comparisons <- anova(bm,x,y,z,xy,xz,yz,xyz) write.csv(model.comparisons$table, "Proportions normalising model comparisons/Tarsometatarsus model comparisons.csv") #choose residuals from best model xyz$aov.table plot.PGLS.proportion.free<-plot(xyz, type="regression", reg.type="RegScore", predictor = df$final.distances.X) ## ploteas regscores para ver la distribucion general RegScores.proportion.free<-plot.PGLS.proportion.free$RegScore proportion.free.residuals <- xyz$pgls.residuals proportion.free.residuals <- arrayspecs(proportion.free.residuals, dim(GPA.fit$coords)[1], 3, sep = ".") proportion.free.shape <- proportion.free.residuals + array(GPA.fit$consensus, dim(proportion.free.residuals)) tarsometatarsus.proportions.free.final <- proportion.free.shape #checking extreme shapes for main axes PCA.fit <- gm.prcomp(GPA.fit$coords) GPA.fit <- gpagen(proportion.free.shape) PCA.fit <- gm.prcomp (proportion.free.shape) plot(PCA.fit, axis1 = 1, axis2 = 2) PC <- 2 PC.temp<-PCA.fit$x[,PC] preds<-shape.predictor(GPA.fit$coords, x = as.numeric( PCA.fit$x[,PC] ), Intercept = F, pred1 = quantile(PC.temp, probs = 0.03), pred2 = quantile(PC.temp, probs = 0.97)) mesh.original <- read.ply(".ply for meshes/Ptilonorhynchus_violaceus_UMMZ_155483_sternum.ply", ShowSpecimen = F, addNormals = F ) coords.original <- compiled.landmarks.temp[["output.landmarks.array"]][,,"Ptilonorhynchus_violaceus"] M <- mshape(GPA.fit$coords) #calculates per landmarks variance my.variances <- per_lm_variance(shape.data = GPA.fit$coords) # now we need to put all shapes in the same space to plot warped mesh and hot.dots on top of it open3d() par3d(windowRect = c(0,0,700,250)) Sys.sleep(1) mfrow3d(nr = 1, nc = 2, byrow = TRUE, sharedMouse = TRUE) mesh.min <- tps3d(mesh.original, refmat = coords.original, tarmat = preds$pred1) shade3d(mesh.min, col= 8, alpha = 1) spheres3d(preds$pred1, col = my.variances$Variance_Colors, radius = 0.003) next3d() mesh.max <- tps3d(mesh.original, refmat = coords.original, tarmat = preds$pred2, lambda = 0.5) shade3d(mesh.max, col= 8, alpha = 1) spheres3d(preds$pred2, col = my.variances$Variance_Colors, radius = 0.003) #take snapshot in each position rgl.snapshot( "MESHES EXTREMES FINAL/FEMUR.PROPORTIONS-NORMALISED.PC1.shapes_ventral.png" ) ###Check individual shapes plot3d(combined.landmarks.array[,,"Accipiter_nisus"], size = 10 , col = "black") ; aspect3d("iso") rgl.snapshot( "Proportions normalising species comparisons/Tarsometatarsus Accipiter diagonal.png" ) # the block to generate and read into the Rworkspace all the PROPORTIONS NORMALISED DATA ENDS HERE ## this block reads and combine several proportions normalised individual shapes and combines them #change here the name of the bone to store each bone after proportion's correction tarsometatarsus.proportion.free <- proportion.free.shape ## This block compiles several proportions normalised shapes (FROM COMBINE.ELEMENTS ORIGINAL FUNCTION) GPA.coords.resized.temp <- list(synsacrum.proportions.free.final) #tarsometatarsus.proportions.free)#, #synsacrum.proportions.free, femur.proportions.free, tibiotarsus.proportions.free, #tarsometatarsus.proportions.free) elements <- c("synsacrum") #"synsacrum", "femur", "tibiotarsus", "tarsometatarsus") specimen.names <- table( unlist( lapply( GPA.coords.resized.temp , function(X){dimnames(X)[[3]]} ) ) ) == length( elements ) specimen.names <- names( specimen.names )[ specimen.names ] for( i in 1:length( GPA.coords.resized.temp ) ) { GPA.coords.resized.temp[[ i ]] <- GPA.coords.resized.temp[[ i ]][ , , specimen.names ] } combined.landmarks.list <- list() for( i in 1:length( specimen.names ) ){ combined.landmarks.list[[ i ]] <- do.call( rbind , lapply( GPA.coords.resized.temp , get.array.element , element = i ) ) } names( combined.landmarks.list ) <- dimnames( ( GPA.coords.resized.temp )[[ 1 ]] )[[ 3 ]] combined.landmarks.array <- do.call( abind , c( combined.landmarks.list , along = 3 ) ) scaled.combined.landmarks.array <- unit.scale.coords( combined.landmarks.array ) scaled.combined.landmarks.array combined.proportion.free <- scaled.combined.landmarks.array # gpa combined proportion free data GPA.fit <- gpagen(beak.allometry.free) PCA.fit <- gm.prcomp(GPA.fit$coords) ###Check that it worked by plotting the coordinates in 3d load("ALL PARTITIONS FINAL/skull.allometry.free.rds") GPA.fit <- gpagen(tarsometatarsus.proportions.free) red.element <- c( "coracoid") plot3d( GPA.fit$coords[,,"Fregata_aquila"], size = 10 , col = "black") ; aspect3d("iso") tree.temp <- tree element <- "synsacrum and hindlimb" #Note: Use Pcscores for skeletal proportions data, use GPA.coords for shape or form data #PCA.scores.temp <- PCA.scores.list[[ element ]] # for individual elements PCA.scores.temp<-PCA.fit$x # for sets of bones #GPA.coords.temp<-GPA.coords.list [[ element ]] # for disparity for individual bones GPA.coords.temp<-GPA.fit$coords #GPA.coords.temp <- allometric.free.shape#for disparity for sets of bones ## matches data and phylogeny for PCA scores data.names <- dimnames( PCA.scores.temp )[[1]] drop.taxa <- tree.temp$tip.label[ ! tree.temp$tip.label %in% data.names ] tree.temp <- drop.tip( tree.temp , drop.taxa ) PCA.scores.temp <- PCA.scores.temp[ unlist( tree.temp$tip.label ) , ] ## matches data and phylogeny for GPA coords data.names <- dimnames( GPA.coords.temp ) [[3]] ## drop.taxa <- tree.temp$tip.label[ ! tree.temp$tip.label %in% data.names ] tree.temp <- drop.tip( tree.temp , drop.taxa ) GPA.coords.temp <- GPA.coords.temp[ , , unlist( tree.temp$tip.label ) ] #subsetting by another element re-orders the data with the element's order # get nodes ages from tree.temp pruned by data ##### DISPARITY THROUGH TIME ###### disparity.nodes.temp<-disparity.phylo(data = two.d.array(GPA.coords.temp), phy = tree.temp ) # use this block for shape and form data # simulated disparity data using mvMORPH fully multivariate functions. # first fit a multivariate model of BM using the rapid fit option H&L extract the coefficients and sigma # use those to simulate shape multivariate data under BM from which to compare empirical data fit1 <- mvgls(two.d.array(GPA.coords.temp)~1, tree=tree.temp, model="BM", method="H&L") sim.temp.new <- mvSIM(tree.temp, nsim = 200, model = "BM1", param = list(sigma = fit1$sigma$Pinv, theta = fit1$coefficients )) lndmks.bone <- dim(GPA.coords.temp)[1] * 3 number.taxa <-length(tree.temp$tip.label) x <- array(unlist(sim.temp.new), c(number.taxa,lndmks.bone,200), dimnames = list(dimnames(GPA.coords.temp)[[3]],as.character(c(1:lndmks.bone)),as.character(c(1:200)))) #use this for skeletal proportions data i.e., pcscores disparity.nodes.temp<-disparity.phylo(data = PCA.scores.temp, phy = tree.temp ) fit1 <- mvgls(PCA.scores.temp~1, tree=tree.temp, model="BM", method="H&L") sim.temp.new <- mvSIM(tree.temp, nsim = 200, model = "BM1", param = list(sigma = fit1$sigma$Pinv, theta = fit1$coefficients )) lndmks.bone <- dim(PCA.scores.temp)[2] number.taxa <-length(tree.temp$tip.label) x <- array(unlist(sim.temp.new), c(number.taxa,lndmks.bone,200), dimnames = list(dimnames(PCA.scores.temp)[[1]],as.character(c(1:lndmks.bone)),as.character(c(1:200)))) # use this line for all kinds of data, that is, skeletal proportions, allometry free shape and form, and proportions-normalised shape and form sim.disparities <- apply( x , 3 , disparity.phylo , phy = tree.temp) ### Generates deviations of empirical disparities from BM simulations disparities.deviation <- log10( disparity.nodes.temp ) - log10( apply (sim.disparities, 1, mean)) max(disparities.deviation) mean(disparities.deviation) min(disparities.deviation) # uses positive and negative deviations to generate a divergent palette of two colours edge.values <- disparities.deviation edge.values <- -1*edge.values[which(edge.values <= 0)] colours.rgb <- c("#55185D","#74467C","#d5cfce") ##because we want people to look at outliers from BMw, grey is a good colour for unwanted attention colour.scale <- colorRamp( rev( colours.rgb ) , space = "rgb") #bias ensures grey corresponds always in good BM fitted values (adjust conveniently and check, more sophisticated in the final plots) BG.node.table <- colour.scale( edge.values / max( edge.values ) ) BG.disp.negative <- c() for( i in 1:nrow( BG.node.table ) ) { BG.disp.negative[i] <- rgb( BG.node.table[i,1], BG.node.table[i,2], BG.node.table[i,3] , alpha = 255 , max = 255 ) } names(BG.disp.negative) <- names(edge.values) edge.values <- disparities.deviation edge.values.positive <- edge.values [which(edge.values > 0)] colours.rgb <- c("#C8963E", "#BCA47D","#d5cfce" ) ##because we want people to look at outliers from BMw, grey is a good colour for unwanted attention colour.scale <- colorRamp( rev( colours.rgb ) , space = "rgb") #bias ensures grey corresponds always in good BM fitted values (adjust conveniently and check, more sophisticated in the final plots) BG.node.table <- colour.scale( edge.values.positive / max( edge.values.positive ) ) BG.disp.positive <- c() for( i in 1:nrow( BG.node.table ) ) { BG.disp.positive[i] <- rgb( BG.node.table[i,1], BG.node.table[i,2], BG.node.table[i,3] , alpha = 255 , max = 255 ) } names(BG.disp.positive) <- names(edge.values.positive) BG.disp <- c(BG.disp.negative, BG.disp.positive) BG.disp <- BG.disp[names(disparity.nodes.temp)] # calls new function to calculate binned trends through time trends.envelope <- trend.through.time (disparity.nodes.temp, sim.disparities, tree.temp ) subset.landbirds <- as.character(c(327:374)) # non passerine landbirds subset.waterbirds <- as.character(c(285:326)) subset.passerines <- as.character(c(374:455)) landbirds.trends.envelope <- trend.through.time.empirical(disparity.nodes.temp, tree.temp, subset.landbirds ) waterbirds.trends.envelope <- trend.through.time.empirical(disparity.nodes.temp, tree.temp, subset.waterbirds) passerines.trends.envelope<- trend.through.time.empirical(disparity.nodes.temp, tree.temp, subset.passerines) #this block extracts the mean ages from the character string generated by cut # the order is different depending on means,uppers or lowers disp.bin.uppers.plot<- data.frame (trends.envelope[[1]], trends.envelope[[5]]) disp.bin.lowers.plot<-data.frame(trends.envelope[[2]], trends.envelope[[5]]) disp.bin.means.plot<-data.frame(trends.envelope[[3]], trends.envelope[[5]]) disp.bin.means.empirical.plot<-data.frame(trends.envelope[[4]], trends.envelope[[5]]) disp.landbirds.empirical.plot <- data.frame(landbirds.trends.envelope[[1]], landbirds.trends.envelope[[2]]) disp.waterbirds.empirical.plot <- data.frame(waterbirds.trends.envelope[[1]], waterbirds.trends.envelope[[2]]) disp.passerines.empirical.plot <- data.frame(passerines.trends.envelope[[1]], passerines.trends.envelope[[2]]) # sets nodes # subset node.ages to data, do this before plotting dim and disp and then for plotting the angles tree.temp <- tree variable = disparity.nodes.temp tree <- tree.temp nodes.ages.temp <- tree.age(tree.temp) node.ages.temp.mod <- nodes.ages.temp[,1] names(node.ages.temp.mod)<- as.character(nodes.ages.temp[,2]) node.ages.temp.mod<-node.ages.temp.mod[ names(variable)] #plot with individual clades colored as departure from median simulation plus binned trends for empirical and simulated data dev.new() plot(disparity.nodes.temp, node.ages.temp.mod, xlim = c(0, max(disparity.nodes.temp)), ylim = c(80, 0) , type = "p", cex = 0.01, pch = 21, bg = BG.disp, frame.plot = F) lines(disp.bin.means.plot[, 1], disp.bin.means.plot[, 2], lty = 2, lw = 3, col = "#5E5E5E") lines(disp.bin.uppers.plot[, 1], disp.bin.uppers.plot[, 2], lty = 3, lw = 3, col = "#5E5E5E") lines(disp.bin.lowers.plot[, 1], disp.bin.lowers.plot[, 2], lty = 3, lw = 3, col = "#5E5E5E") lines(disp.bin.means.empirical.plot[, 1], disp.bin.means.empirical.plot[, 2], lw = 4, col = "#999999") lines(disp.landbirds.empirical.plot[, 1], disp.landbirds.empirical.plot[, 2], lw = 4, col = "#6EB057") lines(disp.waterbirds.empirical.plot[, 1], disp.waterbirds.empirical.plot[, 2], lw = 4, col = "#6699CC") lines(disp.passerines.empirical.plot[, 1], disp.passerines.empirical.plot[, 2], lw = 4, col = "#745B8C") # Plot phylogeny to identify nodes of interest in the tree for later dev.new() plot( tree.temp , direction = "u", font = 1, cex = 0.3); nodelabels(cex =0.7, bg = "transparent", frame = "circle") # MDIs for all Neornithes # range01 <- function(x){(x-min(x))/(max(x)-min(x))} # normalises ranges among all clades # Note: Branching event dates need to be in units of relative time from 0 to 1 in descending order neornithes.dates <- rev(range01(disp.bin.means.empirical.plot [, 2])) passerines.dates <- rev(range01(disp.passerines.empirical.plot [, 2])) landbirds.dates <- rev(range01(disp.landbirds.empirical.plot [, 2])) waterbirds.dates <- rev(range01(disp.waterbirds.empirical.plot [, 2])) MDI.Neornithes <- geiger:::.area.between.curves(x = neornithes.dates, f1 = disp.bin.means.plot[, 1], f2 = disp.bin.means.empirical.plot[, 1] , xrange = c(0, 1)) MDI.Neornithes # MDIs for subgroups # # Note: read the next block then come back to the above code # to calculate simulated and empirical disparities again GPA.coords.temp<-GPA.fit$coords tree.temp <- extract.clade(tree, node = 374) # # subset for different trees # check node numbers plot(tree.temp) data.names <- dimnames( GPA.coords.temp )[[3]] drop.taxa <- tree.temp$tip.label[ ! tree.temp$tip.label %in% data.names ] tree.temp <- drop.tip( tree.temp , drop.taxa ) GPA.coords.temp <- GPA.coords.temp[ ,,unlist( tree.temp$tip.label ) ] PCA.scores.temp <- PCA.fit$x tree.temp <- extract.clade(tree, node = 374) # # subset for different trees # check node numbers plot(tree.temp) data.names <- dimnames( PCA.scores.temp )[[1]] drop.taxa <- tree.temp$tip.label[ ! tree.temp$tip.label %in% data.names ] tree.temp <- drop.tip( tree.temp , drop.taxa ) PCA.scores.temp <- PCA.scores.temp[ unlist( tree.temp$tip.label ) , ] trends.envelope <- trend.through.time (disparity.nodes.temp, sim.disparities, tree.temp ) disp.bin.uppers.plot<- data.frame (trends.envelope[[1]], trends.envelope[[5]]) disp.bin.lowers.plot<-data.frame(trends.envelope[[2]], trends.envelope[[5]]) disp.bin.means.plot<-data.frame(trends.envelope[[3]], trends.envelope[[5]]) disp.bin.means.empirical.plot<-data.frame(trends.envelope[[4]], trends.envelope[[5]]) # subset node.ages to data, do this before plotting dim and disp and then for plotting the angles tree.temp <- tree variable = disparity.nodes.temp nodes.ages.temp <- tree.age(tree.temp) node.ages.temp.mod <- nodes.ages.temp[,1] names(node.ages.temp.mod)<- as.character(nodes.ages.temp[,2]) nodes.clade <- c(374:455) node.ages.temp.mod<-node.ages.temp.mod[ nodes.clade ] dev.new() plot(disparity.nodes.temp,node.ages.temp.mod, xlim = c(0, max(disparity.nodes.temp)), ylim = c(80, 0), cex.axis = 1.5, type = "p", cex = 2, pch = 21, col = "transparent", bg = BG.disp, frame.plot = F) lines(disp.bin.means.plot[, 1], disp.bin.means.plot[, 2], lty = 2, lw = 3, col = "#5E5E5E") lines(disp.bin.uppers.plot[, 1], disp.bin.uppers.plot[, 2], lty = 3, lw = 3, col = "#5E5E5E") lines(disp.bin.lowers.plot[, 1], disp.bin.lowers.plot[, 2], lty = 3, lw = 3, col = "#5E5E5E") lines(disp.bin.means.empirical.plot[, 1], disp.bin.means.empirical.plot[, 2], lw = 4, col = "#745B8C") MDI.subclade.passerines <- geiger:::.area.between.curves(x = neornithes.dates, f1 = disp.bin.lowers.plot[, 1], f2 = disp.bin.means.empirical.plot[, 1], xrange = c(0, 1)) MDI.subclade.passerines GPA.coords.temp<-GPA.fit$coords tree.passerines <- tree.temp # drop.taxa <- tree.passerines$tip.label tree.temp <- extract.clade(tree, node = 330) plot(tree.temp) # check tree.temp <- drop.tip(tree.temp, drop.taxa) # subsets passerines out of landbirds plot(tree.temp) #check data.names <- dimnames( GPA.coords.temp )[[3]] drop.taxa <- tree.temp$tip.label[ ! tree.temp$tip.label %in% data.names ] tree.temp <- drop.tip( tree.temp , drop.taxa ) GPA.coords.temp <- GPA.coords.temp[ ,, unlist( tree.temp$tip.label ) ] trends.envelope <- trend.through.time (disparity.nodes.temp, sim.disparities, tree.temp ) disp.bin.uppers.plot<- data.frame (trends.envelope[[1]], trends.envelope[[5]]) disp.bin.lowers.plot<-data.frame(trends.envelope[[2]], trends.envelope[[5]]) disp.bin.means.plot<-data.frame(trends.envelope[[3]], trends.envelope[[5]]) disp.bin.means.empirical.plot<-data.frame(trends.envelope[[4]], trends.envelope[[5]]) dev.new() plot(disparity.nodes.temp,node.ages.temp.mod, xlim = c(0, max(disparity.nodes.temp)), ylim = c(80, 0), cex.axis = 1.5, type = "p", cex = 2, pch = 21, col = "transparent", bg = BG.disp, frame.plot = F) lines(disp.bin.means.plot[, 1], disp.bin.means.plot[, 2], lty = 2, lw = 3, col = "#5E5E5E") lines(disp.bin.uppers.plot[, 1], disp.bin.uppers.plot[, 2], lty = 3, lw = 3, col = "#5E5E5E") lines(disp.bin.lowers.plot[, 1], disp.bin.lowers.plot[, 2], lty = 3, lw = 3, col = "#5E5E5E") lines(disp.bin.means.empirical.plot[, 1], disp.bin.means.empirical.plot[, 2], lw = 4, col = "#6EB057") neornithes.dates <- range01(disp.bin.means.empirical.plot [, 2]) MDI.subclade.landbirds <- geiger:::.area.between.curves(x = neornithes.dates, f1 = disp.bin.means.empirical.plot[, 1], f2 = disp.bin.means.plot[, 1], xrange = c(0,1)) MDI.subclade.landbirds tree.landbirds <- extract.clade(tree, node = 330) GPA.coords.temp<-GPA.fit$coords drop.taxa <- tree.landbirds$tip.label tree.temp <- extract.clade(tree, node = 287) plot(tree.temp) tree.temp <- drop.tip(tree.temp, drop.taxa) plot(tree.temp) data.names <- dimnames( GPA.coords.temp )[[3]] drop.taxa <- tree.temp$tip.label[ ! tree.temp$tip.label %in% data.names ] tree.temp <- drop.tip( tree.temp , drop.taxa ) GPA.coords.temp <- GPA.coords.temp[ ,, unlist( tree.temp$tip.label )] trends.envelope <- trend.through.time (disparity.nodes.temp, sim.disparities, tree.temp ) disp.bin.uppers.plot<- data.frame (trends.envelope[[1]], trends.envelope[[5]]) disp.bin.lowers.plot<-data.frame(trends.envelope[[2]], trends.envelope[[5]]) disp.bin.means.plot<-data.frame(trends.envelope[[3]], trends.envelope[[5]]) disp.bin.means.empirical.plot<-data.frame(trends.envelope[[4]], trends.envelope[[5]]) dev.new() plot(disparity.nodes.temp,node.ages.temp.mod, xlim = c(0, max(disparity.nodes.temp)), ylim = c(80, 0), cex.axis = 1.5, type = "p", cex = 2, pch = 21, col = "transparent", bg = BG.disp, frame.plot = F) lines(disp.bin.means.plot[, 1], disp.bin.means.plot[, 2], lty = 2, lw = 3, col = "#5E5E5E") lines(disp.bin.uppers.plot[, 1], disp.bin.uppers.plot[, 2], lty = 3, lw = 3, col = "#5E5E5E") lines(disp.bin.lowers.plot[, 1], disp.bin.lowers.plot[, 2], lty = 3, lw = 3, col = "#5E5E5E") lines(disp.bin.means.empirical.plot[, 1], disp.bin.means.empirical.plot[, 2], lw = 4, col = "#6699CC") neornithes.dates <- range01(disp.bin.means.empirical.plot [, 2]) MDI.subclade.waterbirds <- geiger:::.area.between.curves(x = neornithes.dates, f1 = disp.bin.means.empirical.plot[, 1], f2 = disp.bin.means.plot[, 1], xrange = c(0,1)) MDI.subclade.waterbirds ### PLOT DISPARITY THROUGH TIME ### # subset node.ages to data, do this before plotting dim and disp and then for plotting the angles tree.temp <- tree variable = disparity.nodes.temp tree <- tree.temp nodes.ages.temp <- tree.age(tree.temp) node.ages.temp.mod <- nodes.ages.temp[,1] names(node.ages.temp.mod)<- as.character(nodes.ages.temp[,2]) node.ages.temp.mod<-node.ages.temp.mod[ names(variable)] #plot trees dev.new() windows(width = 12, height = 12) par(mfrow=c(3,2), mfg = c(3,2,3,2), mar = c(2,2,2,2), oma=c(5,0,5,0), cex.main = 0.85, cex.lab = 0.5) # disparity through time plots + phylogeny plot( tree.temp , direction = "u", show.tip.label = F, no.margin = T, y.lim = c(-5, 72.907 )) nodelabels( node = as.numeric(names(disparity.nodes.temp)), frame = "n" , cex = 3 , pch = 21 , bg = BG.disp ) plot(disparity.nodes.temp,node.ages.temp.mod, xlim = c(0, max(disparity.nodes.temp)), ylim = c(80, 0), cex.axis = 1.5, type = "p", cex = 2, pch = 21, col = "transparent", bg = BG.disp, frame.plot = F) lines(disp.bin.uppers.plot[, 1], disp.bin.uppers.plot[, 2], lty = 3, lw = 3, col = "#5E5E5E") lines(disp.bin.lowers.plot[, 1], disp.bin.lowers.plot[, 2], lty = 3, lw = 3, col = "#5E5E5E") lines(disp.bin.means.empirical.plot[, 1], disp.bin.means.empirical.plot[, 2], lw = 4, col = "#A07F7F") lines(disp.landbirds.empirical.plot[, 1], disp.landbirds.empirical.plot[, 2], lw = 4, col = "#6EB057") lines(disp.waterbirds.empirical.plot[, 1], disp.waterbirds.empirical.plot[, 2], lw = 4, col = "#6699CC") lines(disp.passerines.empirical.plot[, 1], disp.passerines.empirical.plot[, 2], lw = 4, col = "#745B8C") text(y = 1 , x = 0.5,labels = MDI.Neornithes, cex = 1, col = "#A07F7F" ) ### Disparities: Plot empirical values versus simulated values disparities.jittered <- jitter( disparity.nodes.temp, factor =0.001) choose.node <- "137" dev.new() plot( y = disparities.jittered , x = apply( sim.disparities , 1 , mean) , bty = "l" , ylab = "Empirical disparities" , xlab = "Mean simulated disparities" , main = paste( "Bird" , element ) , pch = 21 , cex = 2, bg = BG.disp , xlim = c(0,1) + range(apply( sim.disparities , 1 , mean )) , log = "xy" ) text( y = disparities.jittered , x = apply( sim.disparities , 1 , mean) , labels = names( disparity.nodes.temp ) , pos = 4 , cex =0.5 ) abline( 0 , 1 , lty = 2 , lwd = 2 , col = "grey" ) ##### DELTA DISPARITIES ##### ## skip the previous block of code for disparity through time ## partition <- "cpf.whole.skeleton" GPA.fit <- gpagen(whole.skeleton.proportions.free) GPA.coords.temp <- GPA.fit$coords PCA.fit <- prcomp(synsacrum.and.hindlimb.skeletal.proportions) PCA.scores.temp<-PCA.fit$x data.names <- dimnames( PCA.scores.temp )[[1]] drop.taxa <- tree.temp$tip.label[ ! tree.temp$tip.label %in% data.names ] tree.temp <- drop.tip( tree.temp , drop.taxa ) PCA.scores.temp <- PCA.scores.temp[ unlist( tree.temp$tip.label ) , ] ## matches data and phylogeny for GPA coords data.names <- dimnames( GPA.coords.temp ) [[3]] ## drop.taxa <- tree.temp$tip.label[ ! tree.temp$tip.label %in% data.names ] tree.temp <- drop.tip( tree.temp , drop.taxa ) GPA.coords.temp <- GPA.coords.temp[ , , unlist( tree.temp$tip.label ) ] #subsetting by another element re-orders the data with the element's order # simulations fit1 <- mvgls(two.d.array(GPA.coords.temp)~1, tree=tree.temp, model="BM", method="H&L") sim.temp.new <- mvSIM(tree.temp, nsim = 200, model = "BM1", param = list(sigma = fit1$sigma$Pinv, theta = fit1$coefficients )) lndmks.bone <- dim(GPA.coords.temp)[1] * 3 number.taxa <-length(tree.temp$tip.label) x <- array(unlist(sim.temp.new), c(number.taxa,lndmks.bone,200), dimnames = list(dimnames(GPA.coords.temp)[[3]],as.character(c(1:lndmks.bone)),as.character(c(1:200)))) # read only once # code for clades anseriforms.taxa <- get.descendants(tree.temp, node = 234) anseriforms.empirical.disp <- proc.disp(two.d.array(GPA.coords.temp[,, anseriforms.taxa])) anseriforms.sims <- x[ anseriforms.taxa,,] anseriforms.sim.disparities <- apply( anseriforms.sims , 3 , proc.disp) interquantile.range <- quantile(anseriforms.sim.disparities, probs = 0.75) - quantile (anseriforms.sim.disparities, probs = 0.25) anseriforms.delta.disp [[partition]] <- ( -1 * (anseriforms.sim.disparities - anseriforms.empirical.disp))/ interquantile.range galliforms.taxa <- get.descendants(tree.temp, node = 240) galliforms.empirical.disp <- proc.disp(two.d.array(GPA.coords.temp[,, galliforms.taxa])) galliforms.sims <- x[ galliforms.taxa,,] galliforms.sim.disparities <- apply( galliforms.sims , 3 , proc.disp) interquantile.range <- quantile(galliforms.sim.disparities, probs = 0.75) - quantile (galliforms.sim.disparities, probs = 0.25) galliforms.delta.disp [[partition]] <- ( -1 * (galliforms.sim.disparities - galliforms.empirical.disp))/ interquantile.range gruiforms.taxa <- get.descendants(tree.temp, node = 275) gruiforms.empirical.disp <- proc.disp(two.d.array(GPA.coords.temp[,, gruiforms.taxa])) gruiforms.sims <- x[gruiforms.taxa,,] gruiforms.sim.disparities <- apply( gruiforms.sims , 3 , proc.disp) interquantile.range <- quantile(gruiforms.sim.disparities, probs = 0.75) - quantile (gruiforms.sim.disparities, probs = 0.25) gruiforms.delta.disp [[partition]] <- (-1 * (gruiforms.sim.disparities - gruiforms.empirical.disp )) / interquantile.range strisores.taxa <-get.descendants(tree.temp, node = 249) otidimorph.taxa <- get.descendants(tree.temp, node = 261) neoavian.terrestrial.taxa <- c(strisores.taxa, otidimorph.taxa) neoavian.terrestrial.empirical.disp <- proc.disp(two.d.array(GPA.coords.temp[,, neoavian.terrestrial.taxa])) neoavian.terrestrial.sims <- x[ neoavian.terrestrial.taxa,,] neoavian.terrestrial.sim.disparities <- apply( neoavian.terrestrial.sims , 3 , proc.disp) interquantile.range <- quantile(neoavian.terrestrial.sim.disparities, probs = 0.75) - quantile (neoavian.terrestrial.sim.disparities, probs = 0.25) neoavian.terrestrial.delta.disp [[partition]] <- (-1 * ( neoavian.terrestrial.sim.disparities - neoavian.terrestrial.empirical.disp )) / interquantile.range landbirds.taxa <- get.descendants(tree.temp, node = 330) # subsets all landbirds to get the non-passerine landbirds passerines.taxa <- get.descendants(tree.temp, node = 374) passerines.empirical.disp <- proc.disp(two.d.array(GPA.coords.temp[,, passerines.taxa])) passerines.sims <- x[passerines.taxa,,] passerines.sim.disparities <- apply( passerines.sims , 3 , proc.disp) interquantile.range <- quantile(passerines.sim.disparities, probs = 0.75) - quantile (passerines.sim.disparities, probs = 0.25) passerines.delta.disp [[partition]] <- (-1 * (passerines.sim.disparities - passerines.empirical.disp)) / interquantile.range non.passerine.landbirds.taxa <-landbirds.taxa[!landbirds.taxa %in% passerines.taxa] non.passerine.landbirds.empirical.disp <- proc.disp(two.d.array(GPA.coords.temp[,, non.passerine.landbirds.taxa])) non.passerine.landbirds.sims <- x[non.passerine.landbirds.taxa,,] non.passerine.landbirds.sim.disparities <- apply( non.passerine.landbirds.sims , 3 , proc.disp) interquantile.range <- quantile(non.passerine.landbirds.sim.disparities, probs = 0.75) - quantile (non.passerine.landbirds.sim.disparities, probs = 0.25) non.passerine.landbirds.delta.disp [[partition]] <- (-1 * (non.passerine.landbirds.sim.disparities - non.passerine.landbirds.empirical.disp)) / interquantile.range waterbirds.taxa <- get.descendants(tree.temp, node = 284) waterbirds.empirical.disp <- proc.disp(two.d.array(GPA.coords.temp[,, waterbirds.taxa])) waterbirds.sims <- x[waterbirds.taxa,,] waterbirds.sim.disparities <- apply( waterbirds.sims , 3 , proc.disp) interquantile.range <- quantile(waterbirds.sim.disparities, probs = 0.75) - quantile (waterbirds.sim.disparities, probs = 0.25) waterbirds.delta.disp [[partition]] <- (-1 * (waterbirds.sim.disparities - waterbirds.empirical.disp)) / interquantile.range ardeans.taxa <- get.descendants(tree.temp, node = 306) ardeans.empirical.disp <- proc.disp(two.d.array(GPA.coords.temp[,, ardeans.taxa])) ardeans.sims <- x[ardeans.taxa,,] ardeans.sim.disparities <- apply( ardeans.sims , 3 , proc.disp) interquantile.range <- quantile(ardeans.sim.disparities, probs = 0.75) - quantile (ardeans.sim.disparities, probs = 0.25) ardeans.delta.disp [[partition]] <- (-1 * (ardeans.sim.disparities - ardeans.empirical.disp)) / interquantile.range shorebirds.taxa <- get.descendants(tree.temp, node = 291) shorebirds.empirical.disp <- proc.disp(two.d.array(GPA.coords.temp[,, shorebirds.taxa])) shorebirds.sims <- x[shorebirds.taxa,,] shorebirds.sim.disparities <- apply( shorebirds.sims , 3 , proc.disp) interquantile.range <- quantile(shorebirds.sim.disparities, probs = 0.75) - quantile (shorebirds.sim.disparities, probs = 0.25) shorebirds.delta.disp [[partition]] <- (-1 * (shorebirds.sim.disparities - shorebirds.empirical.disp)) / interquantile.range gruiforms.taxa <- get.descendants(tree.temp, node = 279) gruiforms.empirical.disp <- proc.disp(two.d.array(GPA.coords.temp[,, gruiforms.taxa])) gruiforms.sims <- x[gruiforms.taxa,,] gruiforms.sim.disparities <- apply( gruiforms.sims , 3 , proc.disp) interquantile.range <- quantile(gruiforms.sim.disparities, probs = 0.75) - quantile (gruiforms.sim.disparities, probs = 0.25) gruiforms.delta.disp [[partition]] <- (-1 * (gruiforms.sim.disparities - gruiforms.empirical.disp )) / interquantile.range most.taxa <- c(landbirds.taxa, waterbirds.taxa, gruiforms.taxa, anseriforms.taxa) neornithines.taxa <- tree.temp$tip.label neornithines.empirical.disp <- proc.disp(two.d.array(GPA.coords.temp[,, neornithines.taxa])) neornithines.sims <- x[neornithines.taxa,,] neornithines.sim.disparities <- apply( neornithines.sims , 3 , proc.disp) interquantile.range <- quantile(neornithines.sim.disparities, probs = 0.75) - quantile (neornithines.sim.disparities, probs = 0.25) neornithines.delta.disp [[partition]] <- ( -1 * (neornithines.sim.disparities - neornithines.empirical.disp)) / interquantile.range non.landbird.terrestrial.taxa <- neornithines.taxa[!neornithines.taxa %in% most.taxa] non.landbird.terrestrial.empirical.disp <- proc.disp(two.d.array(GPA.coords.temp[,, non.landbird.terrestrial.taxa])) non.landbird.terrestrial.sims <- x[ non.landbird.terrestrial.taxa,,] non.landbird.terrestrial.sim.disparities <- apply( non.landbird.terrestrial.sims , 3 , proc.disp) interquantile.range <- quantile(non.landbird.terrestrial.sim.disparities, probs = 0.75) - quantile (non.landbird.terrestrial.sim.disparities, probs = 0.25) non.landbird.terrestrial.delta.disp [[partition]] <- (-1 * ( non.landbird.terrestrial.sim.disparities - non.landbird.terrestrial.empirical.disp )) / interquantile.range # use get descendants to get the string of taxa # calculate empirical disparity # subset object X using that string # calculate disparity for each simulation round plot(sort(waterbirds.delta.disp[[partition]], decreasing = T), ylim = c(-10, 10),pch = 21, col= "transparent", bg = "#6699CC") points(sort(non.passerine.landbirds.delta.disp[[partition]], decreasing = T), pch = 21, col="transparent", bg = "#6EB057") points(sort(passerines.delta.disp[[partition]], decreasing = T), pch = 21, col="transparent", bg = "#745B8C") points(sort(neornithines.delta.disp[[partition]], decreasing = T), pch = 21, col="transparent", bg = "#A07F7F") save.image("DELTA DISPARITIES OTHER GROUPS.RData ") # boxplots neornithines <- unlist(neoavian.terrestrial.delta.disp) cat.neornithines <- names(neornithines) cat.neornithines <- gsub('[0-9]+', '', cat.neornithines) df <- data.frame(neornithines, cat.neornithines) df %>% ggplot( aes(x=cat.neornithines, y=neornithines)) + geom_boxplot(fill = "#59442F", colour = "#59442F", alpha = 0.8, lwd = 0.8, outlier.fill = "#59442F", outlier.colour = "#59442F", outlier.size = 3, outlier.alpha = 0.7, width =0.8) + theme_minimal() + theme(axis.text.x = element_text(face="bold", color="#525252", size=6, hjust = 1, vjust=1, angle=60), legend.position="none", plot.title = element_text(size=15)) + scale_x_discrete(limits=c("sp.whole.skeleton.", "cf.whole.skeleton.", "cpf.whole.skeleton.", "","", "sp.head.", "cf.head.", "cpf.head.", "","", "sp.pectoral girdle and forelimb.", "cf.pectoral girdle and forelimb.", "cpf.pectoral girdle and forelimb.", "","", "sp.synsacrum and hindlimb.", "cf.synsacrum and hindlimb.", "cpf.synsacrum and hindlimb.", "","", "skull.", "pf.skull.", "", "mandible.", "pf.mandible.", "", "sternum.", "pf.sternum.", "", "coracoid.", "pf.coracoid.", "", "scapula.", "pf.scapula.", "", "humerus.", "pf.humerus.", "", "ulna.", "pf.ulna.", "", "radius.", "pf.radius.", "", "carpometacarpus.", "pf.carpometacarpus.", "", "synsacrum.", "pf.synsacrum.", "", "femur.", "pf.femur.", "", "tibiotarsus.", "pf.tibiotarsus.", "", "tarsometatarsus.", "pf.tarsometatarsus.")) + coord_cartesian(ylim = c(-15, 10)) + ggtitle("Gruiformes") + xlab("") labels <- as.factor(cat.passerines) partitions <- c(levels(labels)) ## Additional plotting code ## ## DISPARITY THROUGH TIME MDI PLOTS ## # Note: you need to generate the appropriate .csv files from the analyses of previous blocks of code Neornithes.MDIs <- as.matrix(read.csv("MDIS WITH CI/NEORNITHES.csv", row.names = 1)) Waterbirds.MDIs <- as.matrix(read.csv("MDIS WITH CI/WATERBIRDS.csv", row.names = 1)) Landbirds.MDIs <- as.matrix(read.csv("MDIS WITH CI/LANDBIRDS.csv", row.names = 1)) Passerines.MDIs <- as.matrix( read.csv("MDIS WITH CI/PASSERINES.csv", row.names = 1)) #plotting MDIs for Proportions Neornithes.proportions <- Neornithes.MDIs[ c(1,4,7,10) , ] Waterbirds.proportions <- Waterbirds.MDIs[ c(1,4,7,10) , ] Landbirds.proportions <- Landbirds.MDIs[ c(1,4,7,10) , ] Passerines.proportions <- Passerines.MDIs[ c(1,4,7,10) , ] # x axis width x = 1:nrow(Neornithes.proportions) # horizontal offset for data of same group offset = 0.2 # draw empty plot plot(NULL, xlim=c(0, nrow(Neornithes.proportions) + 1), ylim=c(min(Passerines.proportions), max(Waterbirds.proportions,na.rm=T)), xaxt='n', ylab='MDI.Proportions', xlab='', frame.plot = F) abline(a = 0, b = 0, lty = 1, lw = 3, col = "#999999") # adds zero line # add points points(x - 2*offset, Neornithes.proportions[,2], pch=21, cex = 2, bg="transparent", col = "#9B7B7C", lw = 3) # mean MDIs for Neornithes points(x - offset, Waterbirds.proportions[,2], pch=21, cex = 2, bg="transparent", col = "#6496C5", lw = 3) points(x, Landbirds.proportions[,2], pch=21, cex = 2, bg="transparent", col = "#67A651", lw = 3) points(x+offset, Passerines.proportions[,2], pch=21, cex = 2, bg="transparent", col = "#644369", lw = 3) # add error bars (arrows with angle=90) arrows(x0=x - 2*offset, x1=x - 2*offset, y0 = Neornithes.proportions[,1], y1 = Neornithes.proportions[,3], angle=90, code=3, len=0.03, col = "#9B7B7C", lw = 3)# arrows(x0=x - offset, x1=x - offset, y0 = Waterbirds.proportions[,1], y1 = Waterbirds.proportions[,3], angle=90, code=3, len=0.03, col = "#6496C5", lw = 3)# arrows(x0=x, x1=x , y0 = Landbirds.proportions[,1], y1 = Landbirds.proportions[,3], angle=90, code=3, len=0.03, col = "#67A651", lw = 3)# arrows(x0=x+offset, x1=x+offset , y0 = Passerines.proportions[,1], y1 = Passerines.proportions[,3], angle=90, code=3, len=0.03, col = "#644369", lw = 3)# # axis labels axis(3, at = 1:nrow(Neornithes.proportions), labels = rownames(Neornithes.proportions), las=1, cex.axis= 0.5, lwd = 0) # add legend legend(x='topleft', legend=colnames(a), col=c(1,2,4), pch=c(1,2,3), inset=0.02) #plotting MDIs for COMBINED FORM AND COMBINED Neornithes.cf <- Neornithes.MDIs[ c(2,5,8,11) , ] Neornithes.cpf <- Neornithes.MDIs[ c(3,6,9,12) , ] Waterbirds.cf <- Waterbirds.MDIs[ c(2,5,8,11) , ] Waterbirds.cpf <- Waterbirds.MDIs[ c(3,6,9,12) , ] Landbirds.cf <- Landbirds.MDIs[ c(2,5,8,11) , ] Landbirds.cpf <- Landbirds.MDIs[ c(3,6,9,12) , ] Passerines.cf <- Passerines.MDIs[ c(2,5,8,11) , ] Passerines.cpf <- Passerines.MDIs[ c(3,6,9,12) , ] # x axis width x = 1:nrow(Neornithes.proportions) # horizontal offset for data of same group offset = 0.03 # draw empty plot plot(NULL, xlim=c(0.5, nrow(Neornithes.proportions) + 1), ylim=c(min(Passerines.proportions), max(Waterbirds.proportions,na.rm=T)), xaxt='n', ylab='MDI.Combined elements', xlab='', frame.plot = F) abline(a = 0, b = 0, lty = 1, lw = 3, col = "#999999") # adds zero line # add points points(x - 9*offset, Neornithes.cf[,2], pch=21, cex = 1.5, col="transparent",bg = "#9B7B7C", lw = 3) points(x - 8*offset, Neornithes.cpf[,2], pch=21, cex = 1.5, col="transparent", bg = "#C3B1B1", lw = 3) points(x - 4*offset, Waterbirds.cf[,2], pch=21, cex = 1.5, col="transparent", bg = "#6496C5", lw = 3) points(x - 3*offset, Waterbirds.cpf[,2], pch=21, cex = 1.5, col="transparent", bg = "#A2C0DC", lw = 3) points(x + 3*offset, Landbirds.cf[,2], pch=21, cex = 1.5, col="transparent", bg = "#67A651", lw = 3) points(x + 4*offset, Landbirds.cpf[,2], pch=21, cex = 1.5, col="transparent", bg = "#A4CA97", lw = 3) points(x + 8*offset, Passerines.cf[,2], pch=21, cex = 1.5, col="transparent", bg = "#6D4573", lw = 3) points(x + 9*offset, Passerines.cpf[,2], pch=21, cex =1.5, col="transparent", bg = "#A68FA9", lw = 3) # add error bars (arrows with angle=90) arrows(x0=x - 9*offset, x1=x - 9*offset, y0 = Neornithes.cf[,1], y1 = Neornithes.cf[,3], angle=90, code=3, len=0.03, col = "#9B7B7C", lw = 3)# arrows(x0=x - 8*offset, x1=x - 8*offset, y0 = Neornithes.cpf[,1], y1 = Neornithes.cpf[,3], angle=90, code=3, len=0.03, col = "#C3B1B1", lw = 3)# arrows(x0=x - 4*offset, x1=x - 4*offset, y0 = Waterbirds.cf[,1], y1 = Waterbirds.cf[,3], angle=90, code=3, len=0.03, col = "#6496C5", lw = 3)# arrows(x0=x - 3*offset, x1=x - 3*offset, y0 = Waterbirds.cpf[,1], y1 = Waterbirds.cpf[,3], angle=90, code=3, len=0.03, col = "#A2C0DC", lw = 3)# arrows(x0=x + 3*offset, x1=x + 3*offset , y0 = Landbirds.cf[,1], y1 = Landbirds.cf[,3], angle=90, code=3, len=0.03, col = "#67A651", lw = 3)# arrows(x0=x + 4*offset, x1=x + 4*offset , y0 = Landbirds.cpf[,1], y1 = Landbirds.cpf[,3], angle=90, code=3, len=0.03, col = "#A4CA97", lw = 3)# arrows(x0=x + 8*offset, x1=x + 8*offset , y0 = Passerines.cf[,1], y1 = Passerines.cf[,3], angle=90, code=3, len=0.03, col = "#6D4573", lw = 3)# arrows(x0=x + 9*offset, x1=x + 9*offset, y0 = Passerines.cpf[,1], y1 = Passerines.cpf[,3], angle=90, code=3, len=0.03, col = "#A68FA9", lw = 3)# # axis labels axis(3, at = 1:nrow(Neornithes.cf), labels = rownames(Neornithes.cf), las=1, cex.axis= 0.55, lwd = 0) # add legend legend(x='topleft', legend=colnames(a), col=c(1,2,4), pch=c(1,2,3), inset=0.02) #plotting MDIs for INDIVIDUAL ELEMENTS Neornithes.shapes <- Neornithes.MDIs[ c(13, 15, 17, 19, 21, 23, 25, 27, 29, 31, 33, 35, 37) , ] Neornithes.pfs <- Neornithes.MDIs[ c(14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38) , ] Waterbirds.shapes <- Waterbirds.MDIs[ c(13, 15, 17, 19, 21, 23, 25, 27, 29, 31, 33, 35, 37) , ] Waterbirds.pfs <- Waterbirds.MDIs[ c(14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38) , ] Landbirds.shapes <- Landbirds.MDIs[ c(13, 15, 17, 19, 21, 23, 25, 27, 29, 31, 33, 35, 37) , ] Landbirds.pfs <- Landbirds.MDIs[ c(14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38) , ] Passerines.shapes <- Passerines.MDIs[ c(13, 15, 17, 19, 21, 23, 25, 27, 29, 31, 33, 35, 37) , ] Passerines.pfs <- Passerines.MDIs[ c(14, 16, 18, 20, 22, 24, 26, 28, 30, 32, 34, 36, 38) , ] # x axis width x = 1:nrow(Neornithes.shapes) # horizontal offset for data of same group offset = 0.03 # draw empty plot plot(NULL, xlim=c(0.5, nrow(Neornithes.shapes) + 1), ylim=c(min(Landbirds.shapes), max(Passerines.shapes,na.rm=T)), xaxt='n', ylab='MDI.Individual elements', xlab='', frame.plot = F) abline(a = 0, b = 0, lty = 1, lw = 3, col = "#999999") # adds zero line # add points points(x - 9*offset, Neornithes.shapes[,2], pch=21, cex = 1.5, col="transparent",bg = "#9B7B7C", lw = 3) points(x - 8*offset, Neornithes.pfs[,2], pch=21, cex = 1.5, col="transparent", bg = "#C3B1B1", lw = 3) points(x - 4*offset, Waterbirds.shapes[,2], pch=21, cex = 1.5, col="transparent", bg = "#6496C5", lw = 3) points(x - 3*offset, Waterbirds.pfs[,2], pch=21, cex = 1.5, col="transparent", bg = "#A2C0DC", lw = 3) points(x + 3*offset, Landbirds.shapes[,2], pch=21, cex = 1.5, col="transparent", bg = "#67A651", lw = 3) points(x + 4*offset, Landbirds.pfs[,2], pch=21, cex = 1.5, col="transparent", bg = "#A4CA97", lw = 3) points(x + 8*offset, Passerines.shapes[,2], pch=21, cex = 1.5, col="transparent", bg = "#6D4573", lw = 3) points(x + 9*offset, Passerines.pfs[,2], pch=21, cex =1.5, col="transparent", bg = "#A68FA9", lw = 3) # add error bars (arrows with angle=90) arrows(x0=x - 9*offset, x1=x - 9*offset, y0 = Neornithes.shapes[,1], y1 = Neornithes.shapes[,3], angle=90, code=3, len=0.03, col = "#9B7B7C", lw = 3)# arrows(x0=x - 8*offset, x1=x - 8*offset, y0 = Neornithes.pfs[,1], y1 = Neornithes.pfs[,3], angle=90, code=3, len=0.03, col = "#C3B1B1", lw = 3)# arrows(x0=x - 4*offset, x1=x - 4*offset, y0 = Waterbirds.shapes[,1], y1 = Waterbirds.shapes[,3], angle=90, code=3, len=0.03, col = "#6496C5", lw = 3)# arrows(x0=x - 3*offset, x1=x - 3*offset, y0 = Waterbirds.pfs[,1], y1 = Waterbirds.pfs[,3], angle=90, code=3, len=0.03, col = "#A2C0DC", lw = 3)# arrows(x0=x + 3*offset, x1=x + 3*offset , y0 = Landbirds.shapes[,1], y1 = Landbirds.shapes[,3], angle=90, code=3, len=0.03, col = "#67A651", lw = 3)# arrows(x0=x + 4*offset, x1=x + 4*offset , y0 = Landbirds.pfs[,1], y1 = Landbirds.pfs[,3], angle=90, code=3, len=0.03, col = "#A4CA97", lw = 3)# arrows(x0=x + 8*offset, x1=x + 8*offset , y0 = Passerines.shapes[,1], y1 = Passerines.shapes[,3], angle=90, code=3, len=0.03, col = "#6D4573", lw = 3)# arrows(x0=x + 9*offset, x1=x + 9*offset, y0 = Passerines.pfs[,1], y1 = Passerines.pfs[,3], angle=90, code=3, len=0.03, col = "#A68FA9", lw = 3)# # axis labels axis(3, at = 1:nrow(Neornithes.shapes), labels = rownames(Neornithes.shapes), las=1, cex.axis= 1, lwd = 0) save.image("PASSERINES DELTA DISPARITIES.RData ")