###### FUNCTIONS ######
		
			get.descendants <- function( phy , node ) { extract.clade( phy , node )$tip.label }


			
			subset.rows <- function( data , rownames ) { data[ rownames , ] }

	
			#### old bits
			# same as dimensionality.phylo but with disparity 
			
			
			disparity.phylo <- function( data , phy ) {
			 	  nodes.temp <- unique( phy$edge[,1] )
			    descendants.temp <- lapply( nodes.temp , FUN = get.descendants , phy = phy )
			      names( descendants.temp ) <- nodes.temp			
			        node.data.list <- lapply( descendants.temp , FUN = subset.rows , data = data )
			          disparity.temp<-list() 
			          for (i in 1: length( node.data.list ) ) {
			            distances<-dist(node.data.list[[i]], method = "euclidean")
			            disparity.temp[i]<- mean(distances)                             # loop does the same process as Procrustes variance:
			           
			          			          }
			  names(disparity.temp)<-nodes.temp
			  disparity.temp<-unlist(disparity.temp)
			  disparity.temp
			  disparity.temp.scaled<-disparity.temp / disparity.temp[1]
			  disparity.temp.scaled
			  
			}
			
			# function for delta disparities 
			
			proc.disp <- function (data) {
			  
			  disparity.temp <-mean(dist(data, method = "euclidean"))
			  
			}  
			
      morphol.disp.GN <- function (shape) {
        
        shape <-arrayspecs(shape, p = lndmks.bone/3, k = 3)
        df <- geomorph.data.frame(shape = shape)
        morphol.disp <- morphol.disparity(shape ~ 1, data = df)
        
      }
			

			

    			## NEW FUNCTION ##
    			## Creates mean trends of empirical and simulated data of one our variable through time, including CI intervals for simulations under BM
    			## the input is a vector of empirical data, a matrix of simulated data and a phylogeny
    			## uses tree.age() to get node ages
    			
    			trend.through.time<- function (empirical, simulations, phy) {
    		
    				 nodes.ages <- tree.age(phy) 
    			    node.ages.temp.mod <- nodes.ages[,1]
    			      names(node.ages.temp.mod)<- as.character(nodes.ages[,2])
    			      node.ages.temp.mod<-node.ages.temp.mod[ names(empirical)]
    		
    			        
    			      #This block makes the matrix of temporal ranges of stem lineages with rownames as the lineages
    			      
    			      phylogeny.edges <- phy$edge
    			        rownames(phylogeny.edges) <- phy$edge[, 2] # descendent nodes and tips as rownames
    			      descendent.nodes <- phylogeny.edges[,1] 
    			        names(descendent.nodes) <- as.character(rownames(phylogeny.edges)) # make a vector with parent nodes as values and descendant as names
    			      
    			      branches <- phy$edge.length
    			        names(branches) <- names(descendent.nodes) # values are branch lengths names are the node in which it ends
    			      tip.names <- as.character(c(1: length(phy$tip.label))) # creates a vector of tip names
    			        tips <- branches[tip.names]  # subset the tips
    			          branches.mod <- branches[!branches %in% tips] # we do not want tips we are subsetting tips out.
                                                      			      # already in descending order
                                                      			      # this data is the branch lengths that end in the node which is the name
    			      
    			      end.dates.lineages <- node.ages.temp.mod [2 : length(node.ages.temp.mod)] # you need to get rid of the basal node as it is the beggining of a stem lineage
    			      beggining.date.lineages <- branches.mod + end.dates.lineages 
    			        stem.lineages.dates <-cbind(beggining.date.lineages, end.dates.lineages) # final dataframe with stem lineages ranges!
    			          stem.lineages.dates <- stem.lineages.dates[order(stem.lineages.dates[,2], decreasing = T),] #order by descending end ranges
    			           
    			          
    			          # This last bit prepared the vector of branching events for analyses
    			          # descending order so most recent branching orders are at the end
    			          node.ages.temp.mod<- node.ages.temp.mod[order(node.ages.temp.mod, decreasing = T)] 
    			          # deletes last branching event in which only one lineage is alive and therefore cannot be summarised by the function
    			          node.ages.temp.mod <- node.ages.temp.mod[1: length(node.ages.temp.mod) - 1] 
    			          node.ages.temp.mod<-unlist(node.ages.temp.mod) # all branching events (nodes) from which median values will be extracted
    			            binned.uppers<-list()
    			            binned.means<-list()
    			            binned.lowers<-list()
    			            binned.means.empirical<-list()
                			  for (i in 2: length(node.ages.temp.mod)) {
                			    
                			    value.node = node.ages.temp.mod[i] # select first node (first branching event)
                			    
                    			 which.lineages <- names(which(stem.lineages.dates[,1] >= value.node & stem.lineages.dates[,2] <= value.node, useNames = T))
                    			  print(which.lineages)
                    			  
                    			  node.sim.list <- simulations[which.lineages, ]
                			          node.empirical.list <- empirical [which.lineages]
                			    
                			          binned.simulations<-colMeans(node.sim.list, na.rm = T)
                			            binned.uppers[i]<-quantile(binned.simulations, probs = 0.95, na.rm = T)
                			            binned.means[i]<-mean(binned.simulations, na.rm = T)
                			            binned.lowers[i]<-quantile(binned.simulations, probs = 0.05, na.rm = T)
                			          binned.means.empirical[i]<- mean(node.empirical.list, na.rm = T)
                			  }
    			  names(binned.uppers) <- as.character(node.ages.temp.mod)
    			    binned.uppers<-unlist ( binned.uppers [ unique ( names ( binned.uppers ) ) ] )
    			      
    			  names(binned.means) <- as.character(node.ages.temp.mod)
    			    binned.means<-unlist ( binned.means [ unique ( names ( binned.means ) ) ] )
    			      
    			  names(binned.lowers) <- as.character(node.ages.temp.mod)
    			    binned.lowers<-unlist ( binned.lowers [ unique ( names ( binned.lowers ) ) ] )
    			      
    			  names(binned.means.empirical) <- as.character(node.ages.temp.mod)
    			    binned.means.empirical<-unlist ( binned.means.empirical [ unique ( names ( binned.means.empirical ) ) ] )
    			     
    			  branching.events.plot <- node.ages.temp.mod[! duplicated(node.ages.temp.mod) ] 
    			  branching.events.plot <- branching.events.plot[-1] 
    			  
    			  trends.envelope <- list(binned.uppers, binned.lowers, binned.means, binned.means.empirical, branching.events.plot)
    			  
    			}
    			
    			# Same as trend.through.time() but for subclades and only empirical data
    			
    			trend.through.time.empirical<- function (empirical, phy, subset) {
    			   nodes.ages <- tree.age(phy) 
      			  node.ages.temp.mod <- nodes.ages[,1]
        			  names(node.ages.temp.mod)<- as.character(nodes.ages[,2])
        			   node.ages.temp.mod<-node.ages.temp.mod[ names(empirical)]
        			    node.ages.temp.mod <- node.ages.temp.mod [subset] # subset only the clade branching events
        			    
    			  
      			  #This block makes the matrix of temporal ranges of stem lineages with rownames as the lineages
      			  phylogeny.edges <- phy$edge
        			  rownames(phylogeny.edges) <- phy$edge[, 2] # descendent nodes and tips as rownames
        			    descendent.nodes <- phylogeny.edges[,1] 
        			      names(descendent.nodes) <- as.character(rownames(phylogeny.edges)) # make a vector with parent nodes as values and descendant as names
      			  
      			  branches <- phy$edge.length
        			  names(branches) <- names(descendent.nodes) # values are branch lengths names are the node in which it ends
          			  tip.names <- as.character(c(1: length(phy$tip.label))) # creates a vector of tip names
            			  tips <- branches[tip.names]  # subset the tips
              			  branches.mod <- branches[!branches %in% tips] # we do not want tips we are subsetting tips out.# already in descending order # this data is the branch lengths that end in the node which is the name
        			          branches.mod <- branches.mod[subset]
        			          
      			  end.dates.lineages <- node.ages.temp.mod  # you do not need to get rid of the basal node which is a lineage
      			    beggining.date.lineages <- branches.mod + end.dates.lineages 
      			      stem.lineages.dates <-cbind(beggining.date.lineages, end.dates.lineages) # final dataframe with stem lineages ranges!
      			        stem.lineages.dates <- stem.lineages.dates[order(stem.lineages.dates[,2], decreasing = T),] #order by descending end ranges
      			  
      			  
      			  # This last bit prepared the vector of branching events for analyses
      			  # descending order so most recent branching orders are at the end
      			  node.ages.temp.mod<- node.ages.temp.mod[order(node.ages.temp.mod, decreasing = T)] 
      			  # deletes last branching event in which only one lineage is alive and therefore cannot be summarised by the function
      			    node.ages.temp.mod <- node.ages.temp.mod[1: length(node.ages.temp.mod) - 1] 
      			      node.ages.temp.mod<-unlist(node.ages.temp.mod) # all branching events (nodes) from which median values will be extracted
      			  
      			   binned.means.empirical<-list()
      			   
      			    for (i in 1: length(node.ages.temp.mod)) {
      			      
      			      value.node = node.ages.temp.mod[i] # select first node (first branching event)
      			    
        			    which.lineages <- names(which(stem.lineages.dates[,1] >= value.node & stem.lineages.dates[,2] <= value.node, useNames = T))
        			    print(which.lineages)
        			    
        			    node.empirical.list <- empirical [which.lineages]
        			    
        			    binned.means.empirical[i]<- mean(node.empirical.list, na.rm = T)
      			  }
    			 
      			names(binned.means.empirical) <- as.character(node.ages.temp.mod)
    			  binned.means.empirical<-unlist ( binned.means.empirical [ unique ( names ( binned.means.empirical ) ) ] )
    			  
    			  branching.events.plot <- node.ages.temp.mod[! duplicated(node.ages.temp.mod) ] 
    			 
    			  
    			  trends.envelope <- list(binned.means.empirical, branching.events.plot)
    			  
    			  
    			}
    			
    			
			
			  ###Function applies gpagen() to compiled.landmarks objects, used by lapply() call in combine.element.landmarks()				
			  GPA.grabber <- function( compiled.landmarks , lm.counts = "min" ) { 
			    GPA.temp <- gpagen( compiled.landmarks[[ lm.counts ]][[ "output.landmarks.array" ]] , curves = compiled.landmarks[[ lm.counts ]][[ "sliders" ]] , approxBE = T)
			    rownames( GPA.temp$coords ) <- dimnames( compiled.landmarks[[ lm.counts ]][[ "output.landmarks.array" ]] )[[ 1 ]]
			    GPA.temp
			  }
			  
			  ###Function that multiples GPA$coords by GPA centroid sizes, used by combine.element.landmarks()
			  resize.GPA.coords <- function( GPA.fit ) {
			    for( i in 1:length( GPA.fit$Csize ) ) {
			      GPA.fit$coords[,,i] <- GPA.fit$coords[,,i] * GPA.fit$Csize[i]	}
			    GPA.fit$coords
			  }
			  
			  ###Function that scales a landmark array so each specimen has unit centroid size, used combine.element.landmarks(). Warning: only works on landmarks that are already centred on the origin
			  unit.scale.coords <- function( lm.array ) {
			    GPA.temp <- gpagen( lm.array )	
			    for( i in 1:length( GPA.temp$Csize ) ) {
			      lm.array[,,i] <- lm.array[,,i] / GPA.temp$Csize[i]	}
			    lm.array
			  }
			  
			  ###Useful functions, used by combine.element.landmarks()		
			  get.array.element <- function( X , element ) { X[ , , element ] }
			  get.item.list <- function( X ,item ){ X[[ item ]] }
			  
			  ###Function applies partial Procrustes superposition to each set of compiled.landmarks for a vector of elements individually. It then combines them into a shared multi-element array and scales each specimen to unit centroid size
			  combine.element.landmarks <- function( compiled.landmarks , elements = c( "skull", "mandible") )	{
			    
			    GPA.list.temp <- lapply( compiled.landmarks[ elements ] , GPA.grabber , lm.counts = "min" )
			      GPA.coords.resized.temp <- lapply( GPA.list.temp , resize.GPA.coords )
			        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
			    
			  }
			  
			 # Function that makes a matrix of individual elements centroid sizes
			  
			  combine.element.CS <- function( compiled.landmarks , elements = c( "skull", "mandible") )	{
			    
			    GPA.list.temp <- lapply( compiled.landmarks[ elements ] , GPA.grabber , lm.counts = "min" )
  			    combined.CS.list <- list()
    			    for( i in 1:length (elements)) {
    			      combined.CS.list[[i]] <- GPA.list.temp[[i]][[2]]
    			    } 
  			    combined.CS.list 
  			      combined.CS.temp <- matrix(unlist(combined.CS.list), ncol = length(combined.CS.list), nrow = length(names(combined.CS.list[[1]])) ,  byrow = F,
  			                     dimnames = list(names(combined.CS.list[[1]]), elements))
			      combined.CS.temp
			    
			  }
			  
			  # FUNCTION THAT COMPILES ALLOMETRY-FREE RESCALED LANDMARKS 
			  
			  combine.element.allometry.free <- function( compiled.landmarks , elements = c( "skull", "mandible"), bodymass)	{
			    
			    GPA.list.temp <- lapply( compiled.landmarks[ elements ] , GPA.grabber , lm.counts = "min" )
			    
			    for( i in 1:length(GPA.list.temp)){
			     
			      shape <- GPA.list.temp[[i]]$coords
			      BM <- bodymass
			        scaling.shape.frame <- geomorph.data.frame(shape = shape, BM = BM, phy = tree.temp)
    			      PGLS.allometric.free <- procD.pgls(shape ~ BM , phy = phy , data = scaling.shape.frame, iter = 9) # we do not need many iterations as statistical significance is not evaluated here
      			      allometric.free.residuals <- PGLS.allometric.free$pgls.residuals # substracts residuals
      			        allometric.free.residuals <- arrayspecs(allometric.free.residuals, dim(scaling.shape.frame$shape)[[1]] , 3, sep = ",") # converts residuals to a 3d array 
      			          allometric.free.shape <-  allometric.free.residuals + array(GPA.list.temp[[i]]$consensus, dim(allometric.free.residuals)) # generates shape residual data        
      			          dimnames(allometric.free.shape)[[1]] <- dimnames(shape)[[1]]
      			          dimnames(allometric.free.shape) [[2]] <- c("X", "Y", "Z")
    			      GPA.list.temp[[i]]$coords <- allometric.free.shape
			      
			               }
			    
			    GPA.coords.resized.temp <- lapply( GPA.list.temp , resize.GPA.coords )
			      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
			    
			  }
			  
			  
		# This new functions calculates a distribution of delta values. Delta values are computed as difference between the empirical value and 
		# each of the rounds of simulated data
			  
		delta.disparity.BM <- function (node, simulations, empirical) {
		  empirical.node <- empirical[as.character(node)]
		  simulations.node <- simulations[as.character(node),]
		  delta.disparities <-  empirical.node - simulations.node
		 }