# Goal: Visualisation of 3-dimensional (x,y,z) data using contour
#       plots and using colour to represent the 3rd dimension.
#       The specific situation is: On a grid of (x,y) points, you have
#       evaluated f(x,y). Now you want a graphical representation of
#       the resulting list of (x,y,z) points that you have.

# Setup an interesting data matrix of (x,y,z) points:
points <- structure(c(0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.05, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.1, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.15, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.2, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.25, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.3, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.35, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.4, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.45, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.5, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.55, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.6, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.65, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.7, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.75, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.8, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.85, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.9, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 0.95, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 20, 30, 40, 50, 60, 70, 80, 90, 100, 110, 120, 130, 140, 150, 160, 170, 180, 190, 200, 1, 1, 1, 1, 1, 1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 1, 0.998, 0.124, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 1, 0.998, 0.71, 0.068, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 1, 0.998, 0.898, 0.396, 0.058, 0.002, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0.998, 0.97, 0.726, 0.268, 0.056, 0.006, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0.996, 0.88, 0.546, 0.208, 0.054, 0.012, 0.002, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.998, 0.964, 0.776, 0.418, 0.18, 0.054, 0.014, 0.002, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.998, 0.906, 0.664, 0.342, 0.166, 0.056, 0.018, 0.006, 0.002, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.986, 0.862, 0.568, 0.29, 0.15, 0.056, 0.022, 0.008, 0.002, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.954, 0.778, 0.494, 0.26, 0.148, 0.056, 0.024, 0.012, 0.004, 0.002, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.906, 0.712, 0.43, 0.242, 0.144, 0.058, 0.028, 0.012, 0.006, 0.002, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0.878, 0.642, 0.38, 0.222, 0.142, 0.066, 0.034, 0.014, 0.008, 0.004, 0.002, 0, 0, 0, 0, 0, 0, 0, 0, 0.846, 0.586, 0.348, 0.208, 0.136, 0.068, 0.034, 0.016, 0.012, 0.006, 0.004, 0.002, 0, 0, 0, 0, 0, 0, 0, 0.8, 0.538, 0.318, 0.204, 0.136, 0.07, 0.046, 0.024, 0.012, 0.008, 0.004, 0.002, 0.002, 0, 0, 0, 0, 0, 0, 0.762, 0.496, 0.294, 0.2, 0.138, 0.072, 0.05, 0.024, 0.014, 0.012, 0.006, 0.004, 0.002, 0.002, 0, 0, 0, 0, 0, 0.704, 0.472, 0.286, 0.198, 0.138, 0.074, 0.054, 0.028, 0.016, 0.012, 0.008, 0.006, 0.004, 0.002, 0.002, 0, 0, 0, 0, 0.668, 0.438, 0.276, 0.196, 0.138, 0.078, 0.054, 0.032, 0.024, 0.014, 0.012, 0.008, 0.004, 0.004, 0.002, 0.002, 0, 0, 0, 0.634, 0.412, 0.27, 0.194, 0.14, 0.086, 0.056, 0.032, 0.024, 0.016, 0.012, 0.01, 0.006, 0.004, 0.004, 0.002, 0.002, 0, 0, 0.604, 0.388, 0.26, 0.19, 0.144, 0.088, 0.058, 0.048, 0.026, 0.022, 0.014, 0.012, 0.008, 0.006, 0.004, 0.004, 0.002, 0.002, 0, 0.586, 0.376, 0.256, 0.19, 0.146, 0.094, 0.062, 0.052, 0.028, 0.024, 0.014, 0.012, 0.012, 0.008, 0.004, 0.004, 0.004, 0.002, 0.002, 0.566, 0.364, 0.254, 0.192, 0.148, 0.098, 0.064, 0.054, 0.032, 0.024, 0.022, 0.014, 0.012, 0.012, 0.008, 0.004, 0.004, 0.004, 0.002), .Dim = c(399, 3), .Dimnames = list(NULL, c("x", "y", "z")))

# Understand this object --
summary(points)
  # x is a grid from 0 to 1
  # y is a grid from 20 to 200
  # z is the interesting object which will be the 3rd dimension.

# Solution using contourplot() from package 'lattice'
library(lattice)
d3 <- data.frame(points)
contourplot(z ~ x+y, data=d3)
## or nicer
contourplot(z ~ x+y, data=d3, cuts=20, region = TRUE)
## or using logit - transformed z values:
contourplot(qlogis(z) ~ x+y, data=d3, pretty=TRUE, region = TRUE)

# An interesting alternative is levelplot()
levelplot(z ~ x+y, pretty=TRUE, contour=TRUE, data=d3)

# There is a contour() function in R. Even though it sounds obvious
# for the purpose, it is a bit hard to use.
# contour() wants 3 inputs: vectors of x and y values, and a matrix of
# z values, where the x values correspond to the rows of z, and the y
# values to the columns.  A collection of points like `points' above
# needs to be turned into such a grid. It might sound odd, but contour()
# image() and persp() have used this kind of input for the longest time.
#
# For irregular data, there's an interp function in the akima package
# that can convert from irregular data into the grid format.
#
# The `points' object that I have above - a list of (x,y,z) points -
# fits directly into the mentality of lattice::contourplot() but not
# into the requirements of contour()

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/g4.r


##rspt##

rm(list=ls())
memory.limit(size=50000000)
load("SNP.RData")
source("Meff_PCA.R")
source("inferCutoff.R")
PCA_cutoff <- 0.995

SNP <- SNP[SNP$Chromosome==8,]

geno.t <- t(SNP[,-c(1:3)])
geno.df <- data.frame(geno.t)
colnames(geno.df) <- as.character(unlist(SNP[,1]))
g <- cbind(rownames(geno.df), geno.df)
colnames(g)[1] <- c("X")
g$X <- as.character(g$X)

g <- g[,-1]

maf <- ifelse(colMeans(g)/2>0.5,1-colMeans(g)/2,colMeans(g)/2)

geno_filtered <- g[, which(maf > 0.05 )]

mySNP_nonmissing <- t(geno_filtered)

numLoci <- length(mySNP_nonmissing[, 1])

simpleMeff <- NULL
fixLength <- 100000
i <- 1
myStart <- 1
myStop <- 1
while(myStop < numLoci){
  myDiff <- numLoci - myStop
  if(myDiff <= fixLength) break

  myStop <- myStart + i*fixLength - 1
  snpInBlk <- t(mySNP_nonmissing[myStart:myStop, ])
  MeffBlk <- inferCutoff(snpInBlk)
  simpleMeff <- c(simpleMeff, MeffBlk)
  myStart <- myStop+1
}
snpInBlk <- mySNP_nonmissing[myStart:numLoci, ]
MeffBlk <- inferCutoff(snpInBlk)
simpleMeff <- c(simpleMeff, MeffBlk)

simpleM_8 <- sum(simpleMeff)

save(simpleM_8 , file = "simpleM_8.RData")


#' iccvpc: Calculate ICC and VPC from a multilevel model fitted by the lme4 package.
#'
#' This package provides functions to calculate the intra-class
#' correlation coefficient (ICC) and variance partition coefficient
#' (VPC) from multilevel models fitted using the lme4 package.
#'
#' @name iccvpc-package
#' @docType package
NULL


## DO TRAJECTORY-CENTRIC ANALYSIS
#do the features already need to be there???
#or calculate features myself... :/

# read data
trajectory_data = read.table("data/features_trajectory.txt", sep = "\t", header = TRUE)
head(trajectory_data)

# add track lenghts to essen trajectory data
# function to not keep created subsets in memory
getEssen.trackLengths <- function() {
  track_lenghts <- c()
  for(patient in unique(step_data$patientnumber)){
    for(treatment in unique(step_data$treatment)){
      tempsubset <- step_data[which(step_data[["patientnumber"]] == patient), ]
      realsubset <- tempsubset[which(tempsubset[["treatment"]] == treatment), ]
      for(track in unique(realsubset$track_id)){
        track_lenghts <- c(track_lenghts, nrow(realsubset[which(realsubset[["track_id"]] == track), ]))
      }
    }
  }
  return(track_lenghts)
}
essen.trackLengths <- getEssen.trackLengths()
#add track lenghts to trajectory data frame
essen.trajectory$track_length <- essen.trackLengths

### Permutation tests ###-------------------------------------------------------------------

#function to shuffle treatments within patient
shuffle <- function(dataset, number) {
  A <- subset(dataset, patientnumber == number)
  newtreatment<-sample(A[,'treatment'])
  perm_data<-A
  perm_data$treatment = newtreatment
  perm_data
}

patients <- unique(trajectory_data$patientnumber)

#set PBS as baseline for the model to compare with
traj_relevelled <- within(trajectory_data, treatment <- relevel(treatment, ref = "PBS"))

# Linear model + Standard Anova on these data
mod1 <- lm(accumulated_distance ~ treatment + patientnumber, data = features2_relevelled)
ANOVA <- summary(aov(mod1))
ANOVA
cat( " The standard ANOVA for these data follows ","\n")
Ftreatment <-  ANOVA[[1]]$"F value"[1]   # Saving F values for future use
Fpatientnumber <-  ANOVA[[1]]$"F value"[2]

pval=(sum(FT>=Ftreatment)+1)/(nreps+1)
pval
hist(FT, breaks = 100)

treatment = permutated_dataset$treatment

#post hoc test met multcomp library
model1.mcp<-glht(mod1,linfct=mcp(treatment="Tukey"))
summary(model1.mcp)

#4mean_speed

#run function over data, for number of times you want to do iteration
nreps <- 5000
FT <- numeric(nreps)    #Set up space to store F values as calculated.
FP <- numeric(nreps)
for (i in 2:nreps) {
  permutated_dataset = data.frame()
  for (patient in patients){
    newtreatment_dataset <- shuffle(features2, patient)
    permutated_dataset = rbind(permutated_dataset, newtreatment_dataset)
  }
  mod2 <- lm(permutated_dataset$mean_speed ~ permutated_dataset$treatment + permutated_dataset$patientnumber)
  b <- summary(aov(mod2))
  FT[i] <- b[[1]]$"F value"[1]
  FP[i] <- b[[1]]$"F value"[2]
}

# Standard Anova on these data
mod1 <- lm(mean_speed ~ treatment + patientnumber, data = features2_relevelled)
ANOVA <- summary(aov(mod1))
cat( " The standard ANOVA for these data follows ","\n")
Ftreatment <-  ANOVA[[1]]$"F value"[1]   # Saving F values for future use
Fpatientnumber <-  ANOVA[[1]]$"F value"[2]

pval=(sum(FT>=Ftreatment)+1)/(nreps+1)
pval

sum(FT)
sum(FT>=Ftreatment)

#post hoc test
model1.mcp<-glht(mod1,linfct=mcp(treatment="Tukey"))
summary(model1.mcp)

#1. CXCL1 - CXCL8
set.seed(1)
nreps <- 2500
FT <- numeric(nreps)    #Set up space to store F values as calculated.
FP <- numeric(nreps)
for (i in 2:nreps) {
  permutated_dataset = data.frame()
  for (patient in patients){
    newtreatment_dataset <- shuffle4(features2, patient, "CXCL1", "CXCL8")
    permutated_dataset = rbind(permutated_dataset, newtreatment_dataset)
  }
  mod2 <- lm(permutated_dataset$mean_speed ~ permutated_dataset$treatment + permutated_dataset$patientnumber)
  b <- summary(aov(mod2))
  FT[i] <- b[[1]]$"F value"[1]
  FP[i] <- b[[1]]$"F value"[2]
}

# Standard Anova on these data
mod1 <- lm(mean_speed ~ treatment + patientnumber, data = features2_relevelled)
ANOVA <- summary(aov(mod1))
ANOVA
cat( " The standard ANOVA for these data follows ","\n")
Ftreatment <-  ANOVA[[1]]$"F value"[1]   # Saving F values for future use
Fpatientnumber <-  ANOVA[[1]]$"F value"[2]

pval=(sum(FT>=Ftreatment)+1)/(nreps+1)
pval
hist(FT, breaks = 100)
sum(FT>=Ftreatment)

# -> niet significant (p = 0.6565374)

#2. CXCL1, PBS
set.seed(1)
nreps <- 2500
FT <- numeric(nreps)    #Set up space to store F values as calculated.
FP <- numeric(nreps)
for (i in 2:nreps) {
  permutated_dataset = data.frame()
  for (patient in patients){
    newtreatment_dataset <- shuffle4(features2, patient, "CXCL1", "PBS")
    permutated_dataset = rbind(permutated_dataset, newtreatment_dataset)
  }
  mod2 <- lm(permutated_dataset$mean_speed ~ permutated_dataset$treatment + permutated_dataset$patientnumber)
  b <- summary(aov(mod2))
  FT[i] <- b[[1]]$"F value"[1]
  FP[i] <- b[[1]]$"F value"[2]
}

# Standard Anova on these data
mod1 <- lm(mean_speed ~ treatment + patientnumber, data = features2_relevelled)
ANOVA <- summary(aov(mod1))
ANOVA
cat( " The standard ANOVA for these data follows ","\n")
Ftreatment <-  ANOVA[[1]]$"F value"[1]   # Saving F values for future use
Fpatientnumber <-  ANOVA[[1]]$"F value"[2]

pval=(sum(FT>=Ftreatment)+1)/(nreps+1)
pval
hist(FT, breaks = 100)
sum(FT>=Ftreatment)

# -> significant (p = 0.0003998401)

# CXCL1 fMLP

set.seed(1)
nreps <- 2500
FT <- numeric(nreps)    #Set up space to store F values as calculated.
FP <- numeric(nreps)
for (i in 2:nreps) {
  permutated_dataset = data.frame()
  for (patient in patients){
    newtreatment_dataset <- shuffle4(features2, patient, "CXCL1", "fMLP")
    permutated_dataset = rbind(permutated_dataset, newtreatment_dataset)
  }
  mod2 <- lm(permutated_dataset$mean_speed ~ permutated_dataset$treatment + permutated_dataset$patientnumber)
  b <- summary(aov(mod2))
  FT[i] <- b[[1]]$"F value"[1]
  FP[i] <- b[[1]]$"F value"[2]
}

# Standard Anova on these data
mod1 <- lm(mean_speed ~ treatment + patientnumber, data = features2_relevelled)
ANOVA <- summary(aov(mod1))
ANOVA
cat( " The standard ANOVA for these data follows ","\n")
Ftreatment <-  ANOVA[[1]]$"F value"[1]   # Saving F values for future use
Fpatientnumber <-  ANOVA[[1]]$"F value"[2]

pval=(sum(FT>=Ftreatment)+1)/(nreps+1)
pval
hist(FT, breaks = 100)
sum(FT>=Ftreatment)

#niet significant (p = 0.05877649)

#CXCL8 PBS

set.seed(1)
nreps <- 2500
FT <- numeric(nreps)    #Set up space to store F values as calculated.
FP <- numeric(nreps)
for (i in 2:nreps) {
  permutated_dataset = data.frame()
  for (patient in patients){
    newtreatment_dataset <- shuffle4(features2, patient, "CXCL8", "PBS")
    permutated_dataset = rbind(permutated_dataset, newtreatment_dataset)
  }
  mod2 <- lm(permutated_dataset$mean_speed ~ permutated_dataset$treatment + permutated_dataset$patientnumber)
  b <- summary(aov(mod2))
  FT[i] <- b[[1]]$"F value"[1]
  FP[i] <- b[[1]]$"F value"[2]
}

# Standard Anova on these data
mod1 <- lm(mean_speed ~ treatment + patientnumber, data = features2_relevelled)
ANOVA <- summary(aov(mod1))
ANOVA
cat( " The standard ANOVA for these data follows ","\n")
Ftreatment <-  ANOVA[[1]]$"F value"[1]   # Saving F values for future use
Fpatientnumber <-  ANOVA[[1]]$"F value"[2]

pval=(sum(FT>=Ftreatment)+1)/(nreps+1)
pval
hist(FT, breaks = 100)
sum(FT>=Ftreatment)

##heel significant (p = 0.0003998401)

#CXCL8 fMLP
set.seed(1)
nreps <- 2500
FT <- numeric(nreps)    #Set up space to store F values as calculated.
FP <- numeric(nreps)
for (i in 2:nreps) {
  permutated_dataset = data.frame()
  for (patient in patients){
    newtreatment_dataset <- shuffle4(features2, patient, "CXCL8", "fMLP")
    permutated_dataset = rbind(permutated_dataset, newtreatment_dataset)
  }
  mod2 <- lm(permutated_dataset$mean_speed ~ permutated_dataset$treatment + permutated_dataset$patientnumber)
  b <- summary(aov(mod2))
  FT[i] <- b[[1]]$"F value"[1]
  FP[i] <- b[[1]]$"F value"[2]
}

# Standard Anova on these data
mod1 <- lm(mean_speed ~ treatment + patientnumber, data = features2_relevelled)
ANOVA <- summary(aov(mod1))
ANOVA
cat( " The standard ANOVA for these data follows ","\n")
Ftreatment <-  ANOVA[[1]]$"F value"[1]   # Saving F values for future use
Fpatientnumber <-  ANOVA[[1]]$"F value"[2]

pval=(sum(FT>=Ftreatment)+1)/(nreps+1)
pval
hist(FT, breaks = 100)
sum(FT>=Ftreatment)

#significant (p = 0.00239904)

#fMLP PBS
set.seed(1)
nreps <- 2500
FT <- numeric(nreps)    #Set up space to store F values as calculated.
FP <- numeric(nreps)
for (i in 2:nreps) {
  permutated_dataset = data.frame()
  for (patient in patients){
    newtreatment_dataset <- shuffle4(features2, patient, "PBS", "fMLP")
    permutated_dataset = rbind(permutated_dataset, newtreatment_dataset)
  }
  mod2 <- lm(permutated_dataset$mean_speed ~ permutated_dataset$treatment + permutated_dataset$patientnumber)
  b <- summary(aov(mod2))
  FT[i] <- b[[1]]$"F value"[1]
  FP[i] <- b[[1]]$"F value"[2]
}

# Standard Anova on these data
mod1 <- lm(mean_speed ~ treatment + patientnumber, data = features2_relevelled)
ANOVA <- summary(aov(mod1))
ANOVA
cat( " The standard ANOVA for these data follows ","\n")
Ftreatment <-  ANOVA[[1]]$"F value"[1]   # Saving F values for future use
Fpatientnumber <-  ANOVA[[1]]$"F value"[2]

pval=(sum(FT>=Ftreatment)+1)/(nreps+1)
pval
hist(FT, breaks = 100)
sum(FT>=Ftreatment)

#significant (p = 0.009196321)

## other way to try permutation
set.seed(150)
B=5000
fOrig=anova(lm(mean_speed~treatment+patientnumber,data=features2_relevelled))$F[1]
fStar=sapply(X=1:B, FUN=function(b,y,groep)
{anova(lm(features2_relevelled$mean_speed~shuffle3(features2)+features2_relevelled$patientnumber))$F[1]})
fOrig

pval2=(sum(fStar>=fOrig)+1)/(B+1)
pval2

sum(fStar>=fOrig)

hist(fStar, breaks = 100)


#calculating spatial signal in taxa by phylo scale across NEON within sites.
#This shows generall the same pattern but looks much worse.
#its because a few sites have very few observations, yet they are weighted in the average just as much.
#stick with full network model.
rm(list=ls())
source('paths.r')
library(boot)

#logit transform observed values and model residuals?----
do_logit <- T

#Load data.----
d_all <- readRDS(NEON_all.phylo.levels_plot.site_obs_fastq_1k_rare.path)
loc_all <- readRDS(dp1.10086.00_output.path)
#spatial forecast.
fcast <- readRDS(NEON_site_fcast_all_groups_1k_rare.path)

#Calculate spatial statistics for all levels on forecast residuals.----
a_out <- list() #spatial signal of raw values.
b_out <- list() #spatial signal of model residuals.

for(k in 1:length(d_all)){
  #Grab tax/functional level.----
  d <- d_all[[k]]
  d <- d$core.fit
  loc <- loc_all
  pred <- fcast[[k]]$core.fit$mean

  #match up data, subset to mineral soil, drop stuff from identical locations.----
  rownames(d) <- gsub('-GEN','',rownames(d))
  #drop organic horizons. Generates zero distances.
  loc <- loc[loc$horizon == 'M',]
  loc$lat_lon <- paste0(loc$adjDecimalLongitude, loc$adjDecimalLatitude)
  drop <- loc[duplicated(loc$lat_lon),]$sampleID #drop some duplicated locations.
  loc <- loc[!(loc$sampleID %in% drop),]
  loc <- loc[loc$sampleID %in% rownames(d),]
  d <-   d[rownames(d) %in% loc$sampleID,]
  loc <- loc[order(match(loc$sampleID, rownames(d))),]
  pred <- pred[rownames(pred) %in% rownames(d),]
  pred <- pred[order(match(rownames(pred), rownames(d))),]
  #make sure predictions and observation columns are in the same order.
  pred <- pred[,order(match(colnames(pred), colnames(d)))]

  #generate model residuals as a logit difference.----
  resid <- (d) - (pred)
  if(do_logit == T){
    resid <- logit(d) - logit(pred)
    d <- logit(d)
  }

  #grab a particular site.----
  a.site_out <- list()
  b.site_out <- list()
  sites <- unique(loc$siteID)
  for(j in 1:length(sites)){
    #Generate spatial distance matrix.----
    tax.loc <- loc[loc$siteID == sites[j],]
    d.site <- d[rownames(d) %in% tax.loc$sampleID,]
    resid.site <- resid[rownames(resid) %in% tax.loc$sampleID,]
    tax.loc <- tax.loc[,c('adjDecimalLongitude','adjDecimalLatitude')]
    tax.dist <- geosphere::distm(tax.loc)
    inv.tax.dist <- 1/tax.dist
    diag(inv.tax.dist) <- 0

    #calulate moran statistics within site.----
    moran_out <- list()
    resid_out <- list()
    for(i in 1:ncol(d.site)){
      #make sure there is variance in taxa being calculated.
      if(length(unique(d.site[,i])) == 1){
        moran_out[[i]] <- NA
        resid_out[[i]] <- NA
        next
      }
      #moran stat for raw residuals.
      moran.stat  <- ape::Moran.I((d.site[,i]), inv.tax.dist)
      moran.stat  <- c(moran.stat$observed, moran.stat$p.value)
      #moran stat for post-model residuals.
      resid.stat <- ape::Moran.I(resid.site[,i], inv.tax.dist)
      resid.stat <- c(resid.stat$observed, resid.stat$p.value)
      #moran.resid
      names(moran.stat) <- c('moran','p.val')
      names(resid.stat) <- c('moran','p.val')
      moran_out[[i]] <- moran.stat
      resid_out[[i]] <- resid.stat
    }

    #Drop taxa that couldn't fit, wrap up level output.----
    names(moran_out) <- colnames(d)
    names(resid_out) <- colnames(resid)
    moran_out <- moran_out[!(is.na(moran_out))]
    resid_out <- resid_out[!(is.na(resid_out))]
    moran_out <- data.frame(do.call(rbind, moran_out))
    resid_out <- data.frame(do.call(rbind, resid_out))

    #return intra-site output.
    a.site_out[[j]] <- moran_out
    b.site_out[[j]] <- resid_out
  } #end intra_site out.

  names(a.site_out) <- as.character(sites)
  names(b.site_out) <- as.character(sites)
  a.site_out <- data.frame(do.call(rbind, a.site_out))
  b.site_out <- data.frame(do.call(rbind, b.site_out))

  #return output.----
  a_out[[k]] <- a.site_out
  b_out[[k]] <- b.site_out
}
names(a_out) <- names(d_all)
names(b_out) <- names(d_all)

#calculate average morans I for all groups.----
a_avg <- list()
b_avg <- list()
for(i in 1:length(a_out)){
  #no model.
  a.mu <- mean(a_out[[i]]$moran)
  a.sd <-   sd(a_out[[i]]$moran)
  a.se <- a.sd/sqrt(nrow(a_out[[i]]))
  to_return.a <- c(a.mu, a.sd, a.se)
  names(to_return.a) <- c('mu','sd','se')
  a_avg[[i]] <- to_return.a
  #residuals of model.
  b.mu <- mean(b_out[[i]]$moran)
  b.sd <-   sd(b_out[[i]]$moran)
  b.se <- b.sd/sqrt(nrow(b_out[[i]]))
  to_return.b <- c(b.mu, b.sd, b.se)
  names(to_return.b) <- c('mu','sd','se')
  b_avg[[i]] <- to_return.b

}
a_avg <- data.frame(do.call(rbind, a_avg))
b_avg <- data.frame(do.call(rbind, b_avg))
rownames(a_avg) <- names(a_out)
rownames(b_avg) <- names(b_out)

#assign x positions, functional groups first.
a_avg$x <- c(2:(nrow(a_avg)), 1)
b_avg$x <- c(2:(nrow(b_avg)), 1)

#plot.-----
par(mfrow=c(1,2))

#Raw spatial signal.----
limy <- c(0, max(a_avg$mu + a_avg$se))
plot(mu ~ x, data = a_avg, cex = 2, pch = 16, ylim = limy,
     ylab = "Moran's I", xlab = NA, xaxt = 'n')
#error bars.
mu <- a_avg$mu
x <- a_avg$x
upr <- mu + a_avg$se
lwr <- mu - a_avg$se
arrows(c(x), lwr, c(x), upr, length=0.00, angle=90, code=3, col = 'black', lwd = 2)
#x-axis.
x.lab <- rownames(a_avg)
x.lab[x.lab == 'fg'] <- 'function_group'
axis(1, at=a_avg$x, labels=x.lab, cex = 0.8)
mtext('Spatial Signal',side = 3, line = 0.5, cex = 1.4)

#Post model spatial signal.----
plot(mu ~ x, data = b_avg, cex = 2, pch = 16, ylim = limy,
     ylab = "Moran's I", xlab = NA, xaxt = 'n')
#error bars.
mu <- b_avg$mu
x <- b_avg$x
upr <- mu + b_avg$se
lwr <- mu - b_avg$se
arrows(c(x), lwr, c(x), upr, length=0.00, angle=90, code=3, col = 'black', lwd = 2)
#x-axis.
x.lab <- rownames(b_avg)
x.lab[x.lab == 'fg'] <- 'function_group'
axis(1, at=b_avg$x, labels=x.lab, cex = 0.8)
mtext('Spatial Signal Model Residuals',side = 3, line = 0.5, cex = 1.4)


########################### BayesKin ###########################
## Bayesian estimates of rigid body kinematics
## Andy Pohl
## UofC - Faculty of Kinesiology

## Written by: Andy Pohl
## UofC - Faculty of Kinesiology
## June-Dec 2020
## Revision 1: April 2021
################################################################

##################### process_results.r  ###################
## processes_results table for a batch of simulations
#############################################################

# preliminaries
rm(list = ls()) # clear workspace

library('rjags') # load rstan package to analyze rstan objects
library('coda') # load coda package for mcmc analysis
WORKING_DIR = "" # Replace with the location of the BayesKin/src directory on the local PC.
setwd(WORKING_DIR)
RESULTS_DIR = paste0(WORKING_DIR, "/src/") # location of results directory
POSE_DIRS = c("SingleLink_Mdl", "DoubleLink_Mdl", "TripleLink_Mdl")  # Folder names for the various model configurations
MODELS = c("LS", "Bayes_p1", "Bayes_p2", "Bayes_p3", "Bayes_p4", "Bayes_p5") # Names of Models used
file_ends = c('LSModel.rda', 'BayesModel_p1.rda', 'BayesModel_p2.rda', 'BayesModel_p3.rda', 'BayesModel_p4.rda', 'BayesModel_p5.rda')

PARMS = c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma') # Parameters of interest

nfiles = 1000 # the number of results files to process
nmodels = length(MODELS)

################################################################################
# Single Link
################################################################################
results_single = data.frame(pose = rep('SingleLink', nmodels*4*nfiles),
                            seed = rep(1:nfiles, each = nmodels*4),
                            model = rep(rep(MODELS, each = 4),nfiles),
                            parameter = rep(c('r1', 'r2', 'theta1', 'sigma'), nfiles*nmodels),
                            est = NA,
                            quantile = matrix(NA, nfiles*4*nmodels, 5),
                            neff = NA,
                            rhat = NA,
                            ts_se = NA,
                            run_time = NA)

files = list.files(path = paste0(RESULTS_DIR, "SingleLink_Mdl/Bayes_p3"))
seeds = as.numeric(gsub("(.+?)(\\_.*)", "\\1", files))
seeds = seeds[order(seeds)]
rowcnt = 1
for(i in 1:nfiles){
    nlinks = 1
    seed = seeds[i]
    print(sprintf("Processing Single Link file %.0f of %.0f", i, nfiles))

    # process LS results
    lsmdl = readRDS(paste0(RESULTS_DIR, "SingleLink_Mdl/LS/", seed, "_LSModel.rda"))
    est = c(lsmdl$r.hat, lsmdl$theta.hat, lsmdl$sigma.hat)
    int = lsmdl$intervals[1:(nlinks+2),]
    results_single[rowcnt:(rowcnt+3), c('est')] = est
    results_single[rowcnt:(rowcnt+2), c('quantile.1', 'quantile.5')] = int
    results_single[rowcnt:(rowcnt+3), c('run_time')] = lsmdl$time
    rowcnt = rowcnt + 4

    # process Bayes P1
    p1mdl =  readRDS(paste0(RESULTS_DIR, "SingleLink_Mdl/Bayes_p1/", seed, "_BayesModel_p1.rda"))
    p1sum = summary(p1mdl$fit)
    results_single[rowcnt:(rowcnt+3),c('est', 'ts_se')] = p1sum$statistics[c('r[1]', 'r[2]', 'theta', 'sigma'),c('Mean', 'Time-series SE')]
    results_single[rowcnt:(rowcnt+3),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p1sum$quantiles[c('r[1]', 'r[2]', 'theta', 'sigma'),]
    results_single[rowcnt:(rowcnt+3), c('neff')] = effectiveSize(p1mdl$fit)[c('r[1]', 'r[2]', 'theta', 'sigma')]
    results_single[rowcnt:(rowcnt+3), c('rhat')] = gelman.diag(p1mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta', 'sigma'),1]
    results_single[rowcnt:(rowcnt+3), c('run_time')] = p1mdl$time
    rowcnt = rowcnt + 4

    # process Bayes P2
    p2mdl =  readRDS(paste0(RESULTS_DIR, "SingleLink_Mdl/Bayes_p2/", seed, "_BayesModel_p2.rda"))
    p2sum = summary(p2mdl$fit)
    results_single[rowcnt:(rowcnt+3),c('est', 'ts_se')] = p2sum$statistics[c('r[1]', 'r[2]', 'theta', 'sigma'),c('Mean', 'Time-series SE')]
    results_single[rowcnt:(rowcnt+3),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p2sum$quantiles[c('r[1]', 'r[2]', 'theta', 'sigma'),]
    results_single[rowcnt:(rowcnt+3), c('neff')] = effectiveSize(p2mdl$fit)[c('r[1]', 'r[2]', 'theta', 'sigma')]
    results_single[rowcnt:(rowcnt+3), c('rhat')] = gelman.diag(p2mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta', 'sigma'),1]
    results_single[rowcnt:(rowcnt+3), c('run_time')] = p2mdl$time
    rowcnt = rowcnt + 4

    # process Bayes P3
    p3mdl =  readRDS(paste0(RESULTS_DIR, "SingleLink_Mdl/Bayes_p3/", seed, "_BayesModel_p3.rda"))
    p3sum = summary(p3mdl$fit)
    results_single[rowcnt:(rowcnt+3),c('est', 'ts_se')] = p3sum$statistics[c('r[1]', 'r[2]', 'theta[1]', 'sigma'),c('Mean', 'Time-series SE')]
    results_single[rowcnt:(rowcnt+3),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p3sum$quantiles[c('r[1]', 'r[2]', 'theta[1]', 'sigma'),]
    results_single[rowcnt:(rowcnt+3), c('neff')] = effectiveSize(p3mdl$fit)[c('r[1]', 'r[2]', 'theta[1]', 'sigma')]
    results_single[rowcnt:(rowcnt+3), c('rhat')] = gelman.diag(p3mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta[1]', 'sigma'),1]
    results_single[rowcnt:(rowcnt+3), c('run_time')] = p3mdl$time
    rowcnt = rowcnt + 4

    # process Bayes P4
    p4mdl =  readRDS(paste0(RESULTS_DIR, "SingleLink_Mdl/Bayes_p4/", seed, "_BayesModel_p4.rda"))
    p4sum = summary(p4mdl$fit)
    results_single[rowcnt:(rowcnt+3),c('est', 'ts_se')] = p4sum$statistics[c('r[1]', 'r[2]', 'theta', 'sigma'),c('Mean', 'Time-series SE')]
    results_single[rowcnt:(rowcnt+3),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p4sum$quantiles[c('r[1]', 'r[2]', 'theta', 'sigma'),]
    results_single[rowcnt:(rowcnt+3), c('neff')] = effectiveSize(p4mdl$fit)[c('r[1]', 'r[2]', 'theta', 'sigma')]
    results_single[rowcnt:(rowcnt+3), c('rhat')] = gelman.diag(p4mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta', 'sigma'),1]
    results_single[rowcnt:(rowcnt+3), c('run_time')] = p4mdl$time
    rowcnt = rowcnt + 4

    # process Bayes P5
    p5mdl =  readRDS(paste0(RESULTS_DIR, "SingleLink_Mdl/Bayes_p5/", seed, "_BayesModel_p5.rda"))
    p5sum = summary(p5mdl$fit)
    results_single[rowcnt:(rowcnt+3),c('est', 'ts_se')] = p5sum$statistics[c('r[1]', 'r[2]', 'theta', 'sigma'),c('Mean', 'Time-series SE')]
    results_single[rowcnt:(rowcnt+3),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p5sum$quantiles[c('r[1]', 'r[2]', 'theta', 'sigma'),]
    results_single[rowcnt:(rowcnt+3), c('neff')] = effectiveSize(p5mdl$fit)[c('r[1]', 'r[2]', 'theta', 'sigma')]
    results_single[rowcnt:(rowcnt+3), c('rhat')] = gelman.diag(p5mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta', 'sigma'),1]
    results_single[rowcnt:(rowcnt+3), c('run_time')] = p5mdl$time
    rowcnt = rowcnt + 4

}

################################################################################
# Double Link
################################################################################
results_double = data.frame(pose = rep('DoubleLink', nmodels*5*nfiles),
                            seed = rep(1:nfiles, each = nmodels*5),
                            model = rep(rep(MODELS, each = 5),nfiles),
                            parameter = rep(c('r1', 'r2', 'theta1', 'theta2', 'sigma'), nfiles*nmodels),
                            est = NA,
                            quantile = matrix(NA, nfiles*5*nmodels, 5),
                            neff = NA,
                            rhat = NA,
                            ts_se = NA,
                            run_time = NA)

files = list.files(path = paste0(RESULTS_DIR, "DoubleLink_Mdl/Bayes_p3"))
seeds = as.numeric(gsub("(.+?)(\\_.*)", "\\1", files))
seeds = seeds[order(seeds)]
rowcnt = 1
for(i in 1:nfiles){
    nlinks = 2
    seed = seeds[i]
    print(sprintf("Processing Double Link file %.0f of %.0f", i, nfiles))

    # process LS results
    lsmdl = readRDS(paste0(RESULTS_DIR, "DoubleLink_Mdl/LS/", seed, "_LSModel.rda"))
    est = c(lsmdl$r.hat, lsmdl$theta.hat, lsmdl$sigma.hat)
    int = lsmdl$intervals[1:(nlinks+2),]
    results_double[rowcnt:(rowcnt+4), c('est')] = est
    results_double[rowcnt:(rowcnt+3), c('quantile.1', 'quantile.5')] = int
    results_double[rowcnt:(rowcnt+4), c('run_time')] = lsmdl$time
    rowcnt = rowcnt + 5

    # process Bayes P1
    p1mdl =  readRDS(paste0(RESULTS_DIR, "DoubleLink_Mdl/Bayes_p1/", seed, "_BayesModel_p1.rda"))
    p1sum = summary(p1mdl$fit)
    results_double[rowcnt:(rowcnt+4),c('est', 'ts_se')] = p1sum$statistics[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma'),c('Mean', 'Time-series SE')]
    results_double[rowcnt:(rowcnt+4),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p1sum$quantiles[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma'),]
    results_double[rowcnt:(rowcnt+4), c('neff')] = effectiveSize(p1mdl$fit)[c('r[1]', 'r[2]', 'theta[1]','theta[2]', 'sigma')]
    results_double[rowcnt:(rowcnt+4), c('rhat')] = gelman.diag(p1mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma'), 1]
    results_double[rowcnt:(rowcnt+4), c('run_time')] = p1mdl$time
    rowcnt = rowcnt + 5

    # process Bayes P2
    p2mdl =  readRDS(paste0(RESULTS_DIR, "DoubleLink_Mdl/Bayes_p2/", seed, "_BayesModel_p2.rda"))
    p2sum = summary(p2mdl$fit)
    results_double[rowcnt:(rowcnt+4),c('est', 'ts_se')] = p2sum$statistics[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma'),c('Mean', 'Time-series SE')]
    results_double[rowcnt:(rowcnt+4),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p2sum$quantiles[c('r[1]', 'r[2]', 'theta[1]','theta[2]', 'sigma'),]
    results_double[rowcnt:(rowcnt+4), c('neff')] = effectiveSize(p2mdl$fit)[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma')]
    results_double[rowcnt:(rowcnt+4), c('rhat')] = gelman.diag(p2mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma'),1]
    results_double[rowcnt:(rowcnt+4), c('run_time')] = p2mdl$time
    rowcnt = rowcnt + 5

    # process Bayes P3
    p3mdl =  readRDS(paste0(RESULTS_DIR, "DoubleLink_Mdl/Bayes_p3/", seed, "_BayesModel_p3.rda"))
    p3sum = summary(p3mdl$fit)
    results_double[rowcnt:(rowcnt+4),c('est', 'ts_se')] = p3sum$statistics[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma'),c('Mean', 'Time-series SE')]
    results_double[rowcnt:(rowcnt+4),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p3sum$quantiles[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma'),]
    results_double[rowcnt:(rowcnt+4), c('neff')] = effectiveSize(p3mdl$fit)[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma')]
    results_double[rowcnt:(rowcnt+4), c('rhat')] = gelman.diag(p3mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma'),1]
    results_double[rowcnt:(rowcnt+4), c('run_time')] = p3mdl$time
    rowcnt = rowcnt + 5

    # process Bayes P4
    p4mdl =  readRDS(paste0(RESULTS_DIR, "DoubleLink_Mdl/Bayes_p4/", seed, "_BayesModel_p4.rda"))
    p4sum = summary(p4mdl$fit)
    results_double[rowcnt:(rowcnt+4),c('est', 'ts_se')] = p4sum$statistics[c('r[1]', 'r[2]','theta[1]', 'theta[2]', 'sigma'),c('Mean', 'Time-series SE')]
    results_double[rowcnt:(rowcnt+4),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p4sum$quantiles[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma'),]
    results_double[rowcnt:(rowcnt+4), c('neff')] = effectiveSize(p4mdl$fit)[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]','sigma')]
    results_double[rowcnt:(rowcnt+4), c('rhat')] = gelman.diag(p4mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]','sigma'),1]
    results_double[rowcnt:(rowcnt+4), c('run_time')] = p4mdl$time
    rowcnt = rowcnt + 5

    # process Bayes P5
    p5mdl =  readRDS(paste0(RESULTS_DIR, "DoubleLink_Mdl/Bayes_p5/", seed, "_BayesModel_p5.rda"))
    p5sum = summary(p5mdl$fit)
    results_double[rowcnt:(rowcnt+4),c('est', 'ts_se')] = p5sum$statistics[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma'),c('Mean', 'Time-series SE')]
    results_double[rowcnt:(rowcnt+4),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p5sum$quantiles[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma'),]
    results_double[rowcnt:(rowcnt+4), c('neff')] = effectiveSize(p5mdl$fit)[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma')]
    results_double[rowcnt:(rowcnt+4), c('rhat')] = gelman.diag(p5mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'sigma'),1]
    results_double[rowcnt:(rowcnt+4), c('run_time')] = p5mdl$time
    rowcnt = rowcnt + 5

}

################################################################################
# Triple Link
################################################################################
results_triple = data.frame(pose = rep('TripleLink', nmodels*6*nfiles),
                            seed = rep(1:nfiles, each = nmodels*6),
                            model = rep(rep(MODELS, each = 6),nfiles),
                            parameter = rep(c('r1', 'r2', 'theta1', 'theta2', 'theta3', 'sigma'), nfiles*nmodels),
                            est = NA,
                            quantile = matrix(NA, nfiles*6*nmodels, 5),
                            neff = NA,
                            rhat = NA,
                            ts_se = NA,
                            run_time = NA)

files = list.files(path = paste0(RESULTS_DIR, "TripleLink_Mdl/Bayes_p3"))
seeds = as.numeric(gsub("(.+?)(\\_.*)", "\\1", files))
seeds = seeds[order(seeds)]
rowcnt = 1
for(i in 1:nfiles){
    nlinks = 3
    seed = seeds[i]
    print(sprintf("Processing Triple Link file %.0f of %.0f", i, nfiles))

    # process LS results
    lsmdl = readRDS(paste0(RESULTS_DIR, "TripleLink_Mdl/LS/", seed, "_LSModel.rda"))
    est = c(lsmdl$r.hat, lsmdl$theta.hat, lsmdl$sigma.hat)
    int = lsmdl$intervals[1:(nlinks+2),]
    results_triple[rowcnt:(rowcnt+5), c('est')] = est
    results_triple[rowcnt:(rowcnt+4), c('quantile.1', 'quantile.5')] = int
    results_triple[rowcnt:(rowcnt+5), c('run_time')] = lsmdl$time
    rowcnt = rowcnt + 6

    # process Bayes P1
    p1mdl =  readRDS(paste0(RESULTS_DIR, "TripleLink_Mdl/Bayes_p1/", seed, "_BayesModel_p1.rda"))
    p1sum = summary(p1mdl$fit)
    results_triple[rowcnt:(rowcnt+5),c('est', 'ts_se')] = p1sum$statistics[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'),c('Mean', 'Time-series SE')]
    results_triple[rowcnt:(rowcnt+5),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p1sum$quantiles[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'),]
    results_triple[rowcnt:(rowcnt+5), c('neff')] = effectiveSize(p1mdl$fit)[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma')]
    results_triple[rowcnt:(rowcnt+5), c('rhat')] = gelman.diag(p1mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'), 1]
    results_triple[rowcnt:(rowcnt+5), c('run_time')] = p1mdl$time
    rowcnt = rowcnt + 6

    # process Bayes P2
    p2mdl =  readRDS(paste0(RESULTS_DIR, "TripleLink_Mdl/Bayes_p2/", seed, "_BayesModel_p2.rda"))
    p2sum = summary(p2mdl$fit)
    results_triple[rowcnt:(rowcnt+5),c('est', 'ts_se')] = p2sum$statistics[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'),c('Mean', 'Time-series SE')]
    results_triple[rowcnt:(rowcnt+5),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p2sum$quantiles[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'),]
    results_triple[rowcnt:(rowcnt+5), c('neff')] = effectiveSize(p2mdl$fit)[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma')]
    results_triple[rowcnt:(rowcnt+5), c('rhat')] = gelman.diag(p2mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'),1]
    results_triple[rowcnt:(rowcnt+5), c('run_time')] = p2mdl$time
    rowcnt = rowcnt + 6

    # process Bayes P2
    p3mdl =  readRDS(paste0(RESULTS_DIR, "TripleLink_Mdl/Bayes_p3/", seed, "_BayesModel_p3.rda"))
    p3sum = summary(p3mdl$fit)
    results_triple[rowcnt:(rowcnt+5),c('est', 'ts_se')] = p3sum$statistics[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'),c('Mean', 'Time-series SE')]
    results_triple[rowcnt:(rowcnt+5),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p3sum$quantiles[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'),]
    results_triple[rowcnt:(rowcnt+5), c('neff')] = effectiveSize(p3mdl$fit)[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma')]
    results_triple[rowcnt:(rowcnt+5), c('rhat')] = gelman.diag(p3mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'),1]
    results_triple[rowcnt:(rowcnt+5), c('run_time')] = p3mdl$time
    rowcnt = rowcnt + 6

    # process Bayes P4
    p4mdl =  readRDS(paste0(RESULTS_DIR, "TripleLink_Mdl/Bayes_p4/", seed, "_BayesModel_p4.rda"))
    p4sum = summary(p4mdl$fit)
    results_triple[rowcnt:(rowcnt+5),c('est', 'ts_se')] = p4sum$statistics[c('r[1]', 'r[2]','theta[1]', 'theta[2]', 'theta[3]', 'sigma'),c('Mean', 'Time-series SE')]
    results_triple[rowcnt:(rowcnt+5),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p4sum$quantiles[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'),]
    results_triple[rowcnt:(rowcnt+5), c('neff')] = effectiveSize(p4mdl$fit)[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]','sigma')]
    results_triple[rowcnt:(rowcnt+5), c('rhat')] = gelman.diag(p4mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]','sigma'),1]
    results_triple[rowcnt:(rowcnt+5), c('run_time')] = p4mdl$time
    rowcnt = rowcnt + 6

    # process Bayes P5
    p5mdl =  readRDS(paste0(RESULTS_DIR, "TripleLink_Mdl/Bayes_p5/", seed, "_BayesModel_p5.rda"))
    p5sum = summary(p5mdl$fit)
    results_triple[rowcnt:(rowcnt+5),c('est', 'ts_se')] = p5sum$statistics[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'),c('Mean', 'Time-series SE')]
    results_triple[rowcnt:(rowcnt+5),c('quantile.1', 'quantile.2','quantile.3','quantile.4','quantile.5')] = p5sum$quantiles[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'),]
    results_triple[rowcnt:(rowcnt+5), c('neff')] = effectiveSize(p5mdl$fit)[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma')]
    results_triple[rowcnt:(rowcnt+5), c('rhat')] = gelman.diag(p5mdl$fit)$psrf[c('r[1]', 'r[2]', 'theta[1]', 'theta[2]', 'theta[3]', 'sigma'),1]
    results_triple[rowcnt:(rowcnt+5), c('run_time')] = p5mdl$time
    rowcnt = rowcnt + 6

}

################################################################################
# Combine and save
################################################################################
print("Combing files")
results = rbind(results_single, results_double, results_triple)
print("Saving Results...")

saveRDS(results, file = paste0(RESULTS_DIR, 'results/results_', format(Sys.time(), "%d%m%Y"),".rda"))
write.table(results, file = paste0(RESULTS_DIR, 'results/results_', format(Sys.time(), "%d%m%Y"),".csv"), sep = ',', col.names = TRUE, row.names = FALSE)
print("Complete!")


R
library(immuneSIM)

# first obtain BCR fasta sequences with different amount of mutations in the variable domains (15, 30, 45, 60).
# here an example for IGH BCR with 15 somatic hypermutations (SHM):

sim_repertoire_IGH_shm15 <- immuneSIM(number_of_seqs = 100,
                                        species = "hs",
                                        receptor = "ig",
                                        chain = "h",
                                        shm.mode="data",
                                        shm.prob=15/350)

write.table(sim_repertoire_IGH_shm15,"igh_shm15.tsv",quote=F,col.names=T,row.names=F,sep="\t")

sim_repertoire_IGH_shm30 <- immuneSIM(number_of_seqs = 100,
                                        species = "hs",
                                        receptor = "ig",
                                        chain = "h",
                                        shm.mode="data",
                                        shm.prob=30/350)

write.table(sim_repertoire_IGH_shm30,"igh_shm30.tsv",quote=F,col.names=T,row.names=F,sep="\t")

sim_repertoire_IGH_shm45 <- immuneSIM(number_of_seqs = 100,
                                        species = "hs",
                                        receptor = "ig",
                                        chain = "h",
                                        shm.mode="data",
                                        shm.prob=45/350)

write.table(sim_repertoire_IGH_shm45,"igh_shm45.tsv",quote=F,col.names=T,row.names=F,sep="\t")

sim_repertoire_IGH_shm60 <- immuneSIM(number_of_seqs = 100,
                                        species = "hs",
                                        receptor = "ig",
                                        chain = "h",
                                        shm.mode="data",
                                        shm.prob=60/350)

write.table(sim_repertoire_IGH_shm60,"igh_shm60.tsv",quote=F,col.names=T,row.names=F,sep="\t")
q()


library(plyr)
library(dplyr)
library(tibble)
library(tidyr)
library(ggplot2)
library(ordinal)
theme_set(theme_bw())

dd = read.csv(file="tilhaldid-data.csv")

# Reshape table
newtable = dd %>%
  gather(Speaker, Response, -X., -Sentence, -Gloss, -Neg.order, -PosAdv.order, -Aux2.PosAdv.order, -Obj.movt, -Obj.x.PolAdv, -Ptc.x.PolAdv, -Subj.gend, -Subj.num, -Obj.case, -Obj.gend, -Obj.num, -Nom.obj.agr, -Dat.subj.agr, -Acc.obj.agr) %>%
  filter(Response != "-") %>%
  mutate(Response = as.numeric(Response))

# Define "not in" function
'%!in%' <- function(x,y)!('%in%'(x,y))

# Isolate only non-bimodal sentences in table
no_bimodals = newtable %>%
  filter(Sentence %!in% c("Teimum man bókina ikki altíð hava dámað","Mær dáma bátarnar","Mær hevur ikki altíð dámað bókina","Okkum dáma bátarnar","Tykkum dáma bátarnir","Teimum tørva bátarnar"))

# Get rid of sentences with no negative adverb
agreement = no_bimodals %>%
  filter(Neg.order == "-") %>%
  droplevels()

# Aggregate agreement table
agr = no_bimodals %>%
  group_by(Obj.case, Subj.num) %>%
  summarise(Mean = mean(Response), CILow = ci.low(Response), CIHigh = ci.high(Response)) %>%
  mutate(YMin = Mean - CILow, YMax = Mean + CIHigh)

dodge = position_dodge(.9)

# Plot acceptability judgements by agreement
ggplot(agr, aes(x=Obj.case, y=Mean, fill=Subj.num)) +
  geom_bar(stat="identity", position=dodge) +
  geom_errorbar(aes(ymin=YMin, ymax=YMax),position=dodge,width=.25) + coord_cartesian(ylim=c(1,5))

# Run ordered logit regression model
model = clmm(as.factor(Response) ~ Obj.case + Subj.num + (1|Speaker) + (1|Sentence), data = newtable)
summary(model)


#
# Exemplo 5
#

# laco de repeticao: for
x <- seq(-100, 100, 1)
# observação:
#       a função seq_len cujo argumento é length de x
#       anteriormente era 1:length(x) e foi trocado
#       devido ao linter de R.
for (i in seq_len(length(x))) {
    valores <- x^2
}
valores


test_that("Reta Minima Distancia", {
    arq <- system.file("extratestdata/retamindist/colina_Processada/preliminar/retamindistteste.csv",
        package = "curvacolina")
    expect_warning(interp <- retamindist(arq))

    arq <- system.file("extratestdata/retamindist/colina_Processada/preliminar/retamindistteste_1.csv",
        package = "curvacolina")
    interp <- retamindist(arq)

    expect_equal(class(interp), c("retamindist", "interpolador"))
    expect_equal(length(interp), 2)
    expect_equal(names(interp), c("superficie", "colina"))

    gg <- coordgrade(getcolina.retamindist(interp), 20, 20)

    pred_vec <- predict(interp, gg)
    expect_snapshot_value(summary(pred_vec), style = "json2")

    pred_full <- predict(interp, gg, TRUE)
    expect_equal(class(pred_full), "gradecolina")
    expect_equal(class(pred_full[[2]]), "curvacolina")
    expect_equal(colnames(pred_full[[1]]), c("hl", "pot", "rend", "inhull"))
    expect_equal(pred_full[[1]]$rend, pred_vec)

    p3d <- plot(interp, print = FALSE, dhl = 10, dpot = 10)
    expect_equal(class(p3d), c("plotly", "htmlwidget"))

    p2d <- plot(interp, tipo = "2d", print = FALSE, dhl = 10, dpot = 10)
    expect_equal(class(p2d), c("gg", "ggplot"))
})


library("ggplot2")
library("reshape2")
setwd("~/dev/BitFunnel/src/Scripts")

# png(filename="wat.png",width=800,height=600)
png(filename="talk.png",width=1600,height=1200)
# df <- read.csv(header=FALSE, file="wat.csv")
df <- read.csv(header=FALSE, file="talk.csv")
## df <- read.csv(file="wat.csv")
## munged <- melt(df)
## ggplot(munged, aes(x=variable, y=value)) + geom_point()

# plot single
# ggplot(data=df, aes(x=factor(V1), y=V2)) + geom_bar(stat="identity") + labs(x = "Number of cache misses", y = "count")

# plot uniform 20 vs. buggy distribution
# ggplot(data=df, aes(x=factor(V1), y=V2)) + geom_bar(stat="identity") + facet_wrap(~ V3, ncol=1) + labs(x = "Number of cache misses", y = "count")

# plot for talk
ggplot(data=df, aes(x=factor(V1), y=V2)) + geom_bar(stat="identity") + labs(x = "Memory accesses", y = "Percent") +
  theme_bw() +
  theme(axis.text = element_text(size=40),
        axis.title = element_text(size=40))

dev.off()


#movielens data preparation
#laod data
raw_data = read.csv("C:/Suresh/R&D/packtPublications/reco_engines/drafts/personalRecos/udata.csv",sep="\t",header=F)
colnames(raw_data) = c("UserId","MovieId","Rating","TimeStamp")
ratings = raw_data[,1:3]
movies = read.csv("C:/Suresh/R&D/packtPublications/reco_engines/drafts/personalRecos/uitem.csv",sep="|",header=F)
colnames(movies) = c("MovieId","MovieTitle","ReleaseDate","VideoReleaseDate","IMDbURL","Unknown","Action","Adventure","Animation","Children","Comedy","Crime","Documentary","Drama","Fantasy","FilmNoir","Horror","Musical","Mystery","Romance","SciFi","Thriller","War","Western")
movies = movies[,-c(2:5)]

'users = read.csv("C:/Suresh/R&D/packtPublications/reco_engines/drafts/personalRecos/uuser.csv",sep="|",header=F)
colnames(users) = c("UserId","Age","Gender","Occupation","ZipCode")
users = users[,-c(4,5)]'
#basic stats of data
dim(movies)
#[1] 1682   24
#dim(users)
#[1] 943   5

#merging user item rating with user profile
#ratings = merge(x = ratings, y = users, by = "UserId", all.x = TRUE)
ratings = merge(x = ratings, y = movies, by = "MovieId", all.x = TRUE)

names(ratings)

#remove unwanted columns
#ratings = ratings[,-c(4,8:12)]

#conversion to categorical
nrat = unlist(lapply(ratings$Rating,function(x)
{
  if(x>3) {return(1)}
  else {return(0)}
}))
ratings = cbind(ratings,nrat)
apply(ratings[,-c(1:3,23)],2,function(x)table(x))
scaled_ratings = ratings[,-c(3,4)]
#ratings$Rating = as.factor(ratings$Rating)
#ratings$Gender = factor(ratings$Gender,levels=c("0","1"))
#ratings$NAge = scale(ratings$Age)
#ratings = ratings[,-4]
names(scaled_ratings)
#scaled_ratings = scale(ratings[,-c(1,2)])
#build models
'library(caret)
control <- trainControl(method="repeatedcv", number=10, repeats=1)
set.seed(7)
modelKNN <- train(Rating~., data=ratings[,-c(1,2)], method="knn",metric="Accuracy", trControl=control)
'
'k-Nearest Neighbors

100000 samples
22 predictor
5 classes: "1", "2", "3", "4", "5"

No pre-processing
Resampling: Cross-Validated (5 fold)
Summary of sample sizes: 80000, 80000, 80000, 80000, 80000
Resampling results across tuning parameters:

k  Accuracy  Kappa      Accuracy SD  Kappa SD
5  0.35001   0.1001631  0.003126380  0.003737368
7  0.35419   0.1022643  0.001690192  0.001714554
9  0.35468   0.1001364  0.003435586  0.004281009

Accuracy was used to select the optimal model using  the largest value.
The final value used for the model was k = 9.
'
scaled_ratings=scale(scaled_ratings[,-c(1,2,21)])
scaled_ratings = cbind(scaled_ratings,ratings[,c(1,2,23)])
#train test samples
set.seed(7)
which_train <- sample(x = c(TRUE, FALSE), size = nrow(scaled_ratings),
                      replace = TRUE, prob = c(0.8, 0.2))
model_data_train <- scaled_ratings[which_train, ]
model_data_test <- scaled_ratings[!which_train, ]
library(randomForest)
fit = randomForest(as.factor(nrat)~., data = model_data_train[,-c(19,20)])
predictions <- predict(fit, model_data_test[,-c(19,20,21)], type="class")
cm = table(predictions,model_data_test$nrat)
(accuracy <- sum(diag(cm)) / sum(cm))
(precision <- diag(cm) / rowSums(cm))
recall <- (diag(cm) / colSums(cm))

table(predictions, model_data_test$Rating)

library(pROC)
plot.roc(as.numeric(model_data_test$nrat),as.numeric(predictions))
#create a movie rating matrix

totalMovieIds = unique(movies$MovieId)
nonratedmoviedf = function(userid){
  ratedmovies = raw_data[raw_data$UserId==userid,]$MovieId
  non_ratedmovies = totalMovieIds[!totalMovieIds %in% ratedmovies]
  df = data.frame(cbind(rep(userid),non_ratedmovies,0))
  names(df) = c("UserId","MovieId","Rating")
  return(df)
}
activeusernonratedmoviedf  = nonratedmoviedf(943)
#oneratings = merge(x = onenonratedmoviedf, y = users, by = "UserId", all.x = TRUE)
activeuserratings = merge(x = activeusernonratedmoviedf, y = movies, by = "MovieId", all.x = TRUE)

predictions <- predict(fit, activeuserratings[,-c(1:4)], type="class")
recommend = data.frame(MovieId = activeuserratings$MovieId,predictions)
recommend = recommend[which(recommend$predictions == 1),]
#predList = apply(predictions,1,function(x) if(x[1] > x[2]) return(x[1]) else return(x[2]))

################################################################################
#convert timestamp to local time
ratings_ctx = merge(x = raw_data, y = movies, by = "MovieId", all.x = TRUE)
ts = ratings_ctx$TimeStamp
hours <- as.POSIXlt(ts,origin="1960-10-01")$hour
ratings_ctx = data.frame(cbind(ratings_ctx,hours))
UCP  = ratings_ctx[(ratings_ctx$UserId == 943),][,-c(2,3,4,5)]
UCP_pref = aggregate(.~hours,UCP[,-1],sum)
UCP_pref_sc = cbind(context = UCP_pref[,1],t(apply(UCP_pref[,-1], 1, function(x)(x-min(x))/(max(x)-min(x)))))
UCP_pref_content = merge(x = recommend, y = movies, by = "MovieId", all.x = TRUE)

dim(UCP_pref_content)
dim(UCP_pref_sc)

active_user =cbind(UCP_pref_content$MovieId,(as.matrix(UCP_pref_content[,-c(1,2,3)]) %*% as.matrix(UCP_pref_sc[4,2:19])))
active_user_df = as.data.frame(active_user)
names(active_user_df) = c('MovieId','SimVal')
FinalPredicitons_943 = active_user_df[order(-active_user_df$SimVal),]

names(context_df) = c('UserId','hourOfDay')
context_matrix = table(context_df)
context_matrix_sc = t(apply(context_matrix, 1, function(x)(x-min(x))/(max(x)-min(x))))

################################################################################


# Algoritm for Donor Tangeting Challenge (UC Statistics Methods)


# Function to find nodes that can be realistically dated by the Hedman technique:
find.dateable.nodes <- function(tree, tip.ages) {

	# Requires ape library for reading tree structure:
	require(ape)

	# List all internal nodes except root:
	list.nodes <- (Ntip(tree) + 2):(Ntip(tree) + Nnode(tree))

	# Create vector to store nodes that are dateable:
	defo.nodes <- vector(mode="numeric")

	# For each node in the list:
	for(i in length(list.nodes):1) {

		# Find descendant nodes:
		descs <- tree$edge[grep(TRUE, tree$edge[, 1] == list.nodes[i]), 2]

		# If all immediate descendants are internal nodes than it cannot be dated and is removed:
		if(length(which(descs > Ntip(tree))) == length(descs)) list.nodes <- list.nodes[-i]

		# If all immediate descendants are terminal nodes than it can definitely be dated...:
		if(length(which(descs <= Ntip(tree))) == length(descs)) {

			# ...and is retained...:
			defo.nodes <- c(defo.nodes, list.nodes[i])

			# ...but can be removed from list.nodes:
			list.nodes <- list.nodes[-i]

		}

	}

	# For each internal node with both a terminal and internal node descendant:
	for(i in length(list.nodes):1) {

		# Find node age:
		node.age <- max(tip.ages[FindDescendants(list.nodes[i], tree)])

		# List its descendants:
		descs.ages <- descs <- tree$edge[grep(TRUE, tree$edge[, 1] == list.nodes[i]), 2]

		# For each descendant:
		for(j in length(descs.ages):1) {

			# If an internal node date as oldest descendant:
			if(descs[j] > Ntip(tree)) descs.ages[j] <- max(tip.ages[FindDescendants(descs[j], tree)])

			# Remove if terminal node:
			if(descs[j] <= Ntip(tree)) descs.ages <- descs.ages[-j]

		}

		# If node age is older than any descendant internal nodes:
		if(node.age > max(descs.ages)) {

			# Then can be dated so add to list:
			defo.nodes <- c(defo.nodes, list.nodes[i])

		}

	}

	# Output all dateable nodes:
	return(defo.nodes)

}

# Function that retrieves dates for use as tnodes variable in Hedman function
get.tnodes <- function(node, tree, tip.ages) {

	# Require ape library:
	require(ape)

	# Number of root node (point at which searching for ancestral nodes stops):
	root.node <- Ntip(tree) + 1

	# If the input node is the root node:
	if(node == root.node) {

		# Error and warning:
		stop("ERROR: Input node is root node - tnodes has length one!")

	# If input node is not root node:
	} else {

		# Find first ancestor node:
		internodes <- tree$edge[match(node, tree$edge[, 2]), 1]

		# As long as we have not yet reached the root:
		while(internodes[length(internodes)] != root.node) {

			# Add next internode to set:
			internodes <- c(internodes, tree$edge[match(internodes[length(internodes)], tree$edge[, 2]), 1])
		}

		# Add in original node as that is counted too!:
		internodes <- c(node, internodes)

		# Create tnodes vector for storage:
		tnodes <- vector(mode="numeric")

		# Date first (original) node:
		tnodes[1] <- max(tip.ages[FindDescendants(internodes[1], tree)])

		# For each internode:
		for(i in 2:length(internodes)) {

			# Find descendants:
			descs <- tree$edge[grep(TRUE, tree$edge[, 1] == internodes[i]), 2]

			# Remove previously dated node:
			descs <- descs[-match(internodes[(i - 1)], descs)]

			# For each other descendant:
			for(j in 1:length(descs)) {

				# If descendant node is internal:
				if(descs[j] > Ntip(tree)) {

					# Get maximum possible age:
					descs[j] <- max(tip.ages[FindDescendants(descs[j], tree)])

				# If descendant node is terminal:
				} else {

					# Get maximum possible age:
					descs[j] <- tip.ages[descs[j]]

				}

			}

			# Store in tnodes:
			tnodes[i] <- max(descs)

		}

		# Vector for storing node ages to be deleted:
		deletes <- vector(mode="numeric")

		# For each potential tnode:
		for(i in 2:length(tnodes)) {

			# Find nodes too young for dating and store in deletes:
			if(max(tnodes[1:(i-1)]) > tnodes[i]) deletes <- c(deletes, i)

		}

		# Remove these nodes (if there are any) from tnodes:
		if(length(deletes) > 0) tnodes <- tnodes[-deletes]

		# Give in order from oldest to youngest:
		tnodes <- rev(tnodes)

		# Return tnodes:
		return(tnodes)

	}

}

# Hedman (2010) method for estimating confidence given ages of ougroups (tnodes is the sequence of ages, from oldest to youngest; t0 is the arbitrary lower stratigraphic bound; resolution is the number of steps to take between the FAD and the lower stratigraphic bound):
Hedman.2010 <- function (tnodes, t0, resolution) { # Outputs estimate with two-tailed 95% CIs

    # Check t0 is older than any other node age:
    if(!all(t0 > tnodes)) stop("t0 must be older than any tnode value.")

	# Store requested resolution:
	requested.resolution <- resolution

	# Function returns p.d.f. for node ages	(t0 is an arbitrary oldest age to consider, tnodes are the ages of oldest known fossil stemming from each node, and tsteps is a vector of arbitrary time steps on which the p.d.f. is calculated):
	nodeage <- function(tsteps, tnodes, t0) {

		# Get number of outgroups (tnodes):
		nn  <- length(tnodes)

		# Get number of time steps (resolution):
		nt  <- length(tsteps)

		# Initialize array:
		pnodes  <- matrix(0, nn, nt)

		# First get pdf for node 1, at discrete values:
		ii  <- which(tsteps > t0 & tsteps < tnodes[1])

		# Assume uniform distribution for oldest node:
		pnodes[1, ii] <- 1.0 / length(ii)

		# Cycle through remaining nodes:
		for (i in 2:nn) {

			# Cycle through series of time steps:
			for (j in 1:nt) {

				# Initialize vector:
				p21  <- rep(0, nt)

				# Get p.d.f. for ith node ay discrete values:
				ii <- which(tsteps >= tsteps[j] & tsteps < tnodes[i])

				p21[ii]  <- 1.0 / length(ii) * pnodes[(i - 1), j]

				# Conditional probability of this age, given previous node age, times probability of previous node age, added to cumulative sum:
				pnodes[i, ii]  <- pnodes[i, ii] + p21[ii]

			}

		}

		# Get just the p.d.f. vector for the youngest node:
		out <- pnodes[nn, ]

		# Return output:
		return(out)

	}

	# Calculate c.d.f. from p.d.f., find median and 95% credibility limits:
	HedmanAges <- function(tnodes, t0, resolution) {

		# Store input resolution for later reuse:
		old.resolution <- resolution

		# Get uniformly spaced p-values (including 95% limits adn median) for calculating CIs:
		CIs <- sort(unique(c(0.025, 0.975, 0.5, c(1:old.resolution) * (1 / old.resolution))))

		# Get enw resolution (may be longer by adding limits and/or median):
		resolution <- length(CIs)

		# Get oldest possible age to consider:
		first <- t0

		# Get youngest possible age to consider:
		last <- min(tnodes)

		# Make tnodes negative for Hedman function:
		tnodes  <- -tnodes

		# Get uniformly spaced time steps for Hedman function:
		tsteps <- seq(-first, -last, length=resolution)

		# Make t0 negative for Hedman function:
		t0 <- -t0

		# Run Hedman function to get p.d.f.:
		vector <- nodeage(tsteps, tnodes, t0)

		# Convert from p-value scale to age scale:
		integral.vector <- vector * ((abs(first - last)) / resolution)

		# Get sum of probabilities in order to re-scale as p.d.f.:
		probability.sum <- sum(integral.vector)

		# Get re-scaled p-values for CIs:
		ps.CIs <- probability.sum * CIs

		# Cretae empty vector to store dates:
		date.distribution <- vector(mode="numeric")

		# Set initial value:
		value <- 0

		# For each re-scaled p-value:
		for(i in length(ps.CIs):1) {

			# Update value:
			value <- value + integral.vector[i]

			# If in age window:
			if(length(which(value >= ps.CIs)) > 0) {

				# Store dates:
				date.distribution <- c(date.distribution, rep(tsteps[i], length(which(value >= ps.CIs))))

				# Update re-scaled p-values:
				ps.CIs <- ps.CIs[-grep(TRUE, value >= ps.CIs)]

			}

		}

		# Add t0 at end if length is short:
		while(length(date.distribution) < resolution) date.distribution <- c(date.distribution, t0)

		# Find median of distribution:
		Best.guess <- date.distribution[CIs == 0.5]

		# Get upper 95% CI:
		Best.guess.lower <- date.distribution[CIs == 0.975]

		# Get lower 95% CI:
		Best.guess.upper <- date.distribution[CIs == 0.025]

		# Combine results and reverse sign to give palaeo ages:
		results <- list(-Best.guess, -Best.guess.lower, -Best.guess.upper, -date.distribution[match(c(c(1:old.resolution) * (1 / old.resolution)), CIs)])

		# Name subvariables:
		names(results) <- c("Best.guess", "Best.guess.lower", "Best.guess.upper", "Age.distribution")

		# Return result
		return(results)

	}

	# Get Hedman ages:
	out <- HedmanAges(tnodes, t0, resolution)

	# If Hedman ages represent less than five unique values (leading to downstream problem of flat distributions):
	while(length(unique(out$Age.distribution[round(seq(1, length(out$Age.distribution), length.out=requested.resolution))])) < 5) {

		# Double the resolution size:
		resolution <- resolution * 2

		# Get Hedman ages:
		out <- HedmanAges(tnodes, t0, resolution)

	}

	# Update output:
	out$Age.distribution <- out$Age.distribution[round(seq(1, length(out$Age.distribution), length.out=requested.resolution))]

	# Return output:
	return(out)

}

# Over-arching Hedman tree-dating function:
Hedman.tree.dates <- function(tree, tip.ages, outgroup.ages, t0, resolution = 1000, conservative = TRUE) {

# MORE CONDITIONALS NEEDED FOR WHEN RESOLUTION IS LOW

	# Load libraries:
	require(ape)
	require(strap)

    # Check tree is fully bifurcating:
    if(!is.binary.tree(tree)) stop("Tree must be fully bifurcating.")

	# Ensure tip ages are in tree tip order:
	tip.ages <- tip.ages[tree$tip.label]

	# Find root node:
	root.node <- Ntip(tree) + 1

	# Create variables to store age estimates:
	age.estimates <- matrix(nrow = Nnode(tree), ncol = 3)

	# Create variables to store age distributions:
	age.distributions <- matrix(nrow = Nnode(tree), ncol = resolution)

	# Set column headings:
	colnames(age.estimates) <- c("Best.guess", "Best.guess.lower", "Best.guess.upper")

	# Set row names:
	rownames(age.estimates) <- rownames(age.distributions) <- c((Ntip(tree) + 1):(Ntip(tree) + Nnode(tree)))

	# Vector to store outgroup sequences:
	og.seq <- vector(mode = "numeric")

	# Report progress:
	cat("Identifying nodes that are date-able using the Hedman technique_")

	# Find dateable conservative nodes:
	if(conservative) dateable.nodes <- find.dateable.nodes(tree, tip.ages)

	# Find dateable non-conservative nodes:
	if(!conservative) dateable.nodes <- c((Ntip(tree) + 1):(Ntip(tree) + Nnode(tree)))

	# Report progress:
	cat("Done\nDating nodes using Hedman technique_")

	# If not using the conservative approach:
	if(!conservative) {

		# Create ages matrix:
		ages <- cbind(tip.ages, tip.ages)

		# Add rownames:
		rownames(ages) <- names(tip.ages)

		# Add column names:
		colnames(ages) <- c("FAD", "LAD")

		# Sort by taxon order in tree:
		ages <- ages[tree$tip.label, ]

		# Date tree using basic algorithm:
		stree <- DatePhylo(tree, ages, 0, "basic", FALSE)

		# Get node ages:
		sages <- GetNodeAges(stree)

		# Set first outgroup sequence (i.e. root) as this is special case:
		og.seq[1] <- paste(c(outgroup.ages, sages[root.node]), collapse = "%%")

		# For each non-root node:
		for(i in 2:length(dateable.nodes)) {

			# Identify node:
			node <- dateable.nodes[i]

			# Find preceding node:
			internodes <- tree$edge[match(node, tree$edge[, 2]), 1]

			# Keep going until we reach the root and add next internode to set:
			while(internodes[length(internodes)] != root.node) internodes <- c(internodes, tree$edge[match(internodes[length(internodes)], tree$edge[, 2]), 1])

			# Collate nodes and put in order:
			internodes <- sort(c(node, internodes))

			# Find outgroup age sequence and collaspe to single string and store:
			og.seq[i] <- paste(c(outgroup.ages, sages[internodes]), collapse="%%")

		}

	# If using the conservative approach:
	} else {

		# Find age estimates for each dateable node:
		for(i in 1:length(dateable.nodes)) {

			# Find tnodes for a specific node:
			tnodes <- get.tnodes(dateable.nodes[i], tree, tip.ages)

			# Add additional outgroup tnodes:
			tnodes <- c(outgroup.ages, tnodes)

			# Turn outgroup sequence into single string and store:
			og.seq[i] <- paste(tnodes, collapse="%%")

		}

	}

	# Get unique outgroup sequences:
	unq.og.seq <- unique(og.seq)

	# For each unique outgroup sequence:
	for(i in 1:length(unq.og.seq)) {

		# List nodes with this outgroup sequence:
		nodes <- dateable.nodes[which(og.seq == unq.og.seq[i])]

		# Define tnodes:
		tnodes <- as.numeric(strsplit(unq.og.seq[i], "%%")[[1]])

		# Get Hedman dates:
		hedman.out <- Hedman.2010(tnodes = tnodes, t0 = t0, resolution = resolution)

		# Update age distributions:
        for(j in 1:length(nodes)) age.distributions[as.character(nodes[j]), ] <- hedman.out$Age.distribution

	}

	# Separate check to see if root is dateable (first find root descendants that are tips, if any):
	root.desc.tips <- sort(tree$tip.label[tree$edge[which(root.node == tree$edge[, 1]), 2]])

	# Now check that there are descendants that are tips:
	if(length(root.desc.tips) > 0) {

		# Get maximum root descendant age:
		root.tip.age <- max(tip.ages[root.desc.tips])

		# Now check that descendants are older than any other tips and get Hedman dates for root and update age distributions:
		if(root.tip.age > max(tip.ages[setdiff(tree$tip.label, root.desc.tips)])) age.distributions[as.character(root.node), ] <- Hedman.2010(tnodes = c(outgroup.ages, root.tip.age), t0 = t0, resolution = resolution)$Age.distribution

	}

	# If not using the conservative approach:
	if(conservative == FALSE) {

		# Report progress:
		cat("Done\nIdentifying remaining undated nodes_")

		# Report progress:
		cat("Done\nDating remaining undated nodes using randomisation technique_")

	# If using the conservative approach:
	} else {

		# Report progress:
		cat("Done\nIdentifying remaining undated nodes_")

		# Find undated nodes by first establishing actually dated nodes:
		dated.nodes <- sort(dateable.nodes)

		# List all internal nodes:
		all.nodes <- (Ntip(tree) + 1):(Ntip(tree) + Nnode(tree))

		# Get undated nodes:
		undated.nodes <- setdiff(all.nodes, dated.nodes)

		# Find branches that define undated nodes:
		internal.branches <- tree$edge[which(tree$edge[, 2] > Ntip(tree)), ]

		# Is root dated? (default to "yes" before actually checking):
		root.dated <- "Yes"

		# If the root is undated (then it needs to be):
		if(is.na(match(root.node, dated.nodes))) {

			# Update root.dated:
			root.dated <- "no"

			# Create tnodes from outgroup ages ONLY (this will later be used to constrain the root age through the saem randomisation process as the other undated nodes):
			tnodes <- outgroup.ages

			# Date root node:
			hedman.out <- Hedman.2010(tnodes = tnodes, t0 = t0, resolution = resolution)

			# Add to age estimates:
			age.estimates <- rbind(age.estimates, c(hedman.out$Best.guess, hedman.out$Best.guess.lower, hedman.out$Best.guess.upper))

			# Add to age distributions:
			age.distributions <- rbind(age.distributions, hedman.out$Age.distribution)

			# Add node name 0:
			rownames(age.estimates)[length(rownames(age.estimates))] <- rownames(age.distributions)[length(rownames(age.distributions))] <- "0"

		}

		# Vector for storing strings of sequences of undated node(s) bound by dated nodes:
		anc.strings.trimmed <- anc.strings <- vector(mode = "character")

		# Work through dated nodes to find sequences of undated nodes bracketed by them:
		for(i in 1:length(dated.nodes)) {

			# As long as the dated node is not the root (which has no ancestors):
			if(dated.nodes[i] != root.node) {

				# Get ancestors:
				ancestors <- internal.branches[which(internal.branches[, 2] == dated.nodes[i]), 1]

				# As long as the ancestor is neither the root or a dated node:
				if(ancestors != root.node && length(sort(match(ancestors, dated.nodes))) == 0) {

					# And as long as it remains so find next ancestral node:
					while(ancestors[length(ancestors)] != root.node && length(sort(match(ancestors[length(ancestors)], dated.nodes))) == 0) ancestors <- c(ancestors, internal.branches[match(ancestors[length(ancestors)], internal.branches[, 2]), 1])

				}

				# Add initial dated node:
				ancestors <- c(dated.nodes[i], ancestors)

				# Only need retain those with at least one undated node between dated nodes:
				if(length(ancestors) > 2) {

					# Add to ancestor strings:
					anc.strings <- c(anc.strings, paste(ancestors, collapse = " "))

					# Add to trimmed ancestor strings:
					anc.strings.trimmed <- c(anc.strings.trimmed, paste(ancestors[2:(length(ancestors) - 1)], collapse = " "))

				}

			}

		}

		# If root is undated then anc.strings with the root present must be modified to include node 0 at the end:
		if(root.dated == "no") {

			# Go through each anc.string:
			for(i in 1:length(anc.strings)) {

				# Get ancestors vector:
				ancestors <- as.numeric(strsplit(anc.strings[i], " ")[[1]])

				# If last node is the root:
				if(ancestors[length(ancestors)] == root.node) {

					# Add 0 node to end:
					ancestors <- c(ancestors, 0)

					# Re-store in anc.strings:
					anc.strings[i] <- paste(ancestors, collapse = " ")

				}

			}

		}

		# Find oldest node from each ancestral sequence (first set up empty vector):
		oldest.nodes <- vector(mode="numeric")

		# Go through each anc.string:
		for(i in 1:length(anc.strings)) {

			# Get ancestors vector:
			ancestors <- as.numeric(strsplit(anc.strings[i], " ")[[1]])

			# Store oldest node:
			oldest.nodes <- c(oldest.nodes, ancestors[length(ancestors)])

		}

		# Collapse to unique oldest nodes only:
		oldest.nodes <- sort(unique(oldest.nodes))

		# Clump anc.strings by shared oldest node (i.e. blocks that will be dated at the same time) - first create empty vector:
		clumped.anc.strings <- vector(mode="character")

		# For each oldest node find anc.strings with oldest node and collapse with %%:
		for(i in 1:length(oldest.nodes)) clumped.anc.strings <- c(clumped.anc.strings, paste(anc.strings[grep(paste(" ", oldest.nodes[i], sep = ""), anc.strings)], collapse = "%%"))

		# Report progress:
		cat("Done\nDating remaining undated nodes using randomisation technique_")

		# Can now date undated nodes using random draws from bounding Hedman dated nodes:
		for(i in 1:length(clumped.anc.strings)) {

			# First retrieve anc.strings with shared oldest node:
			anc.strings <- strsplit(clumped.anc.strings[i], "%%")[[1]]

			# Get young dated nodes (for drawing from for upper bounds):
			young.dated.nodes <- vector(mode="numeric")

			# For each ancestor string find youngest dated node, i.e., lower bounds::
			for(j in 1:length(anc.strings)) young.dated.nodes <- c(young.dated.nodes, as.numeric(strsplit(anc.strings[j], " ")[[1]][1]))

			# Get age distributions for young dated nodes:
			young.distributions <- age.distributions[as.character(young.dated.nodes), ]

			# Force into a single row matrix if only a vector:
			if(!is.matrix(young.distributions)) young.distributions <- t(as.matrix(young.distributions))

			# Set young distribution half up from young distributions:
			young.distributions.old.half <- young.distributions

			# Get old half as age distributions for young dated nodes:
			for(j in 1:length(apply(young.distributions, 1, median))) {

				# As long as the median is not the maximum:
				if(max(young.distributions[j, ]) > median(young.distributions[j, ])) {

					# Split distribution into older half using median:
					temp.distribution <- young.distributions[j, which(young.distributions[j, ] > median(young.distributions[j, ]))]

				# If the median is the maximum:
				} else {

					# Just use the maximum:
					temp.distribution <- max(young.distributions[j, ])

				}

				# ???:
				young.distributions.old.half[j, ] <- c(temp.distribution, rep(NA, length(young.distributions[j, ]) - length(temp.distribution)))

			}

			# Get old dated node (for drawing from for lower bounds):
			old.dated.node <- as.numeric(strsplit(anc.strings[1], " ")[[1]][length(strsplit(anc.strings[1], " ")[[1]])])

			# Get age distributions for old dated node:
			old.distribution <- age.distributions[as.character(old.dated.node), ]

			# As long as the median is not the minimum:
			if(min(old.distribution) < median(old.distribution)) {

				# Split distribution using median:
				old.distribution.young.half <- old.distribution[which(old.distribution < median(old.distribution))]

			# If the median is the minimum:
			} else {

				# Just use the minimum:
				old.distribution.young.half <- min(old.distribution)

			}

			# Get undated nodes (vector for storing output):
			undated.nodes <- vector(mode="numeric")

			# For each anc.string:
			for(j in 1:length(anc.strings)) {

				# Get ancestors:
				ancestors <- strsplit(anc.strings[j], " ")[[1]]

				# Store undated nodes:
				undated.nodes <- c(undated.nodes, as.numeric(ancestors[2:(length(ancestors) - 1)]))

			}

			# Collapse to unique nodes only:
			undated.nodes <- sort(unique(undated.nodes))

			# Find young constraints for each undated node (vector for storing results):
			young.constraints <- vector(mode = "numeric")

			# For each undated node add young constraints to list:
			for(j in 1:length(undated.nodes)) young.constraints <- c(young.constraints, paste(young.dated.nodes[grep(paste(" ", undated.nodes[j], sep = ""), anc.strings)], collapse = " "))

			# Find old constraints for each undated node (i.e. all nodes that are lower in tree as these will potentially be dated first and replace the current oldest age; vector for storing results):
			old.constraints <- vector(mode="numeric")

			# For each undated node:
			for(j in 1:length(undated.nodes)) {

				# Get just anc.strings where undated node is present:
				node.strings <- anc.strings[grep(paste(" ", undated.nodes[j], sep=""), anc.strings)]

				# Vector for storing older nodes:
				older.nodes <- vector(mode="numeric")

				# For each anc.string where the undated node exists ?????:
				for(k in 1:length(node.strings)) older.nodes <- c(older.nodes, as.numeric(strsplit(strsplit(node.strings[k], undated.nodes[j])[[1]][2], " ")[[1]]))

				# ????:
				old.constraints <- c(old.constraints, paste(unique(sort(older.nodes)), collapse=" "))

			}

			# Find undated nodes constrained by dated nodes (vector for storage):
			young.dated.nodes.constrain <- vector(mode = "character")

			# For each young dated node constraint find undated nodes which it contrains:
			for(j in 1:length(young.dated.nodes)) young.dated.nodes.constrain[j] <- paste(as.numeric(strsplit(anc.strings[j], " ")[[1]][2:(length(strsplit(anc.strings[j], " ")[[1]]) - 1)]), collapse = " ")

			# Main dating loop (repeats random draw N times, where N is defined by the variable resolution):
			for(j in 1:resolution) {

				# Modify age distributions used if medians of undated nodes exceed bounds of medians of dated nodes (needs to have been at least two entries already):
				if(j >= 3 && j >= floor(resolution / 2)) {

					# If there is more than one undated node establish present medians for undated nodes:
					if(length(undated.nodes) > 1) undated.medians <- apply(age.distributions[as.character(undated.nodes), 1:(j - 1)], 1, median)

					# If there is only one undated node
					if(length(undated.nodes) == 1) {

						# Establish present median of undated node:
						undated.medians <- median(age.distributions[as.character(undated.nodes), 1:(j - 1)])

						# Add name for reference later:
						names(undated.medians) <- as.character(undated.nodes)

					}

					# Case if oldest median of the undated nodes exceeds the median of the bounding old dated node:
					if(max(undated.medians) >= median(sort(old.distribution))) {

						# Update active distribution with older half only (to force undated nodes towards median ages consistent with dated nodes):
						active.old.distribution <- old.distribution.young.half

					# If oldest median ages do not conflict:
					} else {

						# Draw from full distribution:
						active.old.distribution <- old.distribution

					}

					# Set default active young distributions:
					active.young.distributions <- young.distributions

					# For each young (top bounding) dated node:
					for(k in 1:length(young.dated.nodes)) {

						# Case if youngest median of the undated nodes exceeds the median of the bounding young dated node - update active distribution with younger half only (to force undated nodes towards median ages consistent with dated nodes):
						if(min(undated.medians[strsplit(young.dated.nodes.constrain[k], " ")[[1]]]) <= median(sort(age.distributions[as.character(young.dated.nodes[k]), ]))) active.young.distributions[k, ] <- young.distributions.old.half[k, ]

					}

				# Case if still in first half of resolution:
				} else {

					# Use uncorrected distribution for upper bound:
					active.old.distribution <- old.distribution

					# Use uncorrected distributions for lower bound:
					active.young.distributions <- young.distributions

				}

				# Special case of last iteration where we want to ensure we draw a date between the constraining medians:
				if(j == resolution) {

					# Set old distribution to young half only:
					active.old.distribution <- old.distribution.young.half

					# Set default active young distributions:
					active.young.distributions <- young.distributions

					# For each young (top bounding) dated node set all young distribution to old half only:
					for(k in 1:length(young.dated.nodes)) active.young.distributions[k, ] <- young.distributions.old.half[k, ]

				}

				# Modify young and old distributions to remove tails which will always violate node order (young node older than old node and vice versa) to speed up the random draw step below; if part of young distributions are older than the oldest part of the old distribution:
				if(max(sort(as.vector(active.young.distributions))) >= max(sort(active.old.distribution))) {

					# Find oldest part of old distribution
					upper.limit <- max(sort(active.old.distribution))

					# ????:
					active.young.distributions[which(active.young.distributions >= upper.limit)] <- NA

				}

				# Vector to store young distribution minima:
				active.young.distribution.mins <- vector(mode="numeric")

				# For each young node store minima:
				for(k in 1:length(active.young.distributions[, 1])) active.young.distribution.mins <- c(active.young.distribution.mins, min(sort(active.young.distributions[k, ])))

				# If part of old distribution is younger than the youngest part of the youngest young distribution:
				if(min(sort(active.old.distribution)) <= min(active.young.distribution.mins)) {

					# Find lower limit (minimum of minima):
					lower.limit <- min(active.young.distribution.mins)

					# Remove values less than or equal to the lower limit from the old distribution:
					active.old.distribution <- active.old.distribution[grep(FALSE, active.old.distribution <= lower.limit)]

				}

				# Draw upper and lower bounds at random from old and young nodes:
				young.random.ages <- vector(mode="numeric")

				# For each young node draw a random age from its distributon:
				for(k in 1:length(young.dated.nodes)) young.random.ages <- c(young.random.ages, sort(active.young.distributions[k, ])[ceiling(runif(1, 0, length(sort(active.young.distributions[k, ]))))])

				# Repeat for old age:
				old.random.age <- sort(active.old.distribution)[ceiling(runif(1, 0, length(sort(active.old.distribution))))]

				# Ensure old node is older than all young nodes; while old node is younger or equal in age to oldest young nodes:
				while(old.random.age <= max(young.random.ages)) {

					# Re-draw ages as above:
					young.random.ages <- vector(mode="numeric")

					# For each young node draw a random age from its distributon:
					for(k in 1:length(young.dated.nodes)) young.random.ages <- c(young.random.ages, sort(active.young.distributions[k, ])[ceiling(runif(1, 0, length(sort(active.young.distributions[k, ]))))])

					# Repeat for old age:
					old.random.age <- sort(active.old.distribution)[ceiling(runif(1, 0, length(sort(active.old.distribution))))]

				}

				# Need to add names so can extract data later:
				names(young.random.ages) <- young.dated.nodes

				# Find oldest (i.e. constraining) young node for each undated node (vector for storing output):
				young.constraints.node <- young.constraints.age <- vector(mode="numeric")

				# For each undated node:
				for(k in 1:length(undated.nodes)) {

					# Store young age:
					young.constraints.age <- c(young.constraints.age, max(young.random.ages[strsplit(young.constraints[k], " ")[[1]]]))

					# Store young node:
					young.constraints.node <- c(young.constraints.node, as.numeric(names(young.random.ages[strsplit(young.constraints[k], " ")[[1]]])[which(young.random.ages[strsplit(young.constraints[k], " ")[[1]]] == max(young.random.ages[strsplit(young.constraints[k], " ")[[1]]]))[1]]))

				}

				# Vector for storing node dates:
				node.dates <- rep(NA, length(undated.nodes))

				# Date undated nodes using randomisation process:
				for(k in 1:length(unique(young.constraints.node)) ) {

					# Find top.node:
					top.node <- unique(young.constraints.node)[k]

					# Find target (.e. undated) nodes:
					target.nodes <- undated.nodes[which(young.constraints.node == top.node)]

					# Find bounding dates (potential old constraints):
					old.constraining.nodes <- as.numeric(sort(unique(strsplit(paste(old.constraints[match(target.nodes, undated.nodes)], collapse=" "), " ")[[1]])))

					# Remove any target nodes present
					if(length(sort(match(target.nodes, old.constraining.nodes))) > 0) old.constraining.nodes <- old.constraining.nodes[-sort(match(target.nodes, old.constraining.nodes))]

					# Find youngest old node as actual constraint:
					old.constraining.node <- max(old.constraining.nodes)

					# If lower bound is the previously dated old node:
					if(old.constraining.node == old.dated.node) {

						# Use that as maximum limit
						max <- old.random.age

					# If lower bound is a previously undated node:
					} else {

						# Use that as maximum limit
						max <- node.dates[match(old.constraining.node, undated.nodes)]

					}

					# Set minimum age:
					min <- young.random.ages[as.character(top.node)]

					# Get node dates:
					node.dates[match(target.nodes, undated.nodes)] <- sort(runif(length(target.nodes), min = min, max = max), decreasing = TRUE) # Draw node ages from bounding minima and maxima

				}

				# Store results:
				age.distributions[as.character(undated.nodes), j] <- node.dates

			}

		}

		# Can now remove node "0" (i.e., if root is undated by Hedman method) if present:
		if(root.dated == "no") {

			# Remove zero node from distributions:
			age.distributions <- age.distributions[-which(rownames(age.distributions) == "0"), ]

			# Remove zero node from estimates:
			age.estimates <- age.estimates[-which(rownames(age.estimates) == 0), ]

		}

	}

	# Report progress:
	cat("Done\nTidying up and returning results_")

	# Create vector of nodes estimated using Hedman method:
	Hedman.estimated <- rep(1, length(rownames(age.estimates)))

	# Update those not estimated using Hedman method:
	if(conservative == TRUE) Hedman.estimated[match(setdiff(rownames(age.estimates), dateable.nodes), rownames(age.estimates))] <- 0

	# Add to age estimates:
	age.estimates <- cbind(age.estimates, Hedman.estimated)

	# Sort age distributions in advance of picking confidence intervals:
	age.distributions <- t(apply(age.distributions, 1, sort))

	# Add median values to age estimates:
	age.estimates[, "Best.guess"] <- apply(age.distributions, 1, median)

	# Add upper CI to age estimates:
	age.estimates[, "Best.guess.upper"] <- age.distributions[, ceiling(0.975 * resolution)]

	# Add lower CI to age estimates:
	age.estimates[, "Best.guess.lower"] <- age.distributions[, max(c(1, floor(0.025 * resolution)))]

	# Create vectors to store node ages for each branch:
	to.ages <- from.ages <- age.estimates[match(tree$edge[, 1], rownames(age.estimates)), "Best.guess"]

	# Get to ages for terminal branches:
	to.ages[which(tree$edge[, 2] <= Ntip(tree))] <- tip.ages[tree$edge[which(tree$edge[, 2] <= Ntip(tree)), 2]]

	# Get to ages for internal branches:
	to.ages[which(tree$edge[, 2] > Ntip(tree))] <- age.estimates[match(tree$edge[which(tree$edge[, 2] > Ntip(tree)), 2], rownames(age.estimates)), "Best.guess"]

	# Update tree with branch lengths scaled to time using median ages:
	tree$edge.length <- from.ages-to.ages

	# Update tree to include root time:
	tree$root.time <- age.estimates[as.character(root.node), "Best.guess"]

	# Collate results:
	results <- list(age.estimates, age.distributions, tree)

	# Add names:
	names(results) <- c("age.estimates", "age.distributions", "tree")

	# Repprt progress
	cat("Done")

	# Return output:
	return(results)

}

Evolutionary rates analysis (Fig 5d-e and Supplementary Fig 2-4)/cal3/Hedman_functions.r


library(ggvis)
library(ggplot2)
library(ggthemes)

data("cocaine")
head(cocaine)

ggplot(cocaine, aes(x=weight, y=price)) + geom_point()

cocaine %>% ggvis(x=~weight, y=~price) %>% layer_points()
cocaine %>% ggvis(x=~weight, y=~price, fill=~potency) %>% layer_points()
cocaine %>% ggvis(x=~weight, y=~price, stroke=~potency) %>% layer_points()
cocaine %>% ggvis(x=~weight, y=~price, fill:="green", stroke:="white") %>% layer_points()

cocaine %>% ggvis(x=~weight, y=~price, fill=~potency) %>% layer_points() %>% layer_smooths()
#interactive buttons
cocaine %>% ggvis(~weight, ~price, fill=~potency, size:=input_slider(10,100),
                  opacity:=input_slider(0,1)) %>% layer_points()

ggplot(cocaine,aes(x=price)) + geom_histogram()
cocaine %>% ggvis(~price) %>% layer_histograms()

#rCharts
#ramnathv.github.io/rCharts
library(devtools)
install_github("rCharts", "ramnathv")
library(rCharts)
head(iris)
names(iris) <- gsub("\\.","",names(iris))
head(iris)
rPlot(SepalLength ~ SepalWidth | Species, color = "Species", type = "point", data = iris)

hairEye <- as.data.frame(HairEyeColor)
head(hairEye)
rPlot(Freq ~ Hair | Eye, color = "Eye", type = "bar", data = hairEye)

data(economics, package = "ggplot2")
head(economics)
tail(economics)
economics$date <- as.character(economics$date)
head(economics)

m1 <- mPlot(x="date", y=c("psavert", "uempmed"), type ="line", data = economics)
m1$set(pointSize=0, linewidth=1)
m1

map1 <- Leaflet$new()
map1$setView(c(51.505, -.09), zoom =13)
map1


#' Plot factors by week for a range of weeks
#'
#' Generate a single plot of seasonal factors by week for a range of weeks
#'
#' @param this_sf Numeric vector of seasonal factors.
#' @param this_week Numeric vector; Week of the year to match.
#' @param first_week Numeric scalar; First week to be included in the plot.
#' @param last_week Numeric scalar; Last week to be included in the plot.
#' @param forecast Numeric scalar; Number of forecasts. Default: 0.
#' @param this_range Numeric scalar; Range of the seasonal factors to be plotted. Default: range taken from the observations being plotted.
#' @param this_trans Logical scalar; set to TRUE if the log transformation is used in the decomposition, FALSE otherwise. Default: TRUE
#' @return Generate a plot of seasonal factors by week. User can specify limits for the weeks plotted in order to generate a multi-panel plot.
#' @examples
#' par(mfrow = c(3, 2), mar = c(3.1, 2.1, 0.5, 0.5), oma = c(0, 0, 3, 0))
#' sf_range <- range(ic_sf)
#' plot_sf_weekly_single(ic_sf, this_week = ic_week,
#'                       first_week = 1,  last_week = 9,
#'                       forecast = 0, this_range = sf_range,
#'                       this_trans = FALSE)
#' plot_sf_weekly_single(ic_sf, this_week = ic_week,
#'                       first_week = 10, last_week = 18,
#'                       forecast = 0, this_range = sf_range,
#'                       this_trans = FALSE)
#' plot_sf_weekly_single(ic_sf, this_week = ic_week,
#'                       first_week = 19, last_week = 27,
#'                       forecast = 0, this_range = sf_range,
#'                       this_trans = FALSE)
#' plot_sf_weekly_single(ic_sf, this_week = ic_week,
#'                       first_week = 28, last_week = 36,
#'                       forecast = 0, this_range = sf_range,
#'                       this_trans = FALSE)
#' plot_sf_weekly_single(ic_sf, this_week = ic_week,
#'                       first_week = 37, last_week = 45,
#'                       forecast = 0, this_range = sf_range,
#'                       this_trans = FALSE)
#' plot_sf_weekly_single(ic_sf, this_week = ic_week,
#'                       first_week = 46, last_week = 53,
#'                       forecast = 0, this_range = sf_range,
#'                       this_trans = FALSE)
#' @import stats
#' @import graphics
#' @export
plot_sf_weekly_single <- function(this_sf, this_week, first_week, last_week, forecast = 0, this_range = NULL, this_trans = TRUE) {
    # Author: Brian C. Monsell (OEUS), Version 2.4, 3/24/2021

    # generate number of seasonal factors not including forecasts
    len_sf <- length(as.numeric(this_sf)) - forecast

    # put estimated seasonal factors in vector sf
    sf <- this_sf[1:len_sf]

    # generate range of estimated seasonal factors
    if (is.null(this_range)) {
        y_limit <- range(sf)
    } else {
        y_limit <- this_range
    }

    # generate range of weeks for the x-axis of the plot, number of plots
    x_limit <- seq(first_week - 1, last_week + 1)
    num_plots <- last_week - first_week + 1

    # generate assumed mean of seasonal factors
    if (this_trans) {
        h_bar <- 1
    } else {
        h_bar <- 0
    }

    # create the plotting frame, with custom x-axis and create reference line for factor mean.
    plot(x_limit, seq(y_limit[1], y_limit[2], length.out = length(x_limit)), type = "n", ylim = y_limit,
        xlab = " ", ylab = " ", xaxt = "n")
    axis(1, at = first_week:last_week)
    abline(h = h_bar, col = "grey", lty = 2)

    # create vector for factor mean.
    this_mu <- array(h_bar, num_plots)

    # loop through each week.
    for (i in first_week:last_week) {

        # produce limits for week plot.
        s1 <- (i - 1) + 0.6
        s2 <- i + 0.4

        this_i <- i - first_week + 1

        # save seasonal factors for week i, and generate number of factors.
        this_sf <- sf[this_week == i]
        number_sf <- length(this_sf)

        # Generate X values for week i, mean of SF for week i
        this_period_x <- seq(s1, s2, length.out = number_sf)
        this_mu[this_i] <- mean(this_sf)

        # Generate line for mean of SF for week i
        segments(s1, this_mu[this_i], s2, this_mu[this_i], col = "green")

        # Plot SF for week i
        lines(this_period_x, this_sf, col = "blue")

    }

    # Join seasonal subplots with grey line
    lines(first_week:last_week, this_mu, col = "grey", lty = 3)

}