#SCRIPT
set.seed(123)

#load packages
library(abind)
library(ape)
library(class)
library(geiger)
library(geomorph)
library(lattice)
library(mda)
library(Morpho)
library(nlme)
library(nnet)
library(phytools)

#Set working directory
setwd('')

#Download the landmark files provided in https://github.com/G-Hermanson/Turtle-cranial-ecomorphology/tree/main/3D%20landmark%20coordinates/Landmarks_full_dataset

#Store them in a 'Landmarks' folder within your working directory


#Download the following tree file provided in https://github.com/G-Hermanson/Turtle-cranial-ecomorphology/tree/main/Trees :

#Pereira_tree_pruned_full.tre

#Download the ecolomorphological data provided in https://github.com/G-Hermanson/Turtle-cranial-ecomorphology/tree/main

#The file is named as SupportingInformationS1.csv


#Now, your working directory should contain:

#- a folder named 'Landmarks' containing landmark coordinates for extant turtles
#- Nichollsemys landmark data, as in Supplementary_File_S8_Nichollsemys_landmarks.txt
#- two tree files, one used for procD.pgls analysis (Pereira_tree_pruned_full.tre) and one used for PFDA (Supplementary_File_S9_tree.tre)


#Run next lines to load custom functions needed for analyses

{

### Custom-written procD function to retrieve regression scores from ####
### phylogenetic Procustes ANOVA regression models ##

#Retrieved from Hermanson et al. (https://github.com/G-Hermanson/Turtle-cranial-ecomorphology)

################################
######## is.procD() function ###
################################

is.procD <- function( X )
{
  'lm.rrpp' %in% class( X ) | 'procD.lm' %in% class( X )
}

#########################################
######### procD.scores() function #######
#########################################

procD.scores <- function ( model , plot = TRUE )
{

if (!is.procD(model)) 
stop ("\nObject must be of procD.lm or lm.rrpp class type")

  else {
  
coefs <- rownames(coef(model))[-1]

f <- as.matrix ( model$LM$gls.fitted )
Y <- (model$LM$Y)

reg <- matrix ( NA , nrow=nrow(Y) , ncol = length(coefs) , 
                         dimnames = list(rownames(Y),coefs))

for ( i in 1:length(coefs)){
  
  xc <- as.numeric(model$data[  , coefs[i] ])
  X <- cbind ( xc , model$LM$Pcov %*% model$LM$X)  
  b <- as.matrix ( lm.fit ( X , f)$coefficients)[1,]
  
  reg[,i] <- geomorph:::center(Y) %*% b %*% solve(crossprod(b))
}
out <- reg
out

if (plot ){
dev.new()
    if (length(coefs)>1)
pairs(out  , lower.panel = NULL , pch=21,
      col = rgb(0.5,0.5,0.5,0.3),
      bg= rgb(0.8,0.8,0.8,0.2))
    else
        plot(out[,1],out[,1],pch=21, 
             col=rgb(0.5,0.5,0.5,0.3),
             bg=rgb(0.8,0.8,0.8,0.2),
             xlab=coefs[1],ylab=coefs[1])
    }
else {out}

out

}
}

###############################################
####### predict.procD.scores() function #######
###############################################

predict.procD.scores <- function ( model , newdata , plot = TRUE )
{  
  
  if (!is.procD(model)) 
    stop ("\nObject must be of procD.lm or lm.rrpp class type")
  
  else {
    
    coefs <- rownames(coef(model))[-1]
    
    f <- as.matrix ( model$LM$gls.fitted )
    
    if ( length ( dim (newdata) ) > 2   )
      newdata <- geomorph::two.d.array(newdata)
    
    Y <- newdata
    
    reg <- matrix ( NA , nrow=nrow(Y) , ncol = length(coefs) , 
                    dimnames = list(rownames(Y),coefs))
    
    for ( i in 1:length(coefs)){
      
      xc <- as.numeric(model$data[  , coefs[i] ])
      X <- cbind ( xc , model$LM$Pcov %*% model$LM$X)  
      b <- as.matrix ( lm.fit ( X , f)$coefficients)[1,]
      
      reg[,i] <- geomorph:::center(Y) %*% b %*% solve(crossprod(b))
    }
    
    
  }  
  out <- reg
  coefs_data <- rbind ( model$data[,-c(1,2)] , rep(NA, nrow(newdata)))
  
  
  #plot
  if (plot)
    dev.new()
    
    if (length(coefs)>1){
      
      pairs(rbind( procD.scores(model) , out) , lower.panel = NULL , 
            pch=c(rep(21,nrow(model$data)), rep(22,nrow(newdata)) ) ,
            cex=c(rep(1,nrow(model$data)), rep(1.25,nrow(newdata)) ),
            col=c(rep(rgb(0.5,0.5,0.5,0.3),nrow(model$data)), rep('black',nrow(newdata)) ),
            bg=c(rep(rgb(0.5,0.5,0.5,0.3),nrow(model$data)), rep('white',nrow(newdata)) ))
    par(new=T)
    plot(1, type='n', xlim=c(0,1),ylim=c(0,1), xlab='',ylab='', axes=F)
    legend('bottom', legend=c('calculated','predicted'),
           pch=c(21,22),pt.bg=c(rgb(0.5,0.5,0.5,0.3),'white'),
           pt.cex = 1, cex=1, bty='n')}
    
    else {
      plot(rbind( procD.scores(model) , out)[,1],
           rbind( procD.scores(model) , out)[,1],
           pch=c(rep(21,nrow(model$data)), rep(22,nrow(newdata)) ) ,
           cex=c(rep(1,nrow(model$data)), rep(1.25,nrow(newdata)) ),
           col=c(rep(rgb(0.5,0.5,0.5,0.3),nrow(model$data)), rep('black',nrow(newdata)) ),
           bg=c(rep(rgb(0.5,0.5,0.5,0.3),nrow(model$data)), rep('white',nrow(newdata)) ),
           xlab=coefs[1],ylab=coefs[1])
    legend('bottomright', legend=c('calculated','predicted'),
           pch=c(21,22),pt.bg=c(rgb(0.5,0.5,0.5,0.3),'white'),
           pt.cex = 1, cex=1, bty='n')}
    
  
  #else {out}
  
  out
  
}

#### Retrive p-values from ProcD.pgls objects ####

get.procD.p <- function(x){
  
  table.temp <- x$aov.table
  
  p.values <- na.omit ( table.temp[,ncol(table.temp)])
  
  p.values <- setNames(as.numeric(p.values) , colnames(x$X)[-1])
  return(p.values)
}

#### Get R-squared values from each predictor in ProcD.pgls objects ####

get.R2 <- function(X) {

table.temp <- X$aov.table

round(sum(table.temp[1:(nrow(table.temp)-2),'Rsq']),3)

}

#### Retrive p-values from gls objects ####

get.pgls.p <- function(x){
  
  table.temp <- summary(x)$tTable
  
  p.values <- table.temp[,ncol(table.temp)]
  
  }

#### Retrive p-values from phylolm objects ####

get.phylolm.p <- function(x){
  
  table.temp <- summary(x)$coefficients
  
  p.values <- table.temp[,ncol(table.temp)]
  
}

#### Custom function for calculation of Euclidean distance ####

Edist <- function ( x , Y ) { ( sum( ( x - Y ) ^ 2 ) ) ^ 0.5 }

# Get R2 values of potentially correlated variables in procD.pgls models
corR2 <- function(model,cor.vars){
  
  R2.temp <- (model$aov.table[,"Rsq"])
  vars.temp <- rownames(model$pgls.coefficients)[-1]
  
  vars.temp <- setNames(R2.temp[-c(length(R2.temp),(length(R2.temp)-1))] , vars.temp)
  
  out <- vars.temp [cor.vars]
  return(out)
}

#### Old 'plotTangentSpace' function from geomorph ####

plotTangentSpace <- function (A, axis1 = 1, axis2 = 2, warpgrids = FALSE, mesh = NULL, 
    label = NULL, groups = NULL, legend = FALSE, ...) 
{
    if (length(dim(A)) != 3) {
        stop("Data matrix not a 3D array (see 'arrayspecs').")
    }
    if (any(is.na(A)) == T) {
        stop("Data matrix contains missing values. Estimate these first (see 'estimate.missing').")
    }
    dots <- list(...)
    retx <- dots$retx
    if (is.null(retx)) 
        retx <- TRUE
    scale. <- dots$scale.
    if (is.null(scale.)) 
        scale. <- FALSE
    center <- dots$center
    if (is.null(center)) 
        center <- TRUE
    tol <- dots$tol
    k <- dim(A)[2]
    p <- dim(A)[1]
    n <- dim(A)[3]
    ref <- mshape(A)
    x <- two.d.array(A)
    if (is.null(tol)) {
        d <- prcomp(x)$sdev^2
        cd <- cumsum(d)/sum(d)
        cd <- length(which(cd < 1))
        if (length(cd) < length(d)) 
            cd <- cd + 1
        if (length(d) > 2) 
            tol <- max(c(d[cd]/d[1], 0.005))
        else tol <- 0
    }
    pc.res <- prcomp(x, center = center, scale. = scale., retx = retx, 
        tol = tol)
    pcdata <- pc.res$x

    shapes <- shape.names <- NULL
    for (i in 1:ncol(pcdata)) {
        pcaxis.min <- min(pcdata[, i])
        pcaxis.max <- max(pcdata[, i])
        pc.min <- pc.max <- rep(0, dim(pcdata)[2])
        pc.min[i] <- pcaxis.min
        pc.max[i] <- pcaxis.max
        pc.min <- as.matrix(pc.min %*% (t(pc.res$rotation))) + 
            as.vector(t(ref))
        pc.max <- as.matrix(pc.max %*% (t(pc.res$rotation))) + 
            as.vector(t(ref))
        shapes <- rbind(shapes, pc.min, pc.max)
        shape.names <- c(shape.names, paste("PC", i, "min", sep = ""), 
            paste("PC", i, "max", sep = ""))
    }
    shapes <- arrayspecs(shapes, p, k)
    shapes <- lapply(seq(dim(shapes)[3]), function(x) shapes[, 
        , x])
    names(shapes) <- shape.names
 
    out <- list(pc.summary = summary(pc.res), pc.scores = pcdata, 
        pc.shapes = shapes, sdev = pc.res$sdev, rotation = pc.res$rotation)
    class(out) = "plotTangentSpace"
    out
}

#### Code from Motani & Schmitz (2011) - Phylogenetic Flexible Discriminant Analyses ####

require(nnet)
require(mda)
require(ape)
require(geiger)
require(lattice)
###----------------------------------------------------------------------
### Internal function from the package mda
###----------------------------------------------------------------------
"contr.fda" <-
function (p = rep(1, d[1]), contrast.default = contr.helmert(length(p)))
{
d <- dim(contrast.default)
sqp <- sqrt(p/sum(p))
x <- cbind(1, contrast.default) * outer(sqp, rep(1, d[2] +
1))
qx <- qr(x)
J <- qx$rank
qr.qy(qx, diag(d[1])[, seq(2, J)])/outer(sqp, rep(1, J -
1))
}

###----------------------------------------------------------------------
### Associated functions modified from the package mda
###----------------------------------------------------------------------

"predict.phylo.fda" <-
function (object, newdata, type = c("class", "variates", "posterior",
"hierarchical", "distances"), prior, dimension = J - 1, ...)
{
dist <- function(x, mean, m = ncol(mean)) (scale(x, mean,
FALSE)^2) %*% rep(1, m)
type <- match.arg(type)
means <- object$means
Jk <- dim(means)
J <- Jk[1]
k <- Jk[2]
if (type == "hierarchical") {
if (missing(dimension))
dimension.set <- seq(k)
else {
dimension.set <- dimension[dimension <= k]
if (!length(dimension.set))
dimension.set <- k
dimension <- max(dimension.set)
}
}
else dimension <- min(max(dimension), k)
if (missing(newdata))
y <- predict(object$fit)
else {
if (inherits(newdata, "data.frame") || is.list(newdata)) {
Terms <- delete.response(terms(object))
attr(Terms, "intercept") <- 0
newdata <- model.matrix(Terms, newdata)
}
y <- predict(object$fit, newdata)
}
y <- y %*% object$theta[, seq(dimension), drop = FALSE]
lambda <- object$values
alpha <- sqrt(lambda[seq(dimension)])
sqima <- sqrt(1 - lambda[seq(dimension)])
newdata <- scale(y, FALSE, sqima * alpha)
if (missing(prior))
prior <- object$prior
else {
if (any(prior < 0) | round(sum(prior), 5) != 1)
stop("innappropriate prior")
}
means <- means[, seq(dimension), drop = FALSE]
switch(type, variates = return(newdata), class = {
n <- nrow(newdata)
prior <- 2 * log(prior)
mindist <- dist(newdata, means[1, ], dimension) - prior[1]
pclass <- rep(1, n)
for (i in seq(2, J)) {
ndist <- dist(newdata, means[i, ], dimension) - prior[i]
l <- ndist < mindist
pclass[l] <- i
mindist[l] <- ndist[l]
}
## 2001-10-27: Need to provide levels or else if we get an error
## if the predicted classes do no contain all possible classes.
## Reported by Greg Jefferis <jefferis@stanford.edu>, fix by
## Bj/orn-Helge Mevik <bjorn-helge.mevik@matforsk.no>.
return(factor(pclass, levels = seq(J),
labels = dimnames(means)[[1]]))
}, posterior = {
pclass <- matrix(0, nrow(newdata), J)
for (i in seq(J)) pclass[, i] <- exp(-0.5 * dist(newdata, means[i,
], dimension)) * prior[i]
dimnames(pclass) <- list(dimnames(newdata)[[1]], dimnames(means)[[1]])
return(pclass/drop(pclass %*% rep(1, J)))
}, hierarchical = {
prior <- 2 * log(prior)
Pclass <- vector("list", length(dimension.set))
names(Pclass) <- paste("D", dimension.set, sep = "")
for (ad in seq(along = dimension.set)) {
d <- dimension.set[ad]
dd <- seq(d)
mindist <- dist(newdata[, dd, drop = FALSE], means[1, dd, drop = FALSE],
d) - prior[1]
pclass <- rep(1, nrow(newdata))
for (i in seq(2, J)) {
ndist <- dist(newdata[, dd, drop = FALSE], means[i, dd,
drop = FALSE], d) - prior[i]
l <- ndist < mindist
pclass[l] <- i
mindist[l] <- ndist[l]
}
levels(pclass) <- dimnames(means)[[1]]
Pclass[[ad]] <- pclass
}
rownames <- dimnames(newdata)[[1]]
if (is.null(rownames))
rownames <- paste(seq(nrow(newdata)))
return(structure(Pclass, class = "data.frame", row.names = rownames,
dimensions = dimension.set))
}, distances = {
dclass <- matrix(0, nrow(newdata), J)
for (i in seq(J)) dclass[, i] <- dist(newdata, means[i, ],
dimension)
dimnames(dclass) <- list(dimnames(newdata)[[1]], dimnames(means)[[1]])
return(dclass)
})
}

########

"predict.polyreg.modified" <-
function (object, newdata, ...)
{
if (missing(newdata)) {
z <- fitted(object)
if (is.null(z))
stop("need to supply newdata")
else return(z)
}
degree <- object$degree
monomial <- object$monomial
newdata %*% object$coef
}
"polyreg.modified" <-
function (x, y, w, degree = 1, monomial = FALSE, ...)
{
#x <- polybasis(x, degree, monomial)
y <- as.matrix(y) # just making sure ...
if (iswt <- !missing(w)) {
if (any(w <= 0))
stop("only positive weights")
w <- sqrt(w)
y <- y * w
x <- x * w
}
qrx <- qr(x)
coef <- as.matrix(qr.coef(qrx, y))
fitted <- qr.fitted(qrx, y)
if ((df <- qrx$rank) < ncol(x))
coef[qrx$pivot, ] <- coef
if (iswt)
fitted <- fitted/w
structure(list(fitted.values = fitted, coefficients = coef,
degree = degree, monomial = monomial, df = df), class = "polyreg.modified")
}
"print.phylo.fda" <-
function (x, ...)
{
if (!is.null(cl <- x$call)) {
cat("Call:\n")
dput(cl)
}
cat("\nDimension:", format(x$dimension), "\n")
cat("\nPercent Between-Group Variance Explained:\n")
print(round(x$percent, 2))
error <- x$confusion
df <- x$fit
if (!is.null(df))
df <- df$df
if (!is.null(df)) {
cat("\nDegrees of Freedom (per dimension):", format(sum(df)),
"\n")
}
if (!is.null(error)) {
n <- as.integer(sum(error))
error <- format(round(attr(error, "error"), 5))
cat("\nTraining Misclassification Error:", error, "( N =",
n, ")\n")
}
invisible(x)
}
#####

"plot.phylo.fda" <- function(pfdamodel,gfactor=pfdamodel$g,prdfactor=pfdamodel$prd)
{
pfdavar <- predict(pfdamodel, type="variate")
lim1x <- c(min(pfdavar[,1]),max(pfdavar[,1]))
lim1y <- c(min(pfdavar[,2]),max(pfdavar[,2]))
m1 <- 4;m2 <- 1
oldpar<-
par(no.readonly=FALSE);on.exit(par(oldpar));x11(height=8,width=14);par(mfrow=c(1,2),mar=c(m1,m1,m1,
m2),oma=c(m2,m2,m2,m2));
matplot(pfdavar[gfactor==levels(gfactor)[1],1], pfdavar[gfactor==levels(gfactor)[1],2],
xlab="pFDA1",ylab="pFDA2", xlim=lim1x, ylim=lim1y, pch=1, col=1, main="True
Classes",sub=paste("lambda = ",pfdamodel$val," intrcpt=",pfdamodel$intercept,"
eqprior=",pfdamodel$eqprior,sep=""))
for (i in 2:nlevels(gfactor)) matplot(pfdavar[gfactor==levels(gfactor)[i],1],
pfdavar[gfactor==levels(gfactor)[i],2], add=TRUE, pch=i, col=i)
legend(min(lim1x),max(lim1y),levels(gfactor), pch=1:nlevels(gfactor), col=1:nlevels(gfactor))
legend(min(lim1x),min(lim1y)+(max(lim1y)-min(lim1y))*0.1,paste("lambda = ",pfdamodel$val,"
intrcpt=",pfdamodel$intercept," eqprior=",pfdamodel$eqprior," ",sep=""))
addEllipseGrp(pfdavar[,1],pfdavar[,2],gfactor, pval=0.95, num=30)
matplot(pfdavar[prdfactor==levels(prdfactor)[1],1], pfdavar[prdfactor==levels(prdfactor)[1],2],
xlab="pFDA1",ylab="pFDA2", xlim=lim1x, ylim=lim1y, pch=1, col=1, main="Predicted
Classes",sub=paste("lambda = ",pfdamodel$val," intercept=",pfdamodel$intercept,"
eqprior=",pfdamodel$eqprior,sep=""))
for (i in 2:nlevels(prdfactor)) matplot(pfdavar[prdfactor==levels(prdfactor)[i],1],
pfdavar[prdfactor==levels(prdfactor)[i],2], add=TRUE, pch=i, col=i)
legend(min(lim1x),max(lim1y),levels(prdfactor), pch=1:nlevels(prdfactor), col=1:nlevels(prdfactor))
legend(min(lim1x),min(lim1y)+(max(lim1y)-min(lim1y))*0.1,paste(levels(prdfactor),"=",pfdamodel$prior,"
",sep=""))
legend(max(lim1x)-(max(lim1x)-min(lim1x))*0.2,max(lim1y),signif(attr(pfdamodel$confusion,"error"),4))
invisible()
}

###----------------------------------------------------------------------
### Main pFDA function with training data only
###----------------------------------------------------------------------

"phylo.fda" <-function (data,grp,tretre,val=1,treetrans=lambdaTree,
dimension = J - 1, eps = .Machine$double.eps,
keep.fitted = (n * dimension < 1000), method=polyreg.modified,intercept=TRUE,eqprior=FALSE,priin=1)
{
this.call <- match.call()
if(intercept) data <- cbind(Intercept=rep(1,nrow(data)),data)
data <- as.matrix(data)
tretre <- treetrans(tretre,val)
g <- as.factor(grp)
ng <- nlevels(g)
W <- vcv.phylo(tretre)
invW<-solve(W)
invW.eig <- eigen(invW)
N <- invW.eig$vectors %*% diag(sqrt(invW.eig$values)) %*% solve(invW.eig$vectors)
divnum <-det(N)^(1/nrow(N))
N <- N/divnum
DATA <- N%*%data #Rao (4,57); transforming the data to linear
n <- nrow(DATA)
y <- matrix(0,nrow(data),ng)
for (i in 1:nrow(data)){y[i,g[i]] <- 1}
Y <- N%*%y #Dummy matrix with phylo bias removed
x <- DATA
fg <- factor(g)
prior <- colSums(Y)/sum(colSums(Y))
if(eqprior) prior <- c(rep(1/ng,ng))
if(priin != 1) prior<-priin
cnames <- levels(fg)
g <- as.numeric(fg)
J <- length(cnames)
weights <- rep(1, n)
dp <- tapply(weights, g, sum)/n
theta <- contr.helmert(J)
theta <- contr.fda(dp, theta)
Theta <- Y%*%theta #fda p.7, above eq2
fit <- method(x, Theta, weights)
rss <- t(Theta-fit$fitted) %*% (Theta-fit$fitted)
ssm <- t(Theta) %*% fitted(fit)/n
ed <- svd(ssm, nu = 0)
thetan <- ed$v
lambda <- ed$d
lambda[lambda > 1 - eps] <- 1 - eps
discr.eigen <- lambda/(1 - lambda)
pe <- (100 * cumsum(discr.eigen))/sum(discr.eigen)
dimension <- min(dimension, sum(lambda > eps))
if (dimension == 0) {
warning("degenerate problem; no discrimination")
return(structure(list(dimension = 0, fit = fit, call = this.call),
class = "phylo.fda"))
}
thetan <- thetan[, seq(dimension), drop = FALSE]
pe <- pe[seq(dimension)]
alpha <- sqrt(lambda[seq(dimension)])
sqima <- sqrt(1 - lambda[seq(dimension)])
vnames <- paste("v", seq(dimension), sep = "")
means <- scale(theta %*% thetan, FALSE, sqima/alpha)
dimnames(means) <- list(cnames, vnames)
names(lambda) <- c(vnames, rep("", length(lambda) - dimension))
names(pe) <- vnames
frml <- "grp~"
nc <- ncol(data)
varnam <- colnames(data)
for(i in 1:(nc-1)) frml <- paste(frml,varnam[i],"+", sep="")
frml <- paste(frml,varnam[nc], sep="")
frml <- as.formula(frml)
dset <- as.data.frame(cbind(grp,DATA))
Terms <- as.call(fda(formula = frml, data = dset, weights = weights))
obj <- structure(list(percent.explained = pe, values = lambda,
means = means, theta.mod = thetan, dimension = dimension,
prior = prior, fit = fit, call = this.call, terms = Terms),
class = "phylo.fda")
obj$confusion <- confusion(predict(obj), fg)
obj$prd <- predict(obj)
obj$g <- as.factor(grp)
obj$val <- val
obj$rss <- sum(diag(rss))
obj$intercept <- intercept
obj$eqprior <- eqprior
if (!keep.fitted)
obj$fit$fitted.values <- NULL
obj
}

###----------------------------------------------------------------------
### Main pFDA function with training and test data
###----------------------------------------------------------------------

"phylo.fda.pred" <-function (dataA,grpA,taxtaxA,tretreA,testlistn,val=1,treetrans=lambdaTree,
method=polyreg.modified,sbcls=floor(table(grp)/4),
dimension = J - 1, eps = .Machine$double.eps, keep.fitted = (n * dimension <
1000),intercept=TRUE,eqprior=FALSE,priin=1)
{
## Preparing data
this.call <- match.call()
if(intercept) dataA <- cbind(Intercept=rep(1,nrow(dataA)),dataA)
dataA <- as.data.frame(dataA)
nA <- nrow(dataA)
testlist <- taxtaxA[testlistn]
traininglist <- taxtaxA[-testlistn]
rownames(dataA) <- taxtaxA
tretre <- drop.tip(tretreA,testlistn)
grp <- grpA[-testlistn]
grp <- grp[grp %in% names(table(grp))[table(grp) > 0], drop=TRUE]
g <- as.factor(grp)
ng <- nlevels(g)
grpA <- as.factor(grpA)
ntest <- length(testlist)
dataA <- as.matrix(dataA)
tretreA <- treetrans(tretreA,val)
W <- vcv.phylo(tretreA)
invW<-solve(W)
invW.eig <- eigen(invW)
N <- invW.eig$vectors %*% diag(sqrt(invW.eig$values)) %*% solve(invW.eig$vectors)
divnum <-det(N)^(1/nrow(N))
N <- N/divnum
invN <- solve(N)
y <- matrix(0,nA,nlevels(grpA))
for (i in 1:nA){y[i,grpA[i]] <- 1}
Y <- N%*%y #Dummy matrix with phylo bias removed
Y <- Y[-testlistn,1:ng]
DATAA <- N%*%as.matrix(dataA) #Rao (4,57); transforming the data to linear
DATA <- DATAA[-testlistn,]
DATAtest <- DATAA[testlistn,]
n<-nrow(DATA)
m<-nrow(DATAtest)
x <- DATA
fg <- factor(g)
prior <- colSums(Y)/sum(colSums(Y))
if(eqprior) prior <- c(rep(1/ng,ng))
#prior <- c(0.305, 0.237, 0.458) # Mammalian Prior
#prior <- c(0.288, 0.558, 0.154) # Avian Prior
if(priin != 1) prior<-priin
cnames <- levels(fg)
g <- as.numeric(fg)
J <- length(cnames)
weights <- rep(1, n)
dp <- tapply(weights, g, sum)/n
theta <- contr.helmert(J)
theta <- contr.fda(dp, theta)
Theta <- Y%*%theta #fda p.7, above eq2
fit <- method(x, Theta, weights)
rss <- t(Theta-fit$fitted) %*% (Theta-fit$fitted)
ssm <- t(Theta) %*% fitted(fit)/n
ed <- svd(ssm, nu = 0)
thetan <- ed$v
lambda <- ed$d
lambda[lambda > 1 - eps] <- 1 - eps
discr.eigen <- lambda/(1 - lambda)
pe <- (100 * cumsum(discr.eigen))/sum(discr.eigen)
dimension <- min(dimension, sum(lambda > eps))
if (dimension == 0) {
warning("degenerate problem; no discrimination")
return(structure(list(dimension = 0, fit = fit, call = this.call),
class = "fda"))
}
thetan <- thetan[, seq(dimension), drop = FALSE]
pe <- pe[seq(dimension)]
alpha <- sqrt(lambda[seq(dimension)])
sqima <- sqrt(1 - lambda[seq(dimension)])
vnames <- paste("v", seq(dimension), sep = "")
means <- scale(theta %*% thetan, FALSE, sqima/alpha)
dimnames(means) <- list(cnames, vnames)
names(lambda) <- c(vnames, rep("", length(lambda) - dimension))
names(pe) <- vnames
frml <- "grp~"
nc <- ncol(dataA)
varnam <- colnames(dataA)
for(i in 1:(nc-1)) frml <- paste(frml,varnam[i],"+", sep="")
frml <- paste(frml,varnam[nc], sep="")
frml <- as.formula(frml)
dset <- as.data.frame(cbind(grp,DATA))
Terms <- as.call(fda(formula = frml, data = dset, weights = weights))
obj <- structure(list(percent.explained = pe, values = lambda,
means = means, theta.mod = thetan, dimension = dimension,
prior = prior, fit = fit, call = this.call, terms = Terms),
class = "phylo.fda")
obj$confusion <- confusion(predict(obj), fg)
obj$prd <- predict(obj)
obj$x<-x
obj$g <- as.factor(grp)
obj$val <- val
obj$rss <- sum(diag(rss))
obj$intercept <- intercept
obj$eqprior <- eqprior
obj$DATAtest <- DATAtest
obj$DATA <- DATA
tpred <- predict(obj,DATAtest)
tpredn <- as.numeric(tpred)
tpred <- as.matrix(tpred)
rownames(tpred) <- testlist
obj$testprediction <- tpred
obj$testprediction_numeral <- tpredn
if (!keep.fitted)
obj$fit$fitted.values <- NULL
obj
}

###----------------------------------------------------------------------
### Function for optimal lambda value search
###----------------------------------------------------------------------

"phylo.RSS"<-function (datain,grp,tretre,val=1,treetrans=lambdaTree)
{
datainO <- as.matrix(datain)
datainI <- cbind(Intercept=rep(1,nrow(datainO)),datainO)
tretre <- treetrans(tretre,val)
n <- nrow(datain)
g <- as.factor(grp)
ng <- nlevels(g)
W <- vcv.phylo(tretre)
invW<-solve(W)
y <- matrix(0,n,ng) #Dummy matrix without phylo bias
for (i in 1:n){y[i,g[i]] <- 1}
invW.eig <- eigen(invW)
N <- invW.eig$vectors %*% diag(sqrt(invW.eig$values)) %*% solve(invW.eig$vectors)
Y <- N %*% y # Pretending that there is no phylogenetic bias in y; otherwise Y <- N%*%y
DATAI <- N%*%datainI
# BHAT <- solve(t(DATA)%*%DATA)%*%t(DATA)%*%Y
# YHAT <- DATA%*%BHAT
bhatI <- solve(t(datainI)%*%invW%*%datainI)%*%t(datainI)%*%invW%*%y #Rohlf (9) -- data biased still
#Rao (4,64)
yhatI <- datainI%*%bhatI #Rohlf (11)
RSSyI <- t(y-yhatI) %*% invW %*% (y-yhatI) #Martins and Hansen 1997 (9)
l0I<- lm(Y~DATAI-1)
  class(l0I) <- "lm"
# RSSY <- t(Y-YHAT) %*% (Y-YHAT)
list(RSS=sum(diag(RSSyI)),lLY=logLik(l0I),AICY=AIC(l0I),l0I=l0I)
}

#dataA=XA;grpA=gA;taxtaxA=taxaA;tretreA=treA;testlistn=testtaxan;val=0;treetrans=lambdaTree

"phylo.RSS.pred" <-function (dataA,grpA,taxtaxA,tretreA,testlistn,val=1,treetrans=lambdaTree)
{
dataA <- as.data.frame(dataA)
nA <- nrow(dataA)
testlist <- taxtaxA[testlistn]
traininglist <- taxtaxA[-testlistn]
rownames(dataA) <- taxtaxA
tretre <- drop.tip(tretreA,testlistn)
grp <- grpA[-testlistn]
grp <- grp[grp %in% names(table(grp))[table(grp) > 0], drop=TRUE]
g <- as.factor(grp)
ng <- nlevels(g)
grpA <- as.factor(grpA)
icptA <- rep(1,nA)
dataA <- cbind(icptA,dataA)
ntest <- length(testlist)
tretreA <- treetrans(tretreA,val)
W <- vcv.phylo(tretreA)
invW<-solve(W)
invW.eig <- eigen(invW)
N <- invW.eig$vectors %*% diag(sqrt(invW.eig$values)) %*% solve(invW.eig$vectors)
invN <- solve(N)
y <- matrix(0,nA,nlevels(grpA))
for (i in 1:nA){y[i,grpA[i]] <- 1}
Y <- N%*%y #Dummy matrix with phylo bias removed
Y <- Y[-testlistn,1:ng]
DATAA <- N%*%as.matrix(dataA) #Rao (4,57); transforming the data to linear
DATA <- DATAA[-testlistn,]
BHAT <- solve(t(DATA)%*%DATA)%*%t(DATA)%*%Y
YHAT <- DATA%*%BHAT
l0<- lm(Y~DATA-1)
  class(l0) <- "lm"
RSSY <- t(Y-YHAT) %*% (Y-YHAT)
list(RSS=sum(diag(RSSY)),lLY=logLik(l0),AICY=AIC(l0))
}

#measurements=X;grps=g;mytree=tre;idc=filename_stem

"optLambda" <- function(measurements,grps,mytree,idc="default",sstep=0.01,srange=c(0,1),fldr="./")
{
lambdalist <- seq(min(srange),max(srange),sstep)
segnum <- length(lambdalist)
rslt<-matrix(,segnum,3)
colnames(rslt) <- c("Lambda","RSS","logLik")
for(i in 1:segnum){
lambdaval <- lambdalist[i]
rss <- phylo.RSS(measurements,grps,mytree,val=lambdaval)
rslt[i,] <- c(lambdaval,rss$RSS,rss$lLY)
}
optlambda <- matrix(,1,2);colnames(optlambda)<- c("RSS","logLik")
optlambda[1,1]<-max(rslt[which(rslt[,2]==min(rslt[,2])),1])
optlambda[1,2]<-max(rslt[which(rslt[,3]==max(rslt[,3]),1)])
#x11();matplot(rslt[,1],rslt[,2],type="l",xlab=expression(lambda),ylab="RSS",main="RSS",lty=1,col=1)
#abline(v=optlambda[1,1],col=2,lty=2);mtext(paste("Optimal Lambda = ",optlambda[1,1],sep=""))
#x11();matplot(rslt[,1],rslt[,3],type="l",xlab=expression(lambda),ylab="log
#Likelihood",main="logLik",lty=1,col=1)
#abline(v=optlambda[1,2],col=2,lty=2);mtext(paste("Optimal Lambda = ",optlambda[1,2],sep=""))
#pdf(height=11,width=6,file=paste(fldr,idc,".optLambda.pdf",sep=''));layout(matrix(c(1,2),2,1))
#matplot(rslt[,1],rslt[,2],type="l",xlab=expression(lambda),ylab="RSS",main="RSS",lty=1,col=1)
#abline(v=optlambda[1,1],col=2,lty=2);mtext(paste("Optimal Lambda = ",optlambda[1,1],sep=""))
#matplot(rslt[,1],rslt[,3],type="l",xlab=expression(lambda),ylab="log
#Likelihood",main="logLik",lty=1,col=1)
#abline(v=optlambda[1,2],col=2,lty=2);mtext(paste("Optimal Lambda = ",optlambda[1,2],sep=""))
#dev.off()
list(optlambda=optlambda,rslt=rslt)
}

# optLambda(X,grps, mytree, "LSSoft2_1000",0.001,c(0,0.2))
# optLambda(X,grps, mytree, "SHF_1000",0.001,c(0,1))
#measurementsA=XA;grpsA=gA;mytreeA=treA;testn=testtaxan;idc=filename_stem

"optLambda.pred" <-
function(measurementsA,grpsA,taxaA,mytreeA,testn,idc="default",sstep=0.01,srange=c(0,1),fldr="./")
{
lambdalist <- seq(min(srange),max(srange),sstep)
segnum <- length(lambdalist)
rslt<-matrix(,segnum+1,3)
colnames(rslt) <- c("Lambda","RSS","logLik")
for(i in 1:segnum){
lambdaval <- lambdalist[i]
rss <- phylo.RSS.pred(measurementsA,grpsA,taxaA,mytreeA,testn,val=lambdaval)
rslt[i,] <- c(lambdaval,rss$RSS,rss$lLY)
}
optlambda <- matrix(,1,2);colnames(optlambda)<- c("RSS","logLik")
optlambda[1,1]<-max(rslt[which(rslt[,2][!is.na(rslt[,2])]==min(rslt[,2][!is.na(rslt[,2])])),1])
optlambda[1,2]<-max(rslt[which(rslt[,3][!is.na(rslt[,3])]==max(rslt[,3][!is.na(rslt[,3])]),1)])
#x11();matplot(rslt[,1],rslt[,2],type="l",xlab=expression(lambda),ylab="RSS",main="RSS",lty=1,col=1)
#abline(v=optlambda[1,1],col=2,lty=2);mtext(paste("Optimal Lambda = ",optlambda[1,1],sep=""))
#x11();matplot(rslt[,1],rslt[,3],type="l",xlab=expression(lambda),ylab="log
#Likelihood",main="logLik",lty=1,col=1)
#abline(v=optlambda[1,2],col=2,lty=2);mtext(paste("Optimal Lambda = ",optlambda[1,2],sep=""))
#pdf(height=11,width=6,file=paste(fldr,idc,".optLambda.pred.pdf",sep=''));layout(matrix(c(1,2),2,1))
#matplot(rslt[,1],rslt[,2],type="l",xlab=expression(lambda),ylab="RSS",main="RSS",lty=1,col=1)
#abline(v=optlambda[1,1],col=2,lty=2);mtext(paste("Optimal Lambda = ",optlambda[1,1],sep=""))
#matplot(rslt[,1],rslt[,3],type="l",xlab=expression(lambda),ylab="log
#Likelihood",main="logLik",lty=1,col=1)
#abline(v=optlambda[1,2],col=2,lty=2);mtext(paste("Optimal Lambda = ",optlambda[1,2],sep=""))
#dev.off()
list(optlambda=optlambda,rslt=rslt)
}

###----------------------------------------------------------------------
### Utility functions for plotting
###----------------------------------------------------------------------

addEllipseSer <- function(x, y, series=2, pval=0.95, num=30)
{
acc <- num
alpha <- 1-pval
vx <- var(x)
vy <- var(y)
vxy <- var(x, y)
lambda <- eigen(var(cbind(x, y)))$values
a <- sqrt(vxy^2/((lambda[2]-vx)^2+vxy^2))
b <- (lambda[2]-vx)*a/vxy
theta <- atan(a/b)
k <- sqrt(-2*log(alpha))
l1 <- sqrt(lambda[1])*k
l2 <- sqrt(lambda[2])*k
# x2 <- seq(-l1, l1, l1/acc)
pvec <- 0:num
x2right <- sin((pi*pvec)/(num*2))*l1
x2 <- c(-rev(x2right), x2right )
tmp <- 1-x2^2/l1^2
y2 <- l2*sqrt(ifelse(tmp < 0, 0, tmp))
x2 <- c(x2, rev(x2))
72
y2 <- c(y2, -rev(y2))
s0 <- sin(theta)
c0 <- cos(theta)
xx <- c0*x2+s0*y2+mean(x)
yy <- -s0*x2+c0*y2+mean(y)
#polygon(xx, yy, border=series)
matplot(xx,yy,xlim=range(x), ylim=range(y), type="l", add=TRUE, col=series, cex=1)
epp <- cbind(xx,yy)
return(epp)
}

####

addEllipseGrp <- function(x,y,grp, pval=0.95, num=30)
{
gnum <- nlevels(grp)
gnames <- levels(grp)
xrange <- cbind(min(x),max(x))
yrange <- cbind(min(y),max(y))
dset <- cbind(grp,x,y)
epnts <- 1:((num+1)*4)
for (i in 1:gnum)
{
dset1 <- dset[grp==gnames[i],]
if(is.vector(dset1)==TRUE){x1 <- dset1[2]; y1 <- dset1[3]} else{x1 <- dset1[,2]; y1 <- dset1[,3]}
epnts2 <- addEllipseSer(x1,y1,i,pval,num)
epnts <- cbind(epnts, epnts2)
}
}

#Old geomorph functions



gpagen_old = function(A, curves=NULL, surfaces=NULL, PrinAxes = TRUE, 
                      max.iter = NULL, ProcD=FALSE, Proj = TRUE,
                      print.progress = TRUE){
  
  if(inherits(A, "geomorphShapes")) {
    Y <- A$landmarks
    if(any(unlist(lapply(Y, is.na)))) stop("Data matrix contains missing values. Estimate these first (see 'estimate.missing').")
    curves <- A$curves
    n <- A$n
    p <- A$p
    k <- A$k
    
    spec.names <- names(Y)
    p.names <- dimnames(Y[[1]])[[1]]
    k.names <- c("X", "Y", "Z")[1:k] 
    
  } else {
    
    if(!is.array(A)) stop("Coordinates must be a 3D array")
    if(length(dim(A)) != 3) stop("Coordinates array does not have proper dimensions")
    if(any(is.na(A))) stop("Data matrix contains missing values. Estimate these first (see 'estimate.missing').")
    n <- dim(A)[[3]]; p <- dim(A)[[1]]; k <- dim(A)[[2]]
    
    spec.names <- 1:n
    p.names <- 1:p
    k.names <- c("X", "Y", "Z")[1:k] 
    
    dim.names <- dimnames(A)
    if(length(dim.names) != 0) {
      dim.name.check <- sapply(1:length(dim.names), is.null)
      if(!dim.name.check[[1]]) spec.names <- dim.names[[1]]
      if(!dim.name.check[[2]]) spec.names <- dim.names[[2]]
      if(!dim.name.check[[3]]) spec.names <- dim.names[[3]]
    }
    
    Y <- lapply(1:n, function(j) A[,,j])
  }
  
  if(!is.logical(ProcD)) prD <- TRUE else prD <- ProcD
  if(is.null(max.iter)) max.it <- 5 else max.it <- as.numeric(max.iter)
  if(is.numeric(max.it) & max.it > 50) {
    warning("GPA might be halted ahead of maximum iterations, 
            as the number chosen is exceedingly large")
    max.it = 10
  }
  if(is.na(max.it)) max.it <- 5
  if(max.it < 0) max.it <- 5
  if(!is.null(curves)) {
    curves <- as.matrix(curves) 
    if(ncol(curves) != 3) stop("curves must be a matrix of three columns")
  } else curves <- NULL
  if(!is.null(surfaces)) surf <- as.vector(surfaces) else surf <- NULL
  if(print.progress == TRUE){
    if(!is.null(curves) || !is.null(surf)) gpa <- pGpa.wSliders_old(Y, curves = curves, surf=surf,
                                                                    PrinAxes = PrinAxes, max.iter=max.it, 
                                                                    ProcD=prD) else
                                                                      gpa <- pGpa(Y, PrinAxes = PrinAxes, max.iter=max.it)
  } else {
    if(!is.null(curves) || !is.null(surf)) gpa <- .pGpa.wSliders_old(Y, curves = curves, surf=surf,
                                                                     PrinAxes = PrinAxes, max.iter=max.it, 
                                                                     ProcD=prD) else
                                                                       gpa <- .pGpa(Y, PrinAxes = PrinAxes, max.iter=max.it)
  }
  
  coords <- gpa$coords
  M <- gpa$consensus
  dimnames(M) <- list(p.names, k.names)
  
  if (Proj == TRUE) {
    coords <- orp(coords)
    M <- Reduce("+",coords)/n
    dimnames(M) <- list(p.names, k.names)
  }
  Csize <- gpa$CS
  names(Csize) <- spec.names
  iter <- gpa$iter
  pt.var <- Reduce("+",Map(function(y) y^2/n, coords))
  coords <- simplify2array(coords)
  dimnames(coords) <- list(p.names, k.names, spec.names)
  two.d.coords = two.d.array(coords)
  rownames(two.d.coords) <- spec.names
  pt.VCV <- var(two.d.coords)
  rownames(pt.var) <- p.names
  colnames(pt.var) <- c("Var.X", "Var.Y", "Var.Z")[1:k]
  
  if(is.null(colnames(M))) colnames(M) <- c("X", "Y", "Z")[1:k] 
  
  procD <- try(dist(two.d.coords), silent = TRUE)
  if(inherits(procD, "try-error")) procD <- NULL
  if(!is.null(curves) || !is.null(surf)) {
    nsliders <- nrow(curves)
    nsurf <- length(surf)
    if(ProcD == TRUE) smeth <- "ProcD" else smeth <- "BE"
  } else {
    nsliders <- 0
    nsurf <- 0
    smeth <- NULL
  }
  if(is.null(nsliders)) nsliders <- 0; if(is.null(nsurf)) nsurf <- 0
  
  out <- list(coords=coords, Csize=Csize, 
              iter=iter, 
              points.VCV = pt.VCV, points.var = pt.var, 
              consensus = M, procD = procD, 
              p=p,k=k, nsliders=nsliders, nsurf = nsurf,
              data = data.frame(coords = two.d.coords, Csize = Csize),
              Q = gpa$Q, slide.method = smeth, call= match.call())
  class(out) <- "gpagen"
  out
}


####

# pGPA.wSliders
# GPA with partial Procrustes superimposition, incorporating semilandmarks
# used in gpagen
pGpa.wSliders_old <- function(Y, curves, surf, ProcD = TRUE, PrinAxes = FALSE, Proj = FALSE, max.iter = 5){
  n <- length(Y); p <- nrow(Y[[1]]); k <- ncol(Y[[1]])
  Yc <- Map(function(y) center.scale_old(y), Y)
  CS <- sapply(Yc,"[[","CS")
  Ya <- lapply(Yc,"[[","coords")
  Ya <- apply.pPsup_old(Ya[[1]], Ya)
  M <- Reduce("+", Ya)/n
  if(ProcD == FALSE) gpa.slide <- BE.slide(curves, surf, Ya, ref=M, max.iter=max.iter) else
    gpa.slide <- procD.slide(curves, surf, Ya, ref=M, max.iter=max.iter)
  Ya <- gpa.slide$coords
  M <- gpa.slide$consensus
  iter <- gpa.slide$iter
  Q <- gpa.slide$Q
  if (PrinAxes == TRUE) {
    ref <- M
    rot <- prcomp(ref)$rotation
    for (i in 1:k) if (sign(rot[i, i]) != 1)
      rot[1:k, i] = -rot[1:k, i]
    Ya <- Map(function(y) y%*%rot, Ya)
    M <- center.scale_old(Reduce("+", Ya)/n)$coords
  }
  list(coords= Ya, CS=CS, iter=iter, consensus=M, Q=Q, nsliders=NULL)
}

# .pGPA.wSliders
# same as pGPA.wSliders, without option for progress bar
# used in gpagen
.pGpa.wSliders_old <- function(Y, curves, surf, ProcD = TRUE, PrinAxes = FALSE, Proj = FALSE, max.iter = 5){
  n <- length(Y); p <- nrow(Y[[1]]); k <- ncol(Y[[1]])
  Yc <- Map(function(y) center.scale_old(y), Y)
  CS <- sapply(Yc,"[[","CS")
  Ya <- lapply(Yc,"[[","coords")
  Ya <- apply.pPsup_old(Ya[[1]], Ya)
  M <- Reduce("+", Ya)/n
  if(ProcD == FALSE) gpa.slide <- .BE.slide(curves, surf, Ya, ref=M, max.iter=max.iter) else
    gpa.slide <- .procD.slide(curves, surf, Ya, ref=M, max.iter=max.iter)
  Ya <- gpa.slide$coords
  M <- gpa.slide$consensus
  iter <- gpa.slide$iter
  Q <- gpa.slide$Q
  if (PrinAxes == TRUE) {
    ref <- M
    rot <- prcomp(ref)$rotation
    for (i in 1:k) if (sign(rot[i, i]) != 1)
      rot[1:k, i] = -rot[1:k, i]
    Ya <- Map(function(y) y%*%rot, Ya)
    M <- center.scale_old(Reduce("+", Ya)/n)$coords
  }
  list(coords= Ya, CS=CS, iter=iter, consensus=M, Q=Q, nsliders=NULL)
}


# center.scale
# center and divide matrices by centroid size; faster than scale()
# used in other functions for gpagen
center.scale_old <- function(x) {
  x <- center_old(x)
  cs <- sqrt(sum(x^2))
  y <- x/cs
  list(coords=y, CS=cs)
}

###
center_old <- function(x){
  if(is.vector(x)) x - mean(x) else {
    x <- as.matrix(x)
    dims <- dim(x)
    fast.center_old(x, dims[1], dims[2])
  }
}


####
fast.center_old <- function(x, n, p){
  m <- colMeans(x)
  x - rep.int(m, rep_len(n, p))
}


# apply.pPsup
# applies a partial Procrustes superimposition to matrices in a list
# used in gpagen functions
apply.pPsup_old<-function(M, Ya) {	# M = mean (reference); Ya all Y targets
  dims <- dim(Ya[[1]])
  k <- dims[2]; p <- dims[1]; n <- length(Ya)
  M <- cs.scale(M)
  lapply(1:n, function(j){
    y <- Ya[[j]]
    MY <- crossprod(M,y)
    sv <- La.svd(MY,k,k)
    u <- sv$u; u[,k] <- u[,k]*determinant(MY)$sign
    tcrossprod(y,u%*%sv$vt)
  })
}


### Functions that both RRPP and geomorph use, but should remain internal
### any alterations to these functions must be saved for both RRPP and geomorph


# center
# centers a matrix faster than scale()
# used in various functions where mean-centering is required
center <- function(x){
  if(is.vector(x)) x - mean(x) else {
    x <- as.matrix(x)
    dims <- dim(x)
    fast.center(x, dims[1], dims[2])
  }
}

fast.center <- function(x, n, p){
  m <- colMeans(x)
  x - rep.int(m, rep_len(n, p))
}

fast.scale <- function(x, n, p){
  if(p > 1) {
    x <- fast.center(x, n, p)
    scale <- apply(x, 2, sd)
    x / rep.int(scale, rep_len(n, p))
  } else {
    x <- x - mean(x)
    x/sd(x)
  }
}

# csize
# calculates centroid size
# digitsurface
csize <- function(x) sqrt(sum(center(as.matrix(x))^2))

# cs.scale
# divide matrices by centroid size
# used in other functions for gpagen
cs.scale <- function(x) x/csize(x)

# center.scale
# center and divide matrices by centroid size; faster than scale()
# used in other functions for gpagen
center.scale <- function(x) {
  x <- center(x)
  cs <- sqrt(sum(x^2))
  y <- x/cs
  list(coords=y, CS=cs)
}

# apply.pPsup
# applies a partial Procrustes superimposition to matrices in a list
# used in gpagen functions
apply.pPsup<-function(M, Ya) {	# M = mean (reference); Ya all Y targets
  dims <- dim(Ya[[1]])
  k <- dims[2]; p <- dims[1]; n <- length(Ya)
  M <- cs.scale(M)
  lapply(1:n, function(j){
    y <- Ya[[j]]
    MY <- crossprod(M,y)
    sv <- La.svd(MY,k,k)
    u <- sv$u; u[,k] <- u[,k]*determinant(MY)$sign
    tcrossprod(y,u%*%sv$vt)
  })
}

# fast.ginv
# same as ginv, but without traps (faster)
# used in any function requiring a generalized inverse
fast.ginv <- function(X, tol = sqrt(.Machine$double.eps)){
  X <- as.matrix(X)
  k <- ncol(X)
  Xsvd <- La.svd(X, k, k)
  Positive <- Xsvd$d > max(tol * Xsvd$d[1L], 0)
  rtu <-((1/Xsvd$d[Positive]) * t(Xsvd$u[, Positive, drop = FALSE]))
  v <-t(Xsvd$vt)[, Positive, drop = FALSE]
  v%*%rtu
}

# fast.solve
# same as solve, but without traps (faster)
# used in any function requiring a generalized inverse
fast.solve <- function(x) { 
  x <- as.matrix(x)
  if(det(x) > 1e-8) {
    res <- try(chol2inv(chol(x)), silent = TRUE)
    if(inherits(res, "try-error")) res <- fast.ginv(x)
  } else res <- fast.ginv(x)
  return(res)
}

# pcoa
# acquires principal coordinates from distance matrices
# used in all linear model functions with data input
pcoa <- function(D){
  options(warn=-1)
  if(!inherits(D, "dist")) stop("function only works with distance matrices")
  cmd <- cmdscale(D, k=attr(D, "Size") -1, eig=TRUE)
  options(warn=0)
  d <- cmd$eig
  min.d <- min(d)
  if(min.d < 0) {
    options(warn=-1)
    cmd.c <- cmdscale(D, k=attr(D, "Size") -1, eig=TRUE, add= TRUE)
    options(warn=0)
    d <- cmd.c$eig
  } else cmd.c <- cmd
  p <- length(cmd.c$eig[zapsmall(d) > 0])
  Yp <- cmd.c$points[,1:p]
  Yp
}

# perm.index
# creates a permutation index for resampling
# used in all functions with a resampling procedure

perm.index <-function(n, iter, seed=NULL){
  if(is.null(seed)) seed = iter else
    if(seed == "random") seed = sample(1:iter,1) else
      if(!is.numeric(seed)) seed = iter
      set.seed(seed)
      ind <- c(list(1:n),(Map(function(x) sample.int(n,n), 1:iter)))
      rm(.Random.seed, envir=globalenv())
      attr(ind, "seed") <- seed
      ind
}


# boot.index
# creates a bootstrap index for resampling
# used in lm.rrpp for intercept models
boot.index <-function(n, iter, seed=NULL){
  if(is.null(seed)) seed = iter else
    if(seed == "random") seed = sample(1:iter,1) else
      if(!is.numeric(seed)) seed = iter
      set.seed(seed)
      ind <- c(list(1:n),(Map(function(x) sample.int(n, n, replace = TRUE), 1:iter)))
      rm(.Random.seed, envir=globalenv())
      attr(ind, "seed") <- seed
      ind
}

# fastFit
# calculates fitted values for a linear model, after decomoposition of X to get U
# used in SS.iter
fastFit <- function(U,y,n,p){
  if(!is.matrix(y)) y <- as.matrix(y)
  if(p > n) tcrossprod(U)%*%y else
    U%*%crossprod(U,y)
}

# fastLM
# calculates fitted values and residuals, after fastFit
# placeholder in case needed later
fastLM<- function(U,y){
  p <- dim(y)[2]; n <- dim(y)[1]
  yh <- fastFit(U,y,n,p)
  list(fitted = yh, residuals = y-yh)
}

# pval
# P-values form random outcomes
# any analytical function
pval = function(s){# s = sampling distribution
  p = length(s)
  r = rank(s)[1]-1
  pv = 1-r/p
  pv
}

# effect.size
# Effect sizes (standard deviates) form random outcomes
# any analytical function
effect.size <- function(x, center = TRUE) {
  z = scale(x, center=center)
  n <- length(z)
  z[1]*sqrt((n-1)/(n))
}


# Pval.matrix
# P-values form random outcomes that comprise matrices
# any analytical function with results in matrices
Pval.matrix = function(M){
  P = matrix(0,dim(M)[1],dim(M)[2])
  for(i in 1:dim(M)[1]){
    for(j in 1:dim(M)[2]){
      y = M[i,j,]
      p = pval(y)
      P[i,j]=p
    }
  }
  if(dim(M)[1] > 1 && dim(M)[2] >1) diag(P)=1
  rownames(P) = dimnames(M)[[1]]
  colnames(P) = dimnames(M)[[2]]
  P
}

# Effect.size.matrix
# Effect sizes form random outcomes that comprise matrices
# any analytical function with results in matrices
Effect.size.matrix <- function(M, center=TRUE){
  Z = matrix(0,dim(M)[1],dim(M)[2])
  for(i in 1:dim(M)[1]){
    for(j in 1:dim(M)[2]){
      y = M[i,j,]
      z = effect.size(y, center=center)
      Z[i,j]=z
    }
  }
  if(dim(M)[1] > 1 && dim(M)[2] >1) diag(Z)=0
  rownames(Z) = dimnames(M)[[1]]
  colnames(Z) = dimnames(M)[[2]]
  Z
}


# Cov.proj
# generates projection matrix from covariance matrix
# used in lm.rrpp

Cov.proj <- function(Cov, id = NULL){
  Cov <- if(is.null(id)) Cov else Cov[id, id]
  sym <- isSymmetric(Cov)
  eigC <- eigen(Cov, symmetric = sym)
  lambda <- zapsmall(abs(Re(eigC$values)))
  if(any(lambda == 0)){
    cat("\nWarning: singular covariance matrix. Proceed with caution\n")
  }
  
  eigC.vect = t(eigC$vectors)
  L <- eigC.vect *sqrt(abs(eigC$values))
  P <- fast.solve(crossprod(L, eigC.vect))
  dimnames(P) <- dimnames(Cov)
  P
}



###

# BE.slide
# performs sliding iterations using bending energy
# used in pGpa.wSliders
BE.slide <- function(curves, surf, Ya, ref, max.iter=5){# see pGpa.wCurves for variable meaning
  n <- length(Ya); p <- nrow(Ya[[1]]); k <- ncol(Ya[[1]])
  iter <- 1 # from initial rotation of Ya
  pb <- txtProgressBar(min = 0, max = max.iter, initial = 0, style=3)
  slid0 <- Ya
  Q <- ss0 <- sum(Reduce("+",Ya)^2)/n
  setTxtProgressBar(pb,iter)
  while(Q > 0.0001){
    iter <- iter+1
    if(!is.null(curves)) tans <- Map(function(y) tangents(curves, y, scaled=TRUE), slid0)
    L <- Ltemplate(ref)
    if(is.null(surf) & !is.null(curves))
      slid <- Map(function(tn,y) semilandmarks.slide.tangents.BE(y, tn, ref, L), tans, slid0)
    if(!is.null(surf) & is.null(curves))
      slid <- Map(function(y) semilandmarks.slide.surf.BE(y, surf, ref, L), slid0)
    if(!is.null(surf) & !is.null(curves))
      slid <- Map(function(tn,y) semilandmarks.slide.tangents.surf.BE(y, tn, surf, ref, L), tans, slid0)
    ss <- sum(Reduce("+",slid)^2)/n
    slid0 <- apply.pPsup(ref,slid)
    ref = cs.scale(Reduce("+", slid0)/n)
    Q <- abs(ss0-ss)
    ss0 <- ss
    setTxtProgressBar(pb,iter)
    if(iter >= max.iter) break
  }
  if(iter < max.iter) setTxtProgressBar(pb,max.iter)
  close(pb)
  list(coords=slid0, consensus=ref, iter=iter+1, Q=Q)
}

# .BE.slide
# same as BE.slide, but without progress bar option
# used in pGpa.wSliders
.BE.slide <- function(curves, surf, Ya, ref, max.iter=5){# see pGpa.wCurves for variable meaning
  n <- length(Ya); p <- nrow(Ya[[1]]); k <- ncol(Ya[[1]])
  iter <- 1 # from initial rotation of Ya
  slid0 <- Ya
  Q <- ss0 <- sum(Reduce("+",Ya)^2)/n
  while(Q > 0.0001){
    iter <- iter+1
    if(!is.null(curves)) tans <- Map(function(y) tangents(curves, y, scaled=TRUE), slid0)
    L <- Ltemplate(ref)
    if(is.null(surf) & !is.null(curves))
      slid <- Map(function(tn,y) semilandmarks.slide.tangents.BE(y, tn, ref, L), tans, slid0)
    if(!is.null(surf) & is.null(curves))
      slid <- Map(function(y) semilandmarks.slide.surf.BE(y, surf, ref, L), slid0)
    if(!is.null(surf) & !is.null(curves))
      slid <- Map(function(tn,y) semilandmarks.slide.tangents.surf.BE(y, tn, surf, ref, L), tans, slid0)
    ss <- sum(Reduce("+",slid)^2)/n
    slid0 <- apply.pPsup(ref,slid)
    ref = cs.scale(Reduce("+", slid0)/n)
    Q <- abs(ss0-ss)
    ss0 <- ss
    if(iter >= max.iter) break
  }
  list(coords=slid0, consensus=ref, iter=iter+1, Q=Q)
}

# procD.slide
# performs sliding iterations using minimized ProcD
# used in pGpa.wSliders
procD.slide <- function(curves, surf, Ya, ref, max.iter=5){# see pGpa.wCurves for variable meaning
  n <- length(Ya); p <- nrow(Ya[[1]]); k <- ncol(Ya[[1]])
  iter <- 1 # from initial rotation of Ya
  pb <- txtProgressBar(min = 0, max = max.iter, initial = 0, style=3)
  slid0 <- Ya
  Q <- ss0 <- sum(Reduce("+",Ya)^2)/n
  setTxtProgressBar(pb,iter)
  while(Q > 0.0001){
    iter <- iter+1
    if(!is.null(curves)) tans <- Map(function(y) tangents(curves, y, scaled=TRUE), slid0)
    if(is.null(surf) & !is.null(curves))
      slid <- Map(function(tn,y) semilandmarks.slide.tangents.procD(y, tn, ref), tans, slid0)
    if(!is.null(surf) & is.null(curves))
      slid <- Map(function(y) semilandmarks.slide.surf.procD(y, surf, ref), slid0)
    if(!is.null(surf) & !is.null(curves))
      slid <- Map(function(tn,y) semilandmarks.slide.tangents.surf.procD(y, tn, surf, ref), tans, slid0)
    ss <- sum(Reduce("+",slid)^2)/n
    slid0 <- apply.pPsup(ref,slid)
    ref = cs.scale(Reduce("+", slid0)/n)
    Q <- abs(ss0-ss)
    ss0 <- ss
    setTxtProgressBar(pb,iter)
    if(iter >=max.iter) break
  }
  if(iter < max.iter) setTxtProgressBar(pb,max.iter)
  close(pb)
  list(coords=slid0, consensus=ref, iter=iter+1, Q=Q)
}

# .procD.slide
# same as procD.slide, but without progress bar option
# used in pGpa.wSliders
.procD.slide <- function(curves, surf, Ya, ref, max.iter=5){# see pGpa.wCurves for variable meaning
  n <- length(Ya); p <- nrow(Ya[[1]]); k <- ncol(Ya[[1]])
  iter <- 1 # from initial rotation of Ya
  slid0 <- Ya
  Q <- ss0 <- sum(Reduce("+",Ya)^2)/n
  while(Q > 0.0001){
    iter <- iter+1
    if(!is.null(curves)) tans <- Map(function(y) tangents(curves, y, scaled=TRUE), slid0)
    if(is.null(surf) & !is.null(curves))
      slid <- Map(function(tn,y) semilandmarks.slide.tangents.procD(y, tn, ref), tans, slid0)
    if(!is.null(surf) & is.null(curves))
      slid <- Map(function(y) semilandmarks.slide.surf.procD(y, surf, ref), slid0)
    if(!is.null(surf) & !is.null(curves))
      slid <- Map(function(tn,y) semilandmarks.slide.tangents.surf.procD(y, tn, surf, ref), tans, slid0)
    ss <- sum(Reduce("+",slid)^2)/n
    slid0 <- apply.pPsup(ref,slid)
    ref = cs.scale(Reduce("+", slid0)/n)
    Q <- abs(ss0-ss)
    ss0 <- ss
    if(iter >=max.iter) break
  }
  list(coords=slid0, consensus=ref, iter=iter+1, Q=Q)
}

tangents = function(s,x, scaled=FALSE){ # s = curves, x = landmarks
  ts <- x[s[,3],] - x[s[,1],]
  if(scaled==TRUE) {
    ts.scale = sqrt(rowSums(ts^2))
    ts <- ts/ts.scale
  }
  y <- matrix(0, nrow(x), ncol(x))
  y[s[,2],] <- ts
  y
}


# Ltemplate
# calculates inverse of bending energy matrix
# used in any function that calculates bending energy
# used in BE.slide
Ltemplate <-function(Mr, Mt=NULL){
  p <-nrow(Mr); k <- ncol(Mr)
  if(!is.null(Mt)) P <- as.matrix(dist(Mr-Mt)) else P <- as.matrix(dist(Mr))
  if(k==2) {P <-P^2*log(P); P[is.na(P)] <- 0}
  Q <- cbind(1,Mr)
  L<-rbind(cbind(P,Q), cbind(t(Q),matrix(0,k+1,k+1)))
  Linv <- -fast.solve(L)[1:p,1:p]
  Linv
}

# semilandmarks.slide.tangents.surf.BE
# slides landmarks along tangents of curves and PC planes of surfaces using bending energy
# used in pGpa.wSliders
semilandmarks.slide.tangents.surf.BE <- function(y, tans, surf, ref, L){
  yc <- y - ref
  p <- nrow(yc); k <-ncol(yc)
  if(k==3) {tx <- tans[,1]; ty <- tans[,2]; tz <- tans[,3 ]} else {tx <- tans[,1]; ty <- tans[,2]}
  if(k==3) {
    int.part <- fast.solve(t(t(tx*L)*tx)+t(t(ty*L)*ty)+
                             t(t(tz*L)*tz))%*%cbind(tx*L,ty*L,tz*L)
    Ht <- rbind(tx*int.part, ty*int.part, tz*int.part)
  } else {
    int.part <- fast.solve(t(t(tx*L)*tx)+t(t(ty*L)*ty))%*%cbind(tx*L,ty*L)
    Ht <- rbind(tx*int.part, ty*int.part)
  }
  PC <- getSurfPCs(y, surf)
  p1x <- PC$p1x; p1y <- PC$p1y; p1z <- PC$p1z; p2x <- PC$p2x; p2y <- PC$p2y; p2z <- PC$p2z
  if(k==3) {
    int.part <- fast.solve(t(t(p1x*L)*p1x)+t(t(p1y*L)*p1y)+
                             t(t(p1z*L)*p1z))%*%cbind(p1x*L,p1y*L,p1z*L)
    Hp1 <- rbind(p1x*int.part, p1y*int.part, p1z*int.part)
  } else {
    int.part <- fast.solve(t(t(p1x*L)*p1x)+t(t(p1y*L)*p1y))%*%cbind(p1x*L,p1y*L)
    Hp1 <- rbind(p1x*int.part, p1y*int.part)
  }
  if(k==3) {
    int.part <- fast.solve(t(t(p2x*L)*p2x)+t(t(p2y*L)*p2y)+
                             t(t(p2z*L)*p2z))%*%cbind(p2x*L,p2y*L,p2z*L)
    Hp2 <- rbind(p2x*int.part, p2y*int.part, p2z*int.part)
  } else {
    int.part <- fast.solve(t(t(p2x*L)*p2x)+t(t(p2y*L)*p2y))%*%cbind(p2x*L,p2y*L)
    Hp2 <- rbind(p2x*int.part, p2y*int.part)
  }
  y  - matrix(Ht%*%as.vector(yc) + Hp1%*%as.vector(yc) + Hp2%*%as.vector(yc), p,k)
}



# getSurfPCs
# finds PC loadings for surface landmarks
# used in semilandmarks functions, within the larger gpagen framework
getSurfPCs <- function(y, surf){
  V <- La.svd(center(y), nu=0)$vt
  k <- ncol(y)
  kk <- round(0.05 * length(surf))
  kk <- max(c(k, kk))
  p <- nrow(y)
  pc.match <- 1:p; pc.match[-surf] = NA
  nearpts <- lapply(1:p, function(j) {
    nn <- pc.match[j]
    if(is.na(nn)) 0 else
      c(nearest(y, nn, k = kk+1), nn)})
  tmp.pts <- lapply(1:p, function(j) {
    k <- nearpts[[j]]
    if(sum(k) > 0) x <- center(y[k,]) else x <- NA
    x})
  pc.dir <- lapply(1:p, function(j) {
    x <- tmp.pts[[j]]
    if(is.matrix(x)) {
      pc <- La.svd(x, nu=0)$vt
      s=sign(diag(crossprod(V,pc)))
      pc*s
    } else 0
  })
  p1x <- sapply(1:p, function(j) {x <- pc.dir[[j]]; if(is.matrix(x)) x[1,1] else 0})
  p1y <- sapply(1:p, function(j) {x <- pc.dir[[j]]; if(is.matrix(x)) x[1,2] else 0})
  p2x <- sapply(1:p, function(j) {x <- pc.dir[[j]]; if(is.matrix(x)) x[2,1] else 0})
  p2y <- sapply(1:p, function(j) {x <- pc.dir[[j]]; if(is.matrix(x)) x[2,2] else 0})
  if(k==3) {
    p1z <- sapply(1:p, function(j) {x <- pc.dir[[j]]; if(is.matrix(x)) x[1,3] else 0})
    p2z <- sapply(1:p, function(j) {x <- pc.dir[[j]]; if(is.matrix(x)) x[2,3] else 0})
  } else
  {p1z <- NULL; p2z <- NULL}
  
  list(p1x=p1x,p1y=p1y, p2x=p2x, p2y=p2y, p1z=p1z, p2z=p2z)
}


# nearest
# finds nearest points on surfaces for sliding semilandmakrs
# used in all functions associated with pPga.wCurves
nearest <- function(X, m, k = 4) {
  a <- X[m,]
  b <- sapply(1:nrow(X), function (j) sum((a-X[j,])^2))
  match(sort(b)[2:(k + 1)], b)
}


orp<-function(A){
  if(is.array(A)) {
    dims <- dim(A)
    n <- dims[3]; k <- dims[2]; p <- dims[1]
    Y <- lapply(1:n, function(j) A[,,j])
  } else
    if(is.list(A)){
      Y <- A
      n <- length(A); dims <- dim(A[[1]]); k <- dims[2]; p <- dims[1]
    } else stop("Input must be either a list or array")
  
  Y1 <- as.vector(center.scale((Reduce("+", Y)/n))$coords)
  oo <- matrix(1,n)%*%Y1
  mat <- t(matrix(unlist(Y),k*p,n))
  Xp <- (mat%*%(diag(1,p*k) - (tcrossprod(Y1)))) +oo
  lapply(1:n, function(j) matrix(Xp[j,],p,k))
}


}


# LOAD 3D COORDINATES AND SLIDERS INFO; SET 3D ARRAY FOR DOWNSTREAM STEPS

#Load 3D coordinates from folder containing the data
dir.temp <- paste0(getwd(),'/Landmarks/')
land.temp <- paste0(dir.temp,list.files(dir.temp,pattern = '.txt'))
land.temp <- lapply ( land.temp , read.table)
land.rownames <- read.csv(paste0(dir.temp,'rownames.csv'), sep=';')[,2]

landmarks.full <- array(unlist(land.temp), c(dim(land.temp[[1]]), length(land.temp))) 
names.temp <- gsub('.txt','',list.files(dir.temp,pattern = '.txt'))
dimnames(landmarks.full)[[1]] <- land.rownames
dimnames(landmarks.full)[[2]] <- c('x','y','z')
dimnames(landmarks.full)[[3]] <- names.temp

landmarks.full

sliders.full <- read.csv(paste0(dir.temp,'sliders.csv'),sep = ' ')
sliders.full <- as.matrix(sliders.full)


# LOAD TREES and SPREADSHEET WITH ECOMORPHOLOGY INFORMATION

#SPREADSHEET WITH ECOMORPHOLOGY INFORMATION

turtle_data <- read.table('SupportingInformationS1.csv',header=T, row.names=1, sep=',')

#TREES
#Molecular-based tree of Pereira et al. (2017) pruned to 'full landmark dataset' taxa sample; used for procD.pgls analysis
extant_tree_full <- read.tree('Pereira_tree_pruned_full.tre')
#Time-scaled composite topology based on Evers et al. (2019); obtained from Farina et al. (2023); used for pFDA
Evers_tree <- read.tree('Supplementary_File_S9_tree.tre')

#Read Nichollsemys 3D coordinates

Nichollsemys <- read.table('Supplementary_File_S8_Nichollsemys_landmarks.txt',row.names = NULL)


#Add Nichollsemys to the original landmark dataset
landmarks_full_new <- abind::abind(landmarks.full,Nichollsemys[,2:4])

#Add Nichollsemys baieri to the 'Evers tree' object

node.tmp <- getMRCA(Evers_tree,c('Caretta_caretta','Dermochelys_coriacea'))
age.tmp <- paleotree::dateNodes(Evers_tree)[node.tmp]
Evers_tree <- bind.tip(Evers_tree,tip.label = 'Nichollsemys_baieri',
                             where=node.tmp,
                             position = 2, edge.length = age.tmp+2 - 70.6 )

#plot(Evers_tree,cex=0.7)

full_taxa <- rownames (turtle_data) [ turtle_data$full_dataset == 1 ] 
  full_taxa <- full_taxa[ !is.na(full_taxa)]

#Reduced dataset of landmarks (delete squamosal and temporal emargination landmarks)

to_drop <- unique ( c(grep('SQ',dimnames(landmarks_full_new)[[1]]),
                      grep('Temporal',dimnames(landmarks_full_new)[[1]])
  ))


#The following lines perform the analytical workflow for the complete set of landmarks

#Run GPA and PCA

#GPA
GPA.full <- gpagen_old(landmarks_full_new , curves = sliders.full , 
                   surfaces = as.matrix(399:nrow(landmarks_full_new)),  ProcD = F )

#get corrected centroid sizes and fix some names

GPA.full$Csize[ GPA.full$Csize > 3000 ] <- GPA.full$Csize[ GPA.full$Csize > 3000 ] / 1000

## change remaining
GPA.full$Csize["Chelonoidis_sp_SMF67582"] <- GPA.full$Csize["Chelonoidis_sp_SMF67582"] * 2 ##Chelonoidis sp
GPA.full$Csize["Cycloderma_frenatum_NHMUK84241"] <- GPA.full$Csize["Cycloderma_frenatum_NHMUK84241"] / 2 ##Cycloderma
GPA.full$Csize["Heosemys_grandis_unnumbered"] <- GPA.full$Csize["Heosemys_grandis_unnumbered"] * 100 ##Heosemys

size.full <- GPA.full$Csize/10
names( size.full ) <- unlist( lapply( lapply( strsplit( names( size.full ) , "_" ) , function(X){X[c(1,2)]} ) , paste , collapse = "_" ) )
names( size.full )[ names( size.full ) == "Chelonoidis_sp" ]  <- "Chelonoidis_nigra"
names( size.full )[ names( size.full ) == "Gopherus_agassizi" ] <- "Gopherus_agassizii"
names( size.full )[ names( size.full ) == "Deirochelys_reticularis" ] <- "Deirochelys_reticularia"
names( size.full )[ names( size.full ) == "Kinosternon_suburum" ] <- "Kinosternon_subrubrum"

#PCA
PCA.results.full <- gm.prcomp(GPA.full$coords)

#### ECOMORPHOLOGICAL ANALYSES ####

#create 'hardness index'

# temporary data frame containing only food items
turtle_data.temp_food <- turtle_data[full_taxa,-c(1:5,19:ncol(turtle_data))]

# define food hardness categories based on Vanhooydonck et al. 2007 (See main text)
food_hardness <- list('soft' = c('Flowers','Terrestrial_leaves','Aquatic_leaves','Fungi','Jellyfish','Worms'),
                      'interm' = c('Stems','Vertebrates','Aquatic_insects','Terrestrial_arthropods'),
                      'hard' = c('Seeds_fruits','Mollusks','Crustaceans'))

w_matrix <- cbind (turtle_data.temp_food[,food_hardness[['soft']]]*0,
                   turtle_data.temp_food[,food_hardness[['interm']]]*0.5,
                   turtle_data.temp_food[,food_hardness[['hard']]]*1)

hardness_index <- round(apply(w_matrix,1,sum) / apply(turtle_data.temp_food,1,sum),2)


#create 'evasiveness index'

# define food evasiveness categories based on Vanhooydonck et al. 2007 (See main text)
food_evasiveness <- list('sedentary' = c('Seeds_fruits','Flowers','Stems','Terrestrial_leaves','Aquatic_leaves','Fungi','Jellyfish','Worms'),
                         'interm' = c('Terrestrial_arthropods','Mollusks'),
                         'evasive' = c('Vertebrates','Aquatic_insects','Crustaceans'))

w_matrix <- cbind (turtle_data.temp_food[,food_evasiveness[['sedentary']]]*0,
                   turtle_data.temp_food[,food_evasiveness[['interm']]]*0.5,
                   turtle_data.temp_food[,food_evasiveness[['evasive']]]*1)
evasiveness_index <- round(apply(w_matrix,1,sum) / apply(turtle_data.temp_food,1,sum),2)

### D-PGLS models ###

# create geomorph data frame

gdf.full <- geomorph.data.frame(shape=GPA.full$coords[,,1:length(full_taxa)],
                                phy=extant_tree_full,
                                size=size.full[extant_tree_full$tip.label],
                                neck_retraction=turtle_data[extant_tree_full$tip.label,"Neck_retraction"] ,
                                aq_feeding=turtle_data[extant_tree_full$tip.label,"Feed_on_water"],
                                suction=turtle_data[extant_tree_full$tip.label,"Suction_feeding"],
                                duroph=turtle_data[extant_tree_full$tip.label,"Mostly_hard_food..durophagy."],
                                hardness=hardness_index[extant_tree_full$tip.label],
                                evasiveness=evasiveness_index[extant_tree_full$tip.label])

dimnames(gdf.full$shape)[[3]] <- sort(full_taxa)
gdf.full$shape <- gdf.full$shape[,,extant_tree_full$tip.label]

## Run D-PGLS (using the best model as described in Hermanson et al. 2022)

procD.fit.full <- procD.pgls(shape~size+neck_retraction+aq_feeding+suction+duroph+hardness+evasiveness,phy = phy,
                        SS.type = 'II',print.progress = T,data = gdf.full)
						

# Get regression scores
reg.full <- procD.scores ( procD.fit.full , plot = F )

#Predict regression scores for Nichollsemys
coefs <- rownames(coef(procD.fit.full))[-1]
f <- as.matrix ( procD.fit.full$LM$gls.fitted )

Y <- GPA.full$coords
Y <- two.d.array(Y)

reg.fossil <- matrix ( NA , nrow=nrow(Y) , ncol = length(coefs) , 
                dimnames = list(rownames(Y),coefs))

for ( i in 1:length(coefs)){
  
  xc <- as.numeric(procD.fit.full$data[  , coefs[i] ])
  X <- cbind ( xc , procD.fit.full$LM$Pcov %*% procD.fit.full$LM$X)  
  b <- as.matrix ( lm.fit ( X , f)$coefficients)[1,]
  
  reg.fossil[,i] <- geomorph:::center(Y) %*% b %*% solve(crossprod(b))
}


# Bind extant and fossil scores into a single data frame
# Add predictors from the best D-PGLS model to this same data frame

scores.all <- data.frame ( rbind ( reg.full , reg.fossil[72,] ) ,  
                           suct = c(procD.fit.full$data$suction , rep(NA,1)),
                           aq_feed = c(procD.fit.full$data$aq_feeding , rep(NA,1)),
                           durop = c(procD.fit.full$data$durophs , rep(NA,1)),
                           neck = c(procD.fit.full$data$neck_retraction , rep(NA,1)),
                           ev = c(procD.fit.full$data$evasiveness , rep(NA,1)),
                           type= c( rep ('extant',Ntip(extant_tree_full)) , rep('fossil',1)))
rownames(scores.all)[72] <- 'Nichollsemys_baieri'

scores.all$sizes <- log10(size.full)[rownames(scores.all)]


#Phylogenetic Flexible Discriminant Analysis

reps=1000
set.seed(123)

pFDA.list <- list()

fossils <- 'Nichollsemys_baieri'

for ( i in 1:reps){
  
  

  scores_data <- scores.all[scores.all$neck!='unknown',]
  scores_data$neck <- droplevels(as.factor(scores_data$neck))

  
  
  samples <-  list(
    '0'=t(replicate(reps,sample(x=which(scores_data$neck=='0'), size=min(table(scores_data$neck))-1))),
    '1'=t(replicate(reps,sample(x=which(scores_data$neck=='1'), size=min(table(scores_data$neck))-1)))
    
  )
  
  
  to_keep <- c( samples[['0']][i,] , samples[['1']][i,] 
                #, samples[['3']][i,] 
                #, samples[['4']][j,] 
  )
  
  tree.temp_fos <- keep.tip(Evers_tree, c(rownames(scores_data)[to_keep],fossils) )
  tree.temp_ext <- keep.tip(Evers_tree, rownames(scores_data)[to_keep] )
  
  X.temp <- scores.all[tree.temp_ext$tip.label,1:7] 
  g.temp <- setNames(as.factor(scores_data[tree.temp_ext$tip.label,'neck']),rownames(X.temp))
  g.temp <- droplevels(g.temp)
  
  XA.temp <- scores.all[tree.temp_fos$tip.label,1:7]  
  testtaxan.temp <- which(rownames(XA.temp) %in% fossils)
  taxaA.temp <- rownames(XA.temp)
  gA.temp <- setNames( scores.all[tree.temp_fos$tip.label,'neck'] , tree.temp_fos$tip.label)
  #gA.temp <- as.factor(setNames(rep('unknown',length(fossils)),fossils ))
  # gA.temp <- c(g.temp,gA.temp)[tree.temp_fos$tip.label]
  
  #lambda
  ol1.temp <- optLambda(X.temp,g.temp,tree.temp_ext)
  lambda.temp <- ol1.temp$optlambda[1,1]
  
  
  #pfda
  
  
  pFDA.list[[i]] <- phylo.fda.pred(XA.temp,gA.temp,taxaA.temp,
                                   tree.temp_fos,
                                   testtaxan.temp,
                                   val=lambda.temp,eqprior = T)
  
  
  setTxtProgressBar(txtProgressBar(0,reps,style = 3),i)
  
  
}


preds <- lapply(pFDA.list , function(x) predict(x,newdata=x$DATAtest,type='posterior') )

preds_median <- list()
for ( i in 1:length(fossils)){
  
  preds_median[[i]] <-  matrix( unlist(lapply(preds, function(x) x[i,] )),
                                ncol=2,byrow=T)
  #  preds_median[[i]] <- apply(preds_median[[i]],2,mean,na.rm=T)
  
}
names(preds_median) <- tree.temp_fos$tip.label[testtaxan.temp]

round(do.call(rbind,lapply(preds_median, function(x) apply(x,2,mean,na.rm=T))),4)


#The same analysis using the reduced version of the landmarking scheme (without squamosal and temporal emargination landmarks) can be found at the end of the script)


#The next lines are used for plotting the results

#Get neck retraction values for all species, including the prediction for Nichollsemys

neck_retr <- round(c(gdf.full$neck_retraction,mean(preds_median$Nichollsemys_baieri[,2])),3)
names(neck_retr) <- c(extant_tree_full$tip.label,'Nichollsemys_baieri')

Evers_tree_pruned <- keep.tip(Evers_tree,names(neck_retr))

int.nodes <- list(crown=getMRCA(Evers_tree_pruned,c('Chelonia_mydas','Caretta_caretta')),
                  pan=getMRCA(Evers_tree_pruned,c('Chelonia_mydas','Nichollsemys_baieri')),
                  chelon=getMRCA(Evers_tree_pruned,c('Chelonia_mydas','Dermochelys_coriacea'))
)

neck_anc <-   fastAnc(Evers_tree_pruned,neck_retr)
range01 <- function(x){(x-min(x))/(max(x)-min(x))} 


###PLOT

rownames(PCA.results.full$x) <- names(size.full)


pdf('Nichollsemys_neck_final.pdf',width = 5.5,height = 6.8,useDingbats = F)

layout(matrix(c(1,0,3,
                0,0,3,
                2,0,3),3,byrow = T),
       widths=c(0.6,0.05,0.4),heights = c(0.5,0.1,0.3))

phylomorphospace(Evers_tree_pruned,X=PCA.results.full$x[Evers_tree_pruned$tip.label,1:2],
                 label='off',node.size=c(NA,NA),lwd=0.5,colors=rgb(0.6,0.6,0.6,0.5)
)
points(PCA.results.full$x[Evers_tree_pruned$tip.label,1:2],
       pch=ifelse(Evers_tree_pruned$tip.label=='Nichollsemys_baieri',NA,21), 
       col = adjustcolor('gray80',alpha.f = 0.7),
       cex=ifelse(Evers_tree_pruned$tip.label=='Nichollsemys_baieri',2.5,2),
       bg = sapply( rgb(colorRamp(c('indianred3','lightsteelblue'))(range01(neck_retr[Evers_tree_pruned$tip.label]))/255),
                    make.transparent,0.75) )

tiplabels(tip=which(Evers_tree_pruned$tip.label=='Nichollsemys_baieri'),
          pie=apply(preds_median$Nichollsemys_baieri,2,mean),
          piecol =c('indianred3','lightsteelblue'),cex=1.2 )

legend('bottomleft',legend=c('absent','present'),title='Neck retraction',cex=0.9,
       pt.bg = c('indianred3','lightsteelblue'),pch=21,bty='n',pt.cex=2,col='grey70')


hist(preds_median$Nichollsemys_baieri[,2],xaxt='n',xlab='Neck retraction capacity\n (posterior probability)',main='',
     col= colorRampPalette(c('indianred3','lightsteelblue'))(5),
     breaks=7,
     #make.transparent('honeydew3',0.5),
     border='gray80',
     lwd=0.8)

axis(1,at=c(0,0.5,1),labels = c(NA,0.5,NA),tick = T)
axis(1,at=c(0,0.5,1),labels = c('0\n(absent)',NA,'1\n(present)'),tick = F,line = 1)
abline(v=mean(preds_median$Nichollsemys_baieri[,2]),lty=2,lwd=2,col='lightsteelblue4')

neck_rec <- contMap(Evers_tree_pruned,neck_retr,plot=F,lwd=2,outline=F)
plot(setMap(neck_rec,
            c('indianred3','lightsteelblue') ),outline=F,lwd=c(3,7),
     ftype='off')

nodelabels(node=Ntip(Evers_tree_pruned)+1:Nnode(Evers_tree_pruned),
           pch=16,
           col= rgb(colorRamp(c('indianred3','lightsteelblue'))(range01(neck_anc))/255) ,
           cex=2.5)  
nodelabels(node=as.numeric(unlist(int.nodes)),
           text = round( neck_anc[as.character(unlist(int.nodes))],3) ,
           frame='n',cex=0.8)
tiplabels(text='Nichollsemys_baieri',
          tip=which(Evers_tree_pruned$tip.label=='Nichollsemys_baieri'),frame='n',adj=-0.01,
          cex=0.8)

dev.off()


#Plots to show 3D shape deformation in PC axes


open3d()
par3d(windowRect = c(0,0,500,500))
Sys.sleep(1)
mfrow3d(nr = 2, nc = 2, byrow = TRUE, sharedMouse = TRUE)

plot3d( GPA.full$consensus , col = "grey80" , size = 4 , box = "n",aspect = 'iso')	
lines.plot.temp <- rbind( sliders.full[ , 1:2 ] , sliders.full[ , 2:3 ] )
for( j in 1:nrow( lines.plot.temp ) ) { lines3d( GPA.full$consensus[ lines.plot.temp[j,] , ] , 
                                                 lwd = 2 , col = 'grey80' ) }
plot3d( PCA.results.full$shapes$shapes.comp1$min , col = "black" , size = 5 , box = "n", add = T)
aspect3d( "iso" )
#title3d( main = choose, line=1 , cex = 1)
lines.plot.temp <- rbind( sliders.full[ , 1:2 ] , sliders.full[ , 2:3 ] )
for( j in 1:nrow( lines.plot.temp ) ) { lines3d( PCA.results.full$shapes$shapes.comp1$min [ lines.plot.temp[j,], ] , 
                                                 lwd = 2 , col = 'black' ) }

next3d()
plot3d( GPA.full$consensus , col = "grey80" , size = 4 , box = "n",aspect = 'iso')	
lines.plot.temp <- rbind( sliders.full[ , 1:2 ] , sliders.full[ , 2:3 ] )
for( j in 1:nrow( lines.plot.temp ) ) { lines3d( GPA.full$consensus[ lines.plot.temp[j,] , ] , 
                                                 lwd = 2 , col = 'grey80' ) }
plot3d( PCA.results.full$shapes$shapes.comp1$max , col = "black" , size = 5 , box = "n", add = T)
aspect3d( "iso" )
#title3d( main = choose, line=1 , cex = 1)
lines.plot.temp <- rbind( sliders.full[ , 1:2 ] , sliders.full[ , 2:3 ] )
for( j in 1:nrow( lines.plot.temp ) ) { lines3d( PCA.results.full$shapes$shapes.comp1$max [ lines.plot.temp[j,] , ] , 
                                                 lwd = 2 , col = 'black' ) }	

next3d()
plot3d( GPA.full$consensus , col = "grey80" , size = 4 , box = "n",aspect = 'iso')	
lines.plot.temp <- rbind( sliders.full[ , 1:2 ] , sliders.full[ , 2:3 ] )
for( j in 1:nrow( lines.plot.temp ) ) { lines3d( GPA.full$consensus[ lines.plot.temp[j,] , ] , 
                                                 lwd = 2 , col = 'grey80' ) }
plot3d( PCA.results.full$shapes$shapes.comp2$min , col = "black" , size = 5 , box = "n", add = T)
aspect3d( "iso" )
#title3d( main = choose, line=1 , cex = 1)
lines.plot.temp <- rbind( sliders.full[ , 1:2 ] , sliders.full[ , 2:3 ] )
for( j in 1:nrow( lines.plot.temp ) ) { lines3d( PCA.results.full$shapes$shapes.comp2$min [ lines.plot.temp[j,] , ] , 
                                                 lwd = 2 , col = 'black' ) }	

next3d()
plot3d( GPA.full$consensus , col = "grey80" , size = 4 , box = "n",aspect = 'iso')	
lines.plot.temp <- rbind( sliders.full[ , 1:2 ] , sliders.full[ , 2:3 ] )
for( j in 1:nrow( lines.plot.temp ) ) { lines3d( GPA.full$consensus[ lines.plot.temp[j,] , ] , 
                                                 lwd = 2 , col = 'grey80' ) }
plot3d( PCA.results.full$shapes$shapes.comp2$max , col = "black" , size = 5 , box = "n", add = T)
aspect3d( "iso" )
#title3d( main = choose, line=1 , cex = 1)
lines.plot.temp <- rbind( sliders.full[ , 1:2 ] , sliders.full[ , 2:3 ] )
for( j in 1:nrow( lines.plot.temp ) ) { lines3d( PCA.results.full$shapes$shapes.comp2$max [ lines.plot.temp[j,] , ] , 
                                                 lwd = 2 , col = 'black' ) }
												 
												 

#Reduced set of landmarks#

#Run analysis using the reduced version of the landmarking scheme (without squamosal and temporal emargination landmarks)

#PCA

GPA.partial_coords <- GPA.full$coords
GPA.partial_coords <- GPA.partial_coords[-to_drop,,]


PCA.results.partial <- gm.prcomp(GPA.partial_coords)
plot(PCA.results.partial$x,pch=16,col='grey80',cex=2)
text(PCA.results.partial$x,cex=0.45,lab=rownames(PCA.results.partial$x))

### D-PGLS models ###

# create geomorph data frame

gdf.partial <- geomorph.data.frame(shape=GPA.partial_coords[,,1:length(full_taxa)],
                                phy=extant_tree_full,
                                size=size.full[extant_tree_full$tip.label],
                                neck_retraction=turtle_data[extant_tree_full$tip.label,"Neck_retraction"] ,
                                aq_feeding=turtle_data[extant_tree_full$tip.label,"Feed_on_water"],
                                suction=turtle_data[extant_tree_full$tip.label,"Suction_feeding"],
                                duroph=turtle_data[extant_tree_full$tip.label,"Mostly_hard_food..durophagy."],
                                hardness=hardness_index[extant_tree_full$tip.label],
                                evasiveness=evasiveness_index[extant_tree_full$tip.label])

dimnames(gdf.partial$shape)[[3]] <- sort(full_taxa)
gdf.partial$shape <- gdf.partial$shape[,,extant_tree_full$tip.label]

## Run D-PGLS (using the best model as described in Hermanson et al. 2022)

procD.fit.partial <- procD.pgls(shape~size+neck_retraction+aq_feeding+suction+duroph+hardness+evasiveness,phy = phy,
                             SS.type = 'II',print.progress = T,data = gdf.partial)
							 
							 
# Get regression scores
reg.partial <- procD.scores ( procD.fit.partial , plot = F )

#Predict regression scores for Nichollsemys
coefs <- rownames(coef(procD.fit.partial))[-1]
f <- as.matrix ( procD.fit.partial$LM$gls.fitted )

Y <- GPA.partial_coords
Y <- two.d.array(Y)

reg.fossil <- matrix ( NA , nrow=nrow(Y) , ncol = length(coefs) , 
                       dimnames = list(rownames(Y),coefs))

for ( i in 1:length(coefs)){
  
  xc <- as.numeric(procD.fit.partial$data[  , coefs[i] ])
  X <- cbind ( xc , procD.fit.partial$LM$Pcov %*% procD.fit.partial$LM$X)  
  b <- as.matrix ( lm.fit ( X , f)$coefficients)[1,]
  
  reg.fossil[,i] <- geomorph:::center(Y) %*% b %*% solve(crossprod(b))
}


# Bind extant and fossil scores into a single data frame
# Add predictors from the best D-PGLS model to this same data frame

scores.partial <- data.frame ( rbind ( reg.partial , reg.fossil[72,] ) ,  
                           suct = c(procD.fit.partial$data$suction , rep(NA,1)),
                           aq_feed = c(procD.fit.partial$data$aq_feeding , rep(NA,1)),
                           durop = c(procD.fit.partial$data$durophs , rep(NA,1)),
                           neck = c(procD.fit.partial$data$neck_retraction , rep(NA,1)),
                           ev = c(procD.fit.partial$data$evasiveness , rep(NA,1)),
                           type= c( rep ('extant',Ntip(extant_tree_full)) , rep('fossil',1)))
rownames(scores.partial)[72] <- 'Nichollsemys_baieri'

scores.partial$sizes <- log10(size.full)[rownames(scores.partial)]



#PFDA partial

reps=1000
set.seed(123)

pFDA.list_partial <- list()

fossils <- 'Nichollsemys_baieri'

for ( i in 1:reps){
  
  
  
  scores_data <- scores.partial[scores.partial$neck!='unknown',]
  scores_data$neck <- droplevels(as.factor(scores_data$neck))
  
  
  
  samples <-  list(
    '0'=t(replicate(reps,sample(x=which(scores_data$neck=='0'), size=min(table(scores_data$neck))-1))),
    '1'=t(replicate(reps,sample(x=which(scores_data$neck=='1'), size=min(table(scores_data$neck))-1)))
    
  )
  
  
  to_keep <- c( samples[['0']][i,] , samples[['1']][i,] 
                #, samples[['3']][i,] 
                #, samples[['4']][j,] 
  )
  
  tree.temp_fos <- keep.tip(Evers_tree, c(rownames(scores_data)[to_keep],fossils) )
  tree.temp_ext <- keep.tip(Evers_tree, rownames(scores_data)[to_keep] )
  
  X.temp <- scores.partial[tree.temp_ext$tip.label,1:7] 
  g.temp <- setNames(as.factor(scores_data[tree.temp_ext$tip.label,'neck']),rownames(X.temp))
  g.temp <- droplevels(g.temp)
  
  XA.temp <- scores.partial[tree.temp_fos$tip.label,1:7]  
  testtaxan.temp <- which(rownames(XA.temp) %in% fossils)
  taxaA.temp <- rownames(XA.temp)
  gA.temp <- setNames( scores.partial[tree.temp_fos$tip.label,'neck'] , tree.temp_fos$tip.label)
  #gA.temp <- as.factor(setNames(rep('unknown',length(fossils)),fossils ))
  # gA.temp <- c(g.temp,gA.temp)[tree.temp_fos$tip.label]
  
  #lambda
  ol1.temp <- optLambda(X.temp,g.temp,tree.temp_ext)
  lambda.temp <- ol1.temp$optlambda[1,1]
  
  
  #pfda
  
  
  pFDA.list_partial[[i]] <- phylo.fda.pred(XA.temp,gA.temp,taxaA.temp,
                                   tree.temp_fos,
                                   testtaxan.temp,
                                   val=lambda.temp,eqprior = T)
  
  #pFDA.list[[i]] <- pfda.temp
  
  setTxtProgressBar(txtProgressBar(0,reps,style = 3),i)
  
  
}


preds <- lapply(pFDA.list_partial , function(x) predict(x,newdata=x$DATAtest,type='posterior') )

preds_median <- list()
for ( i in 1:length(fossils)){
  
  preds_median[[i]] <-  matrix( unlist(lapply(preds, function(x) x[i,] )),
                                ncol=2,byrow=T)
  #  preds_median[[i]] <- apply(preds_median[[i]],2,mean,na.rm=T)
  
}
names(preds_median) <- tree.temp_fos$tip.label[testtaxan.temp]

round(do.call(rbind,lapply(preds_median, function(x) apply(x,2,mean,na.rm=T))),4)