#' ---
#' title: "Module 3 examples - R code"
#' author: " "
#' date: "September 2019"
#' ---
#' Examples illustrating the over-sampling of some demographic groups and demonstrating the importance of using weights in analyses

# Load required packages
#+ message = FALSE, warning=FALSE
library(survey)
library(dplyr)
#'

# Display Version Information
cat("R package versions:\n")
for (p in c("base", "survey","dplyr")) {
  cat(p, ": ", as.character(packageVersion(p)), "\n")
}

#' # Data preparation
#' ## Download & Read SAS Transport Files

# function to download the required survey cycles for a component file
downloadNHANES <- function(fileprefix){
  print (fileprefix)
  outdf <- data.frame(NULL)
  for (j in 1:length(letters)){
    urlstring <- paste('https://wwwn.cdc.gov/nchs/nhanes/',yrs[j],'/',fileprefix,letters[j],'.XPT', sep='')
    download.file(urlstring, tf <- tempfile(), mode="wb")
    tmpframe <- foreign::read.xport(tf)
    outdf <- bind_rows(outdf, tmpframe)
  }
  return(outdf)
}

# Specify the survey cycles required, with corresponding file suffixes
yrs <- c('2015-2016')
letters <- c('_i')

# Download data for each component
# Demographic (DEMO)
DEMO <- downloadNHANES('DEMO')
# BPX blood pressure exam
BPX <-  downloadNHANES('BPX')
# BPQ blood pressure questionnaire
BPQ <-  downloadNHANES('BPQ')

# Merge component files
# Keep all records in DEMO, even if that SEQN does not match to BPQ or BPX files
one_tmp <- left_join(DEMO, select(BPX, "SEQN", starts_with("BPXSY"), starts_with("BPXDI")), by="SEQN") %>%
  left_join(., select(BPQ, "SEQN", "BPQ050A") , by="SEQN")

#' ## Create derived analysis variables (using dplyr functions)
df <- mutate(one_tmp,
              # create indicator for overall summary
              one = 1,
              # Hypertension prevalence
              # Count Number of Nonmissing SBPs & DBPs
              n_sbp=rowSums(!is.na(select(one_tmp, starts_with("BPXSY")))),
              n_dbp=rowSums(!is.na(select(one_tmp, starts_with("BPXDI"))))) %>%
              # Set DBP Values Of 0 To Missing For Calculating Average
       mutate_at(vars(starts_with("BPXDI")), list(~na_if(., 0))) %>%
       mutate(
              #  Calculate Mean Systolic and Diastolic (over non-missing values)
              mean_sbp=rowMeans(select(., starts_with("BPXSY")), na.rm=TRUE),
              mean_dbp=rowMeans(select(., starts_with("BPXDI")), na.rm=TRUE),
              # Create 0/1 indicator for hypertension
              # "Old" Hypertensive Category variable: taking medication or measured BP > 140/90
              #   as used in NCHS Data Brief No. 289
              # Variable bpq050a: now taking prescribed medicine for hypertension, 1 = yes
              htn_old=case_when( mean_sbp>=140 | mean_dbp>=90 | BPQ050A ==1 ~ 1,
                                n_sbp > 0 & n_dbp > 0 ~ 0),
              # for reference: "new" definition of hypertension prevalence, based on taking medication or measured BP > 130/80
              # From 2017 ACC/AHA hypertension guidelines
              # Not used in Data Brief No. 289
              htn_new=case_when( mean_sbp>=130 | mean_dbp>=80 | BPQ050A ==1 ~ 1,
                                 n_sbp > 0 & n_dbp > 0 ~ 0),
              # Create race and Hispanic ethnicity categories for oversampling analysis
              # combined Non-Hispanic white and Non-Hispanic other and multiple races, to approximate the sampling domains
              race1 = factor(c(3, 3, 4, 1, NA, 2, 4)[RIDRETH3],
                     labels = c('NH Black','NH Asian', 'Hispanic', 'NH White and Other')),
              # Create race and Hispanic ethnicity categories for hypertension analysis
              raceEthCat= factor(c(4, 4, 1, 2, NA, 3, 5)[RIDRETH3],
                                 labels = c('NH White', 'NH Black', 'NH Asian', 'Hispanic', 'NH Other/Multiple')),
              # Create age categories for adults aged 18 and over: ages 18-39, 40-59, 60 and over
              ageCat_18 = cut(RIDAGEYR,
                               breaks = c(17, 39, 59, Inf),
                               labels = c('18-39','40-59','60+')),
              #  Define subpopulation of interest: non-pregnant adults aged 18 and over who have at least 1 valid systolic OR diastolic BP measure
              inAnalysis= (RIDAGEYR >=18 & ifelse(is.na(RIDEXPRG), 0, RIDEXPRG) != 1 & (n_sbp > 0 | n_dbp > 0))
              )

#' ***
#'
#' # Estimates for graph - Distribution of race and Hispanic origin, NHANES 2015-2016
#' Module 3, Examples Demonstrating the Importance of Using Weights in Your Analyses
#' Section "Adjusting for oversampling"

#' Proportion of unweighted interview sample
df %>% count(race1) %>%
      mutate(prop= round(n / sum(n)*100, digits=1))

#' Proportion of weighted interview sample
df %>% count(race1, wt=WTINT2YR) %>%
       mutate(prop= round(n / sum(n)*100, digits=1))

#' Proportion of US population
# Input population totals from the American Community Survey, 2015-2016
# available on the NHANES website: https://wwwn.cdc.gov/nchs/nhanes/responserates.aspx#population-totals
# counts from tab "Both" (for both genders), total row (for all ages)

data.frame(group=c('Non-Hispanic White and Other', 'Non-Hispanic Black', 'Non-Hispanic Asian', 'Hispanic'), n=c(194849491+10444206, 38418696, 17018259, 55750392 )) %>%
  mutate(prop = round(n / sum(n)* 100, digits=1))

#' ***
#'
#' # Comparison of weighted and unweighed estimates for hypertension, NHANES 2015-2016
#' Module 3, Examples Demonstrating the Importance of Using Weights in Your Analyses
#' Section "Why weight?"
#'

#' ## Prevalence of hypertension among adults aged 18 and over, overall and by race and Hispanic origin group

#' ### Unweighted estimates
#' Unweighted estimate - for adults aged 18 and over
df %>% filter(inAnalysis==1) %>% summarize(mean=round(mean(htn_old)*100, digits=1))

#' Unweighted estimate - for adults aged 18 and over, by race and Hispanic origin
df %>% filter(inAnalysis==1 ) %>% group_by(raceEthCat) %>% summarize(mean=mean(htn_old)*100, n=n())

#' ### Weighted estimates

#' ## **WARNING**
#' The following commands are intended to demonstrate the importance of using the sample weight in your analyses.
#' The weighted estimate produces the correct **point estimates** for the prevalence of hypertension.
#' However, your analysis must account for the complex survey design of NHANES (e.g. stratification and clustering),
#'   in order to produce correct **standard errors** (and confidence intervals, statistical tests, etc.).
#' Do not use this step as a model for producing your own analyses!
#' See the Continuous NHANES tutorial Module 4: Variance Estimation for a complete explanation of how to properly account
#'    for the complex survey design using commands in the "survey" package
#'
#'
#' Weighted estimates - for adults aged 18 and over
df %>% filter(inAnalysis==1) %>% summarize(mean=round(weighted.mean(htn_old, WTMEC2YR)*100, digits=1))

#' Weighted estimate - for adults aged 18 and over, by race and Hispanic origin
df %>% filter(inAnalysis==1 ) %>% group_by(raceEthCat) %>% summarize(mean=weighted.mean(htn_old, WTMEC2YR)*100)

#' ## Example of how to use the survey package to estimate the prevalence of hypertension, with correct standard errors
#' See Module 4: Variance Estimation for details
# Define survey design for overall dataset
NHANES_all <- svydesign(data=df, id=~SDMVPSU, strata=~SDMVSTRA, weights=~WTMEC2YR, nest=TRUE)

# Create a survey design object for the subset of interest
# Subsetting the original survey design object ensures we keep the design information about the number of clusters and strata
NHANES <- subset(NHANES_all, inAnalysis==1)

#' Proportion and standard error, for adults aged 18 and over
svyby(~htn_old, ~one, NHANES, svymean) %>% mutate(htn_old = round(htn_old*100, digits=1), se=round(se*100, digits=1))

#' Proportion and standard error, for adults aged 18 and over by race and Hispanic origin
svyby(~htn_old, ~raceEthCat, NHANES, svymean) %>% mutate(htn_old = round(htn_old*100, digits=1), se=round(se*100, digits=1))

#' ***

#' ## Age distribution among Hispanic adults, weighted and unweighted
#' To support the statement in the tutorial text that the unweighted estimate over-represents Hispanic adults aged 60 and over,
#' compared with their actual share of the Hispanic adult population.
#'

#' ### Unweighted age distribution among Hispanic adults in the analysis
df %>% filter(inAnalysis==1 & raceEthCat=='Hispanic') %>%
      count(ageCat_18) %>%
      mutate(prop= round(n / sum(n)*100, digits=1))
#' Unweighted, Hispanic adults aged 60 and over comprise 33% of Hispanic adults in the analysis sample.
#'
#' ### Weighted age distribution among Hispanic adults in the analysis population
df %>% filter(inAnalysis==1 & raceEthCat=='Hispanic') %>% count(ageCat_18, wt=WTMEC2YR) %>%
  mutate(prop= round(n / sum(n)*100, digits=1))
#' When properly weighted, Hispanic adults aged 60 and over comprise 15% of Hispanic adults in the US non-institutionalized civilian population

[Data] NHANES) Tutorial 0 download/module3_examples_R.r


#--------------------------------------------------------------------#
# Analysis of dataset from Heller & Goldrick (2014)
# As reported in Keshet, Adi, Cibelli, Gustafson, Clopper, & Goldrick

# Note on terminology -
# Terms for the algorithmic methods in this code are different than
# those used in the paper. Their correspondences are:
# HMM = Penn/FAVE (forced aligner)
# DLM = SED (structured prediction)
# DLM (no classifier) = SEDNC (structured prediction, no classifier)
#-------------------------------------------------------------------#

# Regression analysis package
library(lme4)

# lme convenience function
# Extracts estimated chi-sq stats p-values for each fixed effect
# To be used with anova() comparing model with and without the fixed effect of interest
chiReport.func <- function(a){
	ifelse (
		a$"Pr(>Chisq)"[2] > .0001,
		return(paste("chisq(",a$"Chi Df"[2],")=",round(a$Chisq[2],2),", p = ",round(a	$"Pr(>Chisq)"[2],4),sep="")), # return chisq, p
		return(paste("chisq(",a$"Chi Df"[2],")=",round(a$Chisq[2],2),", p < .0001"))) # return p < .0001 for very small values of p
}

# Bootstrap analysis package
library(boot)

# Bootstrap function for mean differences in paired observations
boot.mean.dif.fnc <- function (data,indices){
  # get difference at each index
  d <- (data$Obs1[indices]-data$Obs2[indices])
  # calculate mean
  return(mean(d))
}

# Read in manual data
dataMANUAL <- read.delim("durationData.txt",as.is=T)

# Read in aligned datasets and remove extraneous columns
dataSED <- read.csv("structed_classifier_DL.csv",as.is=T)
dataSED = dataSED[,c("file_name","predicted_duration")]
dataSEDNC <- read.csv("structed_no_classifier_DL.csv", as.is=T)
dataSEDNC = dataSEDNC[,c("file_name","predicted_duration")]
dataPENN <- read.csv("fave_jordana.csv",as.is=T)
dataPENN = dataPENN[,c("file_name", "predicted_duration")]

# Make filename columns are consistent
dataMANUAL$File = gsub(".wav", "", dataMANUAL$File)
dataSED$file_name = tolower(gsub(".TextGrid", "", dataSED$file_name))
dataSEDNC$file_name = tolower(gsub(".TextGrid", "", dataSEDNC$file_name))
dataPENN$file_name = gsub(".textgrid", "", dataPENN$file_name)

# Exclude subjects 001, 008, 031
# (These subjects did not give permission for data use beyond the original project)
excludeSubj = c("s001", "s008", "s031")
dataMANUAL = dataMANUAL[!(dataMANUAL$subj %in% excludeSubj),]
dataSED = dataSED[-(grep("008", dataSED$file_name, fixed = TRUE)),]
dataSEDNC = dataSEDNC[-(grep("008", dataSEDNC$file_name, fixed = TRUE)),]

# Remove "lock", "hat" observations from the two data frames they appeared in
dataSED = dataSED[-(grep("lock", dataSED$file_name)),]
dataSED = dataSED[-(grep("hat", dataSED$file_name)),]
dataSEDNC = dataSEDNC[-(grep("lock", dataSEDNC$file_name)),]
dataSEDNC = dataSEDNC[-(grep("hat", dataSEDNC$file_name)),]

# total observations
nrow(dataMANUAL)
# 2395

# Failure rates for each
# (Data points which could not be algorithmically aligned)
1-(nrow(dataSED)/nrow(dataMANUAL))
# -0.002505219
1-(nrow(dataSEDNC)/nrow(dataMANUAL))
#  -0.002505219
1-(nrow(dataPENN)/nrow(dataMANUAL))
# 0

# Find observations common to all
MP <- intersect(dataMANUAL$File, dataSED$file_name)
MPS <- intersect(MP, dataSED$file_name)
MPS2 <- intersect(MPS, dataSED$file_name)

# Select common observations and sort by filename
# Rename duration column to be specific to each data source
dataMANUAL.matched <- dataMANUAL[is.element(dataMANUAL$File,MPS2),]
colnames(dataMANUAL.matched)[13] <- "duration.Manual"
dataMANUAL.matched <- dataMANUAL.matched[order(dataMANUAL.matched$File),]

dataSED.matched <- dataSED[is.element(dataSED$file_name,MPS2),]
colnames(dataSED.matched)[1] <- "File"
colnames(dataSED.matched)[2] <- "duration.SED"
dataSED.matched <- dataSED.matched[order(dataSED.matched$File),]

dataSEDNC.matched = dataSEDNC[is.element(dataSEDNC$file_name,MPS2),]
colnames(dataSEDNC.matched)[1] <- "File"
colnames(dataSEDNC.matched)[2] = "duration.SEDNC"
dataSEDNC.matched = dataSEDNC.matched[order(dataSEDNC.matched$File),]

dataPENN.matched <- dataPENN[is.element(dataPENN$file_name,MPS2),]
colnames(dataPENN.matched)[1] <- "File"
colnames(dataPENN.matched)[2] <- "duration.PENN"
dataPENN.matched <- dataPENN.matched[order(dataPENN.matched$File),]

# Merge datasets into one frame
dataMP <- merge(dataMANUAL.matched,dataPENN.matched,by="File")
dataMP2 <- merge(dataMP,dataSED.matched,by="File")
dataFull = merge(dataMP2, dataSEDNC.matched, by="File")

# Size of common set - make sure this equals the value reported above for nrow(dataMANUAL)
nrow(dataFull)
# 2395

# --------------------------------------------------------------------------------------------
## Density plot

# Compare the distribution of deviance of each algorithmic model to the manual model, and
# plot that distribution

pdf(file="figures/HellerDensity.pdf", width = 5.25, height = 5)
cexStandard = 1.25																					# Baseline text size
axisMaxMin = max(abs((c(																			# Find good axis values
	dataFull$duration.Manual - dataFull$duration.SED,
	dataFull$duration.Manual - dataFull$duration.SEDNC,
	dataFull$duration.Manual - dataFull$duration.PENN))))
axisMaxMin = axisMaxMin + (0.1* axisMaxMin)
plot(density(dataFull$duration.Manual - dataFull$duration.SED), lwd = 2, col = "blue",				# Plot SED (DLM) deviance in blue
	main = "",																						# Suppress main title
	cex.main = cexStandard+.25, cex.axis = cexStandard, cex.lab = cexStandard,						# Set text sizes
	xlim = c(-axisMaxMin, axisMaxMin), ylim = c(0, 30))												# Set x-axis limits
lines(density(dataFull$duration.Manual - dataFull$duration.SEDNC), lwd = 2, col = "red", lty = 2) 	# Plot SEDNC deviance in red
lines(density(dataFull$duration.Manual - dataFull$duration.PENN), lwd = 2, col = "black", lty = 4) 	# Plot Penn (HMM) deviance in black
legend("topright", c("DLM", "DLM (no classifier)", "HMM"), col = c("blue", "red", "black"),			# Legend
      lwd  = 2, lty = c(1, 2, 4), cex = 0.85)
dev.off()

# ---------------------------------------------------------------------------------------

## Metrics of error (MSE)

#Mean squared error of predictions: Structured Prediction
mean((dataFull$duration.SED - dataFull$duration.Manual)^2)*1000
#  1.561764

#Mean squared error of predictions: Structured Prediction (no classifier)
mean((dataFull$duration.SEDNC - dataFull$duration.Manual)^2)*1000
#  2.336025

#Mean squared error of predictions: Penn aligner
mean((dataFull$duration.PENN - dataFull$duration.Manual)^2)*1000
# 1.853601

#Compare MSE: Structured prediction vs. Penn aligner
#bootstrap 95% CI
pairedObs<- data.frame((dataFull$duration.PENN-dataFull$duration.Manual)^2,(dataFull$duration.SED-dataFull$duration.Manual)^2)
colnames(pairedObs) <-c("Obs1","Obs2")
boot.results <- boot(data=pairedObs,statistic = boot.mean.dif.fnc,R=1000) #1000 bootstrap replicates

# Mean squared error of predictions
# Note: these and all bootstrap predictions will vary slightly from run to run
mean((dataFull$duration.PENN - dataFull$duration.Manual)^2 - (dataFull$duration.SED - dataFull$duration.Manual)^2 )
# 0.0002918373
# this is the mean difference in squared error across the two methods.

boot.ci(boot.results,type="perc")$perc[,5] # upper 95th percentile
# 0.0005405129
boot.ci(boot.results,type="perc")$perc[,4] # lower 95th percentile
# 4.535996e-05
# Interpretation: Interval does not include 0, so Penn (HMM) has significantly higher MSE than SED (DLM)

#Compare MSE: Structured prediction vs. without classifier
#bootstrap 95% CI
pairedObs<- data.frame((dataFull$duration.SEDNC-dataFull$duration.Manual)^2,(dataFull$duration.SED-dataFull$duration.Manual)^2)
colnames(pairedObs) <-c("Obs1","Obs2")
boot.results <- boot(data=pairedObs,statistic = boot.mean.dif.fnc,R=1000) #1000 bootstrap replicates

#Mean squared error of predictions
mean((dataFull$duration.SEDNC - dataFull$duration.Manual)^2 - (dataFull$duration.SED - dataFull$duration.Manual)^2 )
# 0.0007742605
# this is the mean difference in squared error across the two methods.

boot.ci(boot.results,type="perc")$perc[,5] # upper 95th percentile
# 0.001009028
boot.ci(boot.results,type="perc")$perc[,4] # lower 95th percentile
# 0.0005153437
# Interpretation: Interval does not contain 0; SEDNC (DLM NC) has significantly higher MSE than SED (DLM)

#Compare MSE: Structured prediction without classifier vs. Penn aligner
#bootstrap 95% CI
pairedObs<- data.frame((dataFull$duration.SEDNC-dataFull$duration.Manual)^2,(dataFull$duration.PENN-dataFull$duration.Manual)^2)
colnames(pairedObs) <-c("Obs1","Obs2")
boot.results <- boot(data=pairedObs,statistic = boot.mean.dif.fnc,R=1000) #1000 bootstrap replicates

#Mean squared error of predictions
mean((dataFull$duration.SEDNC - dataFull$duration.Manual)^2 - (dataFull$duration.PENN - dataFull$duration.Manual)^2 )
# 0.0004824232
# this is the mean difference in squared error across the two methods.

boot.ci(boot.results,type="perc")$perc[,5] # upper 95th percentile
#  0.0007918015
boot.ci(boot.results,type="perc")$perc[,4] # lower 95th percentile
# 0.0001562128
# Interpretation: Interval does not contain 0; SEDNC (DLM NC) has significantly higher MSE than Penn (HMM)

# ------------------------------------------------------------------------------------------
## Regression analyses

# For regressions: follow method of Sonderegger & Keshet (2012)
# Test 1: after trimming outliers, compare model parameters (for fit on training set)
# Test 2: compare predictions of models using leave-one-out method

# Prep regression analysis
# center/log transform density predictor
dataFull$logDur.Manual = log(dataFull$duration.Manual)
dataFull$logDur.SED = log(dataFull$duration.SED)
dataFull$logDur.SEDNC = log(dataFull$duration.SEDNC)
dataFull$logDur.PENN = log(dataFull$duration.PENN)

# For each algorithmic measure:
# Fit a regression model, then re-fit excluding observations where model residuals exceed 2.5 standard deviations from mean
# Assess significance of each fixed effect term using model comparison

# Basic model structure:
# data.lmer = lmer(logDur~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=dataFull,control = lmerControl(optimizer = "bobyqa"),REML=F)

# Manual fit
dataManual.lmer = lmer(logDur.Manual~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=dataFull,control = lmerControl(optimizer = "bobyqa"),REML=F)
manualTrim = dataFull[abs(scale(resid(dataManual.lmer)))<2.5,] # Trim outlier residuals and then refit model
dataManualTrim.lmer = lmer(logDur.Manual~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=manualTrim,control = lmerControl(optimizer = "bobyqa"),REML=F)

summary(dataManualTrim.lmer)
# Fixed effects:
# 			  Estimate 	Std. Error t value
# (Intercept) -1.72217    0.04721  -36.48
# ContextCode -0.05741    0.01747   -3.29
# BlockCode    0.01181    0.01642    0.72

# Assess fixed effects by re-fitting model without predictor, anova() to compare model with and without predictor
chiReport.func(anova(dataManualTrim.lmer,update(dataManualTrim.lmer,.~.-ContextCode)))
# "chisq(1)=10, p = 0.0016"
chiReport.func(anova(dataManualTrim.lmer,update(dataManualTrim.lmer,.~.-BlockCode)))
# "chisq(1)=0.52, p = 0.473"

# Structured prediction fit
dataSED.lmer = lmer(logDur.SED~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=dataFull,control = lmerControl(optimizer = "bobyqa"),REML=F)
sedTrim = dataFull[abs(scale(resid(dataSED.lmer)))<2.5,]
dataSEDTrim.lmer = lmer(logDur.SED~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=sedTrim,control = lmerControl(optimizer = "bobyqa"),REML=F)

summary(dataSEDTrim.lmer)
#             Estimate Std. Error t value
# (Intercept) -1.79041    0.04453  -40.20
# ContextCode -0.07180    0.01879   -3.82
# BlockCode    0.01608    0.01770    0.91

chiReport.func(anova(dataSEDTrim.lmer,update(dataSEDTrim.lmer,.~.-ContextCode)))
# "chisq(1)=13.11, p = 3e-04"
chiReport.func(anova(dataSEDTrim.lmer,update(dataSEDTrim.lmer,.~.-BlockCode)))
#"chisq(1)=0.82, p = 0.3651"

# Structured prediction (no classifier) fit
dataSEDNC.lmer = lmer(logDur.SEDNC~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=dataFull,control = lmerControl(optimizer = "bobyqa"),REML=F)
sedncTrim = dataFull[abs(scale(resid(dataSEDNC.lmer)))<2.5,]
dataSEDNCTrim.lmer = lmer(logDur.SEDNC~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=sedncTrim,control = lmerControl(optimizer = "bobyqa"),REML=F)

summary(dataSEDNCTrim.lmer)
#            Estimate Std. Error t value
# (Intercept) -1.80015    0.04262  -42.24
# ContextCode -0.05861    0.01754   -3.34
# BlockCode    0.01515    0.01680    0.90

chiReport.func(anova(dataSEDNCTrim.lmer,update(dataSEDNCTrim.lmer,.~.-ContextCode)))
# "chisq(1)=10.2, p = 0.0014"
chiReport.func(anova(dataSEDNCTrim.lmer,update(dataSEDNCTrim.lmer,.~.-BlockCode)))
# "chisq(1)=0.81, p = 0.3688"

# Penn aligner fit
dataPENN.lmer = lmer(logDur.PENN~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=dataFull,control = lmerControl(optimizer = "bobyqa"),REML=F)
pennTrim = dataFull[abs(scale(resid(dataPENN.lmer)))<2.5,]
dataPENNTrim.lmer = lmer(logDur.PENN~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=pennTrim,control = lmerControl(optimizer = "bobyqa"),REML=F)

summary(dataPENNTrim.lmer)
# #            Estimate Std. Error t value
# (Intercept) -1.775437   0.046181  -38.45
# ContextCode -0.057771   0.018471   -3.13
# BlockCode    0.007923   0.014283    0.55

chiReport.func(anova(dataPENNTrim.lmer,update(dataPENNTrim.lmer,.~.-ContextCode)))
# "chisq(1)=8.81, p = 0.003"
chiReport.func(anova(dataPENNTrim.lmer,update(dataPENNTrim.lmer,.~.-BlockCode)))
# "chisq(1)=0.31, p = 0.5795"

## ---------------------------------------------------------------------------------
## Leave-one-out model predictions

# Comparison 2: Predictions using leave-one-out method

# Generate predictions for test set
obs = c(1:length(dataFull$File))
dataFull2 = cbind(dataFull, obs)

# Predictions (these will be time-intensive)
manualPredict = double(length(dataFull$File))
for(i in 1:length(dataFull$File)){
  dataFull3 = subset(dataFull2, obs!=i)
  dataManual.lmer = lmer(logDur.Manual~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=dataFull3,control = lmerControl(optimizer = "bobyqa"),REML=F)
  manualTrim = dataFull3[abs(scale(resid(dataManual.lmer)))<2.5,]
  dataManualTrim.lmer = lmer(logDur.Manual~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=manualTrim,control = lmerControl(optimizer = "bobyqa"),REML=F)
  manPred = predict(dataManualTrim.lmer, newdata = dataFull2)
  manualPredict[i] = manPred[i]
}

sedPredict = double(length(dataFull$File))
for(i in 1:length(dataFull$File)){
  dataFull3 = subset(dataFull2, obs!=i)
  dataSED.lmer = lmer(logDur.SED~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=dataFull3,control = lmerControl(optimizer = "bobyqa"),REML=F)
  sedTrim = dataFull3[abs(scale(resid(dataSED.lmer)))<2.5,]
  dataSEDTrim.lmer = lmer(logDur.SED~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=sedTrim,control = lmerControl(optimizer = "bobyqa"),REML=F)
  sedPred = predict(dataSEDTrim.lmer, newdata = dataFull2)
  sedPredict[i] = sedPred[i]
}

sedncPredict = double(length(dataFull$File))
for(i in 1:length(dataFull$File)){
  dataFull3 = subset(dataFull2, obs!=i)
  dataSEDNC.lmer = lmer(logDur.SEDNC~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=dataFull3,control = lmerControl(optimizer = "bobyqa"),REML=F)
  sedncTrim = dataFull[abs(scale(resid(dataSEDNC.lmer)))<2.5,]
  dataSEDNCTrim.lmer = lmer(logDur.SEDNC~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=sedncTrim,control = lmerControl(optimizer = "bobyqa"),REML=F)
  sedncPred = predict(dataSEDNCTrim.lmer, newdata = dataFull2)
  sedncPredict[i] = sedncPred[i]
}

pennPredict = double(length(dataFull$File))
for(i in 1:length(dataFull$File)){
  dataFull3 = subset(dataFull2, obs!=i)
  dataPENN.lmer = lmer(logDur.PENN~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=dataFull3,control = lmerControl(optimizer = "bobyqa"),REML=F)
  pennTrim = dataFull[abs(scale(resid(dataPENN.lmer)))<2.5,]
  dataPENNTrim.lmer = lmer(logDur.PENN~ContextCode+BlockCode+(1+ContextCode||subject)+(1+ContextCode||word),data=pennTrim,control = lmerControl(optimizer = "bobyqa"),REML=F)
  pennPred = predict(dataPENNTrim.lmer, newdata = dataFull2)
  pennPredict[i] = pennPred[i]
}

#MSE for Structured Prediction
mean((exp(manualPredict)-exp(sedPredict))^2)*1000
# 0.4785495

#MSE for Structured Prediction (no classifier)
mean((exp(manualPredict)-exp(sedncPredict))^2) *1000
#  0.9351113

#MSE for penn aligner
mean((exp(manualPredict)-exp(pennPredict))^2) *1000
#  0.8345711

#Compare MSE: Structured prediction vs. Penn aligner
#bootstrap 95% CI
pairedObs<- data.frame((exp(pennPredict) - exp(manualPredict))^2,(exp(sedPredict) - exp(manualPredict))^2)
colnames(pairedObs) <-c("Obs1","Obs2")
boot.results <- boot(data=pairedObs,statistic = boot.mean.dif.fnc,R=1000) #1000 bootstrap replicates

boot.ci(boot.results,type="perc")$perc[,5] # upper 95th percentile
# 0.0004278912
boot.ci(boot.results,type="perc")$perc[,4] # lower 95th percentile
# 0.0002945042
# Interpretation: Interval does not contain 0, so PENN(HMM) has a higher MSE than SED (DLM)

#Compare MSE: Structured prediction vs. structured prediction (no classifier)
#bootstrap 95% CI
pairedObs<- data.frame((exp(sedncPredict) - exp(manualPredict))^2,(exp(sedPredict) - exp(manualPredict))^2)
colnames(pairedObs) <-c("Obs1","Obs2")
boot.results <- boot(data=pairedObs,statistic = boot.mean.dif.fnc,R=1000) #1000 bootstrap replicates

boot.ci(boot.results,type="perc")$perc[,5] # upper 95th percentile
#  0.0005468904
boot.ci(boot.results,type="perc")$perc[,4] # lower 95th percentile
# 0.0003740818
# Interpretation: Interval does not contain 0, so SEDNC (DLM NC) has a higher MSE than SED (DLM)

#Compare MSE: Structured prediction (no classifier) vs. Penn aligner
#bootstrap 95% CI
pairedObs<- data.frame((exp(pennPredict) - exp(manualPredict))^2,(exp(sedncPredict) - exp(manualPredict))^2)
colnames(pairedObs) <-c("Obs1","Obs2")
boot.results <- boot(data=pairedObs,statistic = boot.mean.dif.fnc,R=1000) #1000 bootstrap replicates

#Mean squared error of predictions
boot.ci(boot.results,type="perc")$perc[,5] # upper 95th percentile
# 1.51538e-06
boot.ci(boot.results,type="perc")$perc[,4] # lower 95th percentile
# -0.0002047568
# Interpretation: Interval contains 0, so we cannot be confident in a difference between SED (DLM) and SEDNC (DLM-NC)

# ---------------------------------------------------------------------------------------
## Plot leave-one-out model predictions

# Compare the distribution of deviance of each algorithmic model's preditions to the manual model's predictions, and plot that distribution

pdf(file="figures/HellerDensityPredictions.pdf", width = 5.25, height  = 5)
cexStandard = 1.25
# Set axis min-max to contain data points from all four sets of predictions
axisMaxMin = max(abs((c(
	manualPredict - sedPredict,
	manualPredict - sedncPredict,
	manualPredict - pennPredict))))
axisMaxMin = axisMaxMin + (0.3* axisMaxMin)
plot(density(manualPredict - sedPredict), lwd = 2, col = "blue",
	main = "",
	cex.main = cexStandard+.25, cex.axis = cexStandard, cex.lab = cexStandard,
	xlim = c(-axisMaxMin, axisMaxMin), ylim = c(0, 6))
lines(density(manualPredict - sedncPredict), lwd = 2, col = "red", lty = 2)
lines(density(manualPredict - pennPredict), lwd = 2, col = "black", lty = 4)
legend("topright", c("DLM", "DLM (no classifier)", "HMM"), col = c("blue", "red", "black"),
      lwd  = 2, lty = c(1, 2, 4), cex = 0.85)
dev.off()


##
# @file
# This file is part of SeisSol.
#
# @author Alex Breuer (breuer AT mytum.de, http://www5.in.tum.de/wiki/index.php/Dipl.-Math._Alexander_Breuer)
#
# @section LICENSE
# Copyright (c) 2014, SeisSol Group
# All rights reserved.
#
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that the following conditions are met:
#
# 1. Redistributions of source code must retain the above copyright notice,
#    this list of conditions and the following disclaimer.
#
# 2. Redistributions in binary form must reproduce the above copyright notice,
#    this list of conditions and the following disclaimer in the documentation
#    and/or other materials provided with the distribution.
#
# 3. Neither the name of the copyright holder nor the names of its
#    contributors may be used to endorse or promote products derived from this
#    software without specific prior written permission.
#
# THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
# AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
# IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
# ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE
# LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
# CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
# SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
# INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
# CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
# ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
# POSSIBILITY OF SUCH DAMAGE.
#
# @section DESCRIPTION
# Performance model for SeisSol setups.

computeMeshStatistics <- function( i_meshName,
                                   i_pathToCsvFile,
                                   i_performanceParameters,
                                   i_outputFileTable,
                                   i_outputFilePlot ) {
  message( 'reading mesh', i_pathToCsvFile )
  l_meshStatistics <- read.csv( file = i_pathToCsvFile,
                                header = TRUE )

  #
  # compute data to send and receive in MPI-communication
  #
  # mpi-information per time step in GB, regular mpi faces
  l_meshStatistics$mpi_send <- l_meshStatistics$mpi_faces*i_performanceParameters$dofs_size/1024^3

  # mpi-information per time step in GB, dr mpi face come on top
  l_meshStatistics$mpi_send <- l_meshStatistics$mpi_send + (l_meshStatistics$mpi_dr_faces*i_performanceParameters$dofs_size/1024^3)

  # so far everything is the same
  l_meshStatistics$mpi_receive <- l_meshStatistics$mpi_send

  #
  # compute ratios
  #
  l_meshStatistics$ratio_dynamic_rupture_faces_elements <- l_meshStatistics$dynamic_rupture_faces / l_meshStatistics$elements

  # compute timings for
  # * time integraton of all elements
  # * volume integration of all elements
  # * boundary integration of all elements
  # * additional flux computation for dunamic rupture faces
  # * time integration of MPI-elements
  # * communication of MPI-elements
  # * computation of volume integration and non-MPI time integration
  if( !i_performanceParameters$mic ) {
    l_meshStatistics$time_integration                 <- l_meshStatistics$elements*i_performanceParameters$time_integration
    l_meshStatistics$volume_integration               <- l_meshStatistics$elements*i_performanceParameters$volume_integration
  }

  l_meshStatistics$boundary_integration             <- l_meshStatistics$elements*i_performanceParameters$boundary_integration
  l_meshStatistics$time_communication               <- (l_meshStatistics$mpi_send +  l_meshStatistics$mpi_receive) / i_performanceParameters$network_bandwidth
  l_meshStatistics$dynamic_rupture_fluxes           <- l_meshStatistics$dynamic_rupture_faces*i_performanceParameters$dynamic_rupture

  if( i_performanceParameters$mic ) {
    l_meshStatistics$time_integration_mpi             <- l_meshStatistics$mpi_elements*i_performanceParameters$time_integration
    l_meshStatistics$pci_communication                <- ( (l_meshStatistics$mpi_faces*i_performanceParameters$dofs_size*2 + l_meshStatistics$mpi_dr_faces*i_performanceParameters$dofs_size) /1024^3) / i_performanceParameters$pci_bandwidth
    l_meshStatistics$volume_time_integration_interior <- l_meshStatistics$elements*i_performanceParameters$volume_integration + l_meshStatistics$interior_elements*i_performanceParameters$time_integration

    l_meshStatistics$overlapped_comm_time_volume      <- pmax( l_meshStatistics$time_communication + l_meshStatistics$pci_communication, l_meshStatistics$volume_time_integration_interior )
    l_meshStatistics$cpu_dynamic_rupture              <- l_meshStatistics$dynamic_rupture_fluxes - pmax( l_meshStatistics$volume_time_integration_interior -  l_meshStatistics$overlapped_comm_time_volume, 0 )
    l_meshStatistics$overlapped_dyn_rupture_fluxes    <- pmax( l_meshStatistics$cpu_dynamic_rupture + (l_meshStatistics$dynamic_rupture_faces*i_performanceParameters$dofs_size/1024^3) / i_performanceParameters$pci_bandwidth,
                                                               l_meshStatistics$boundary_integration )
  }

#new overlap
#  if( i_performanceParameters$mic ) {
#    l_meshStatistics$time_integration_mpi             <- l_meshStatistics$mpi_elements*i_performanceParameters$time_integration
#    l_meshStatistics$pci_communication                <- ( (l_meshStatistics$mpi_faces*i_performanceParameters$dofs_size*2 + l_meshStatistics$mpi_dr_faces*i_performanceParameters$dofs_size) /1024^3) / i_performanceParameters$pci_bandwidth
#    l_meshStatistics$volume_time_integration_interior <- l_meshStatistics$elements*i_performanceParameters$volume_integration + l_meshStatistics$interior_elements*i_performanceParameters$time_integration + l_meshStatistics$interior_elements*i_performanceParameters$boundary_integration
#
#    l_meshStatistics$overlapped_comm_time_volume      <- pmax( l_meshStatistics$time_communication + l_meshStatistics$pci_communication, l_meshStatistics$volume_time_integration_interior )
#    l_meshStatistics$cpu_dynamic_rupture              <- l_meshStatistics$dynamic_rupture_fluxes - pmax( l_meshStatistics$volume_time_integration_interior -  l_meshStatistics$overlapped_comm_time_volume, 0 )
#    l_meshStatistics$overlapped_dyn_rupture_fluxes    <- pmax( l_meshStatistics$cpu_dynamic_rupture + (l_meshStatistics$dynamic_rupture_faces*i_performanceParameters$dofs_size/1024^3) / i_performanceParameters$pci_bandwidth,
#                                                               l_meshStatistics$mpi_elements*i_performanceParameters$boundary_integration )
#  }

  if( !i_performanceParameters$mic ) {
    l_meshStatistics$time_total                       <- l_meshStatistics$time_integration + l_meshStatistics$volume_integration + l_meshStatistics$boundary_integration + l_meshStatistics$dynamic_rupture_fluxes + l_meshStatistics$time_communication
  }
  else {
    l_meshStatistics$time_total                       <- l_meshStatistics$time_integration_mpi + l_meshStatistics$overlapped_comm_time_volume + l_meshStatistics$overlapped_dyn_rupture_fluxes
  }
  message( 'summary mesh statistics')
  print( summary( l_meshStatistics ) )

  message( 'writing csv' )
  write.csv( x=l_meshStatistics, file=i_outputFileTable)

  message( 'plotting information' )
  pdf( file = i_outputFilePlot,
       paper = 'a4r',
       width=20,
       height=10)

  # print title page
  plot(0:10, type = "n", xaxt="n", yaxt="n", bty="n", xlab = "", ylab = "")
  text(5, 8, i_meshName)
  text(5, 7, Sys.time())

  # overview boxplots
  if( !i_performanceParameters$mic ) {
    par( mfrow=c(1,6) )
    boxplot(l_meshStatistics$time_integration,       main='time integration'     )
    boxplot(l_meshStatistics$volume_integration,     main='volume integration'   )
    boxplot(l_meshStatistics$boundary_integration,   main='boundary integration' )
    boxplot(l_meshStatistics$dynamic_rupture_fluxes, main='dyn. rupt. fluxes'    )
    boxplot(l_meshStatistics$time_communication,     main='communication'        )
    boxplot(l_meshStatistics$time_total,             main='total time'           )
  }
  else {
    par( mfrow=c(1,6) )
    boxplot( l_meshStatistics$time_integration_mpi,             main='time integration of copy layer'                   )
    boxplot( l_meshStatistics$volume_time_integration_interior, main='time & volume int.'                               )
    boxplot( l_meshStatistics$overlapped_comm_time_volume,      main='overlapped comm., int. time and vol. integration' )
    boxplot( l_meshStatistics$boundary_integration,             main='boundary integration'                             )
    boxplot( l_meshStatistics$overlapped_dyn_rupture_fluxes,    main='overlapped dyn. rupt. and bnd. intgration'        )
    boxplot( l_meshStatistics$time_total,                       main='total time'                                       )
  }

  # detailed plot of every characteristic value
  #for( l_name in names(l_meshStatistics[-1]) ) {
  #  layout( matrix(c(1,2), 2, 2, byrow = TRUE),
  #          widths=c(4,1) )
  #  plot( x=l_meshStatistics$partition,
  #        y=l_meshStatistics[,l_name],
  #        xlab="partition",
  #        ylab=l_name )
  #  boxplot(l_meshStatistics[l_name])
  #}
  dev.off()

  return( median(l_meshStatistics$time_total) )
}

l_config = list ( mesh_names = list( 'statistics_cube320_400_640_1024',
                                     'statistics_cube400_640_640_2048',
                                     'statistics_cube640_640_800_4096',
                                     'statistics_cube640_900_1280_9216',
                                     'statistics_Landers191M_02_05_02_512',
                                     'statistics_Landers191M_02_05_02_768',
                                     'statistics_Landers191M_02_05_02_1024',
                                     'statistics_Landers191M_02_05_02_1536',
                                     'statistics_Landers191M_02_05_02_3072',
                                     'statistics_Landers191M_02_05_02_2048',
                                     'statistics_Landers191M_02_05_02_4096',
                                     'statistics_Landers191M_02_05_02_6144',
                                     'statistics_Landers191M_02_05_02_9216',
                                     'statistics_Landers191M_02_05_02_12288',
                                     'statistics_Landers191M_02_05_02_24756'),

                  statistics_directory = 'mesh_statistics_gb',

                  performance_parameters = list( supermuc = list( basisFunctions       = 56,
                                                                  quantities           = 9,
                                                                  dofs_size            = 56*9*8,
                                                                  network_bandwidth    = 0.8,                              # TODO: missing reference point
                                                                  mic                  = FALSE,
                                                                  boundary_integration = 389.68 * 1024 / 191098540 / 1000, # reference, landers_1024
                                                                  time_integration     = 169.04 * 1024 / 191098540 / 1000, # reference, landers_1024
                                                                  volume_integration   = 126.88 * 1024 / 191098540 / 1000, # reference, landers_1024
                                                                  #boundary_integration = 43.26 * 9216 / 191098540 / 1000,  # reference, landers_9216
                                                                  #time_integration     = 18.86 * 9216 / 191098540 / 1000,  # reference, landers_9216
                                                                  #volume_integration   = 14.06 * 9216 / 191098540 / 1000,  # reference, landers_9216
                                                                  #time_integration     = 36.33 / 400000 / 100,             # reference, cubes_9216
                                                                  #volume_integration   = 27.18 / 400000 / 100,             # reference, cubes_9216
                                                                  #boundary_integration = 84.86 / 400000 / 100,             # reference, cubes_9216
                                                                  dynamic_rupture      = 109.33 /  22798 / 1000 ),          # TODO: missing reference point
                                                 stampede = list( basisFunctions       = 56,
                                                                  quantities           = 9,
                                                                  dofs_size            = 56*9*8,
                                                                  network_bandwidth    = 0.8,
                                                                  mic                  = TRUE,
                                                                  pci_bandwidth        = 6.3,
                                                                  boundary_integration = 230.68 * 2 / 386518 / 1000 * 56 / 60, # extrapolated from LOH1_2
                                                                  time_integration     = 131.84 * 2 / 386518 / 1000 * 56 / 60, # extrapolated frpm LOH1_2
                                                                  volume_integration   =  88.51 * 2 / 386518 / 1000 * 56 / 60, # extrapolated from LOH1_2
                                                                  dynamic_rupture      = 109.33 /  22798 / 1000 ), # same as SuperMUC, but not relevant here; no impact on TH-2
                                                 tianhe   = list( basisFunctions       = 56,
                                                                  quantities           = 9,
                                                                  dofs_size            = 56*9*8,
                                                                  #network_bandwidth    = 0.367, # fitted via cube-runtimes of ~100.25 seconds
                                                                  #network_bandwidth    = 0.61, # fitted via landers_2048, 3 cards
                                                                  network_bandwidth    = 0.525, #fitted via landers_2048, rank 2474: 4582 mpi-facesm 65.56s comm. time
                                                                  mic                  = TRUE,
                                                                  pci_bandwidth        = 3.2,
                                                                  boundary_integration = 230.68 * 2 / 386518 / 1000,  # extrapolated from LOH1_2
                                                                  time_integration     = 131.84 * 2 / 386518 / 1000,  # extrapolated from LOH1_2
                                                                  volume_integration   =  88.51 * 2 / 386518 / 1000,  # extrapolated from LOH1_2
                                                                  dynamic_rupture      =  26.79     /   2800 / 1000 ) # rank 2931 for 6144 ranks on TH-2
                                                )
                 )

l_expectedSimulationTime = list()

message( 'lets go' )
for( l_machine in list('supermuc', 'stampede', 'tianhe') ) {
  for( l_meshName in l_config$mesh_names ) {
    message( 'analyzing: ', l_meshName )
    l_expectedSimulationTime[[paste(l_meshName,'_',l_machine, sep='')]] =
     computeMeshStatistics( i_meshName              = l_meshName,
                            i_pathToCsvFile         = paste(l_config$statistics_directory,'/',l_meshName,'.csv', sep=''),
                            i_performanceParameters = (l_config$performance_parameters)[[l_machine]],
                            i_outputFileTable       = paste(l_meshName,'_',l_machine,'.csv', sep=''),
                            i_outputFilePlot        = paste(l_meshName,'_',l_machine,'.pdf', sep='') )
  }
}

l_expectedSimulationTime$statistics_Landers191M_02_05_02_768_tianhe = 0.581

for( l_machine in list('supermuc', 'stampede', 'tianhe') ) {
  l_strongScalingNodes = list(768, 1024, 1536, 2048, 3072, 4096, 6144, 9216, 12288, 24756 )
  l_runtime = list()
  for( l_nodes in l_strongScalingNodes ) {
    l_runtime = c( l_runtime, l_expectedSimulationTime[[paste('statistics_Landers191M_02_05_02_', l_nodes, '_', l_machine, sep='')]] * ( l_nodes / l_strongScalingNodes[[1]]) )
  }
  l_runtime <- l_runtime[[1]] / unlist(l_runtime)

  print(l_machine)
  print(unlist(l_strongScalingNodes))
  print(l_runtime)

  plot( x=l_strongScalingNodes, l_runtime, ylab='parallel efficiency', main=l_machine )
}


#Italy Invert Figs
#The following code is for the figures presented in the manuscript.
#For all other code use for analysis see ItalyInvertRmarkdownJune8.rmd or ItalyInvertRmarkdownJune8.html for precomputed output
#Joe Receveur Email: josephreceveur[at] gmail.com
#######
#Import
#######

library(vegan)
library(MASS)
library(ggplot2)
library(plyr)
library(dplyr)
library(magrittr)
library(scales)
library(grid)
library(reshape2)
library(phyloseq)
library(randomForest)
library(knitr)
library(ape)
library(ggpubr)
library(multcompView)
library(Rmisc)
library(tiff)

set.seed(27)
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#000000","#CC79A7","#E12D00")
theme_set(theme_bw(base_size = 18)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))
biom=import_biom("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvert2018WTax.biom",parseFunction= parse_taxonomy_greengenes)
#tax_table(biom) <- tax_table(biom)[,-c(5:10,14)]#remove dummy ranks

metadata=read.csv("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvertMetadataWDiversity3.5.2019.csv",header = TRUE)
head(metadata)

tree=read_tree("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvert11.29.18Tree.nwk")

sampdat=sample_data(metadata)
sample_names(sampdat)=metadata$id
physeq=merge_phyloseq(biom,sampdat,tree)
physeq=rarefy_even_depth(physeq, 3000, replace = TRUE, trimOTUs = TRUE, verbose = TRUE)
physeq

#######
#Figure 3A Weights by station
#######

Trtdata <- ddply(metadata, c("Sampling_station", "FFG","Taxon_name"), summarise,
                 N    = length(id),
                 meanWeight = mean(Mass),
                 sd   = sd(Mass),
                 se   = sd / sqrt(N)
)
Trtdata

Scrapers<-subset(metadata, FFG=="Scraper")
t.test( Mass~ Sampling_station, data=Scrapers)
#t-test,t=4.219,P = 0.0047

Shredders<-subset(metadata, FFG=="Shredder")
t.test( Mass~ Sampling_station, data=Shredders)
#t=1.81,P = 0.2095

MassPlot<-ggplot(metadata,aes(x=Sampling_station,y=Mass,fill=Sampling_station))+geom_boxplot()+ #Write in labels from posthoc
  scale_fill_manual(values=cbPalette)+xlab("")+ylab("Mass (mg)")+labs(fill="FFG")+guides(fill=FALSE)+facet_wrap(~FFG,scales = "free_y")+
  theme_bw(base_size = 10)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank())
#+theme(axis.text.x = element_text(angle = 45,
MassPlot

tiff("Figures/MassPlot.tiff", width = 3.3, height = 3.3, units = 'in', res = 300)
MassPlot
dev.off()

#######
#Figure 3B Phylum level stacked bar graph
#######
theme_set(theme_bw(base_size = 9)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))

GPr  = transform_sample_counts(physeq, function(x) x / sum(x) ) #transform samples based on relative abundance
GPr = filter_taxa(GPr, function(x) mean(x) > 1e-5, TRUE)
PhylumAll=tax_glom(GPr, "Phylum")

PhylumLevel = filter_taxa(PhylumAll, function(x) mean(x) > 1e-2, TRUE) #filter out any taxa lower tha 0.1%

df <- psmelt(PhylumLevel)
df$Abundance=df$Abundance*100
Trtdata <- ddply(df, c("Phylum", "FFG","Sampling_station"), summarise,
                 N    = length(Abundance),
                 mean = mean(Abundance),
                 sd   = sd(Abundance),
                 se   = sd / sqrt(N)
)
Trtdata

RelAbuAllSamples <- ddply(df, c("Phylum"), summarise,
                 N    = length(Abundance),
                 mean = mean(Abundance),
                 sd   = sd(Abundance),
                 se   = sd / sqrt(N)
)
RelAbuAllSamples#Mean relative abundance for all samples

Trtdata<-read.csv("PhylumLevelRelAbu.csv", header=T) #Added in other category to reach 100%
Trtdata$Phylum = factor(Trtdata$Phylum, levels = c("Actinobacteria","Bacteroidetes","Firmicutes","Planctomycetes","Proteobacteria","Tenericutes","Verrucomicrobia","Other")) #fixes x-axis labels

PhylumAbu=ggplot(Trtdata, aes(x=FFG,y=mean))+geom_bar(aes(fill = Phylum),colour="black", stat="identity")+
  xlab("FFG")+ylab("Relative Abundance (%)")+theme(axis.title.x=element_blank())+ theme(axis.text.x = element_text(angle = 45, hjust = 1))+
  scale_fill_manual(values=cbPalette)+facet_wrap(~Sampling_station,scale="free_x")+ theme(legend.key.size = unit(0.4, "cm"))+
  theme(legend.text = element_text(size = 8))+ theme(legend.background=element_blank())
PhylumAbu
dev.off()
tiff("Figures/PhylumLevelRelAbu.tiff", width = 3.5, height = 3.2, units = 'in', res = 300)
PhylumAbu
dev.off()

#######
#Figure 3C Phylum level facet plot
#######
#Phylum level comparisons between sites

theme_set(theme_bw(base_size = 14)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))

GPr  = transform_sample_counts(physeq, function(x) x / sum(x) ) #transform samples based on relative abundance
GPr = filter_taxa(GPr, function(x) mean(x) > 1e-5, TRUE)
PhylumAll=tax_glom(GPr, "Phylum")
PhylumLevel = filter_taxa(PhylumAll, function(x) mean(x) > 1e-2, TRUE) #filter out any taxa lower tha 0.1%

df <- psmelt(PhylumLevel)
df$Abundance=df$Abundance*100
Trtdata <- ddply(df, c("Phylum", "FFG"), summarise,
                 N    = length(Abundance),
                 mean = mean(Abundance),
                 sd   = sd(Abundance),
                 se   = sd / sqrt(N)
)

dfStatsPlot<-subset(Trtdata,Phylum!="Actinobacteria"&Phylum!= "Planctomycetes"&Phylum!="Tenericutes")
vec<-c("a","a","b","a","a","b","b","c","ab","a","a","b","ab","a","bc","c") #From plot above
dfStatsPlot # Only show significant taxa
cdataplot=ggplot(dfStatsPlot, aes(x=FFG,y=mean))+geom_bar(aes(fill = FFG),colour="black", stat="identity")+ facet_grid(~Family)+xlab("FFG")+ylab("Relative Abundance (SEM)") + theme(axis.text.x = element_text(angle = 0, hjust = 0.5))+
  theme(axis.title.x=element_blank())+facet_wrap(~Phylum)+geom_errorbar(aes(ymin=mean-se,ymax=mean+se))+geom_text(aes(x=FFG, y=mean+se+10,label=vec),size=3)+
  scale_fill_manual(values=cbPalette)+theme(legend.justification=c(0.05,0.95), legend.position=c(0.75,0.45))+ theme(legend.title = element_blank()) + theme(axis.text.x = element_text(angle = 45, hjust = 1))+
  guides(fill=F)#+  theme(legend.text=element_text(size=rel(0.5)))#+  annotate("text", label = "KW, adj-P = 0.0014", x = 2, y = 15, size = 8)

label = c("         KW, adj-P = 0.0014", "  adj-P = 0.0014", "adj-P = 0.021","  adj-P = 0.0043")

cdataplot<-cdataplot + annotate("text",x=1.5, y=75,label=label,size=2.5)

PhylumFacet<-cdataplot

theme_set(theme_bw(base_size = 12)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))

tiff("Figures/PhylumFacet.tiff", width = 3.3, height = 3.3, units = 'in', res = 300)
PhylumFacet
dev.off()
dev.off()

#######
#Figure 3D Family level facet plot
######

GPr  = transform_sample_counts(physeq, function(x) x / sum(x) ) #transform samples based on relative abundance
GPr = filter_taxa(GPr, function(x) mean(x) > 1e-5, TRUE)
FamilyAll=tax_glom(GPr, "Family")
FamilyLevel = filter_taxa(FamilyAll, function(x) mean(x) > 3e-2, TRUE) #filter out any taxa lower tha 0.1%

df <- psmelt(FamilyLevel)
df$Abundance=df$Abundance*100
Trtdata <- ddply(df, c("Family", "FFG"), summarise,
                 N    = length(Abundance),
                 mean = mean(Abundance),
                 sd   = sd(Abundance),
                 se   = sd / sqrt(N)
)

dfStatsPlot<-subset(Trtdata,Family!="Enterobacteriaceae"&Family!= "Rhodobacteraceae"&Family!="Aeromonadaceae")
#dfStatsPlot

vec<-c("a","a","b","c","a","b","c","a","a","b","b","a","a","b","b","a")
#dfStatsPlot # Only show significant taxa
cdataplot=ggplot(dfStatsPlot, aes(x=FFG,y=mean))+geom_bar(aes(fill = FFG),colour="black", stat="identity")+ facet_grid(~Family)+xlab("FFG")+ylab("Relative Abundance (SEM)") + theme(axis.text.x = element_text(angle = 0, hjust = 0.5))+
  theme(axis.title.x=element_blank())+facet_wrap(~Family)+geom_errorbar(aes(ymin=mean-se,ymax=mean+se))+geom_text(aes(x=FFG, y=mean+se+2,label=vec),size=3)+
  scale_fill_manual(values=cbPalette)+theme(legend.justification=c(0.05,0.95), legend.position=c(0.64,0.4))+ theme(legend.title = element_blank()) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))+ theme(legend.key.size = unit(0.35, "cm"))+
  theme(legend.text = element_text(size = 8))+ theme(legend.background=element_blank())#+  annotate("text", label = "KW, adj-P = 0.0014", x = 2, y = 15, size = 8)

label = c("      KW\n adj-P < 0.001", "adj-P < 0.001", "adj-P < 0.001","           adj-P\n            < 0.001")

cdataplot<-cdataplot + annotate("text",x=3.5, y=18,label=label,size=2.5)

theme_set(theme_bw(base_size = 12)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))

FamilyFacet<-cdataplot
dev.off()
tiff("Figures/FamilyFacet.tiff", width = 3.3, height = 3.3, units = 'in', res = 300)
FamilyFacet
dev.off()

######
#Join together Figure 3
######

MassPlot
PhylumAbu
PhylumFacet
FamilyFacet

dev.off()
tiff("Figures/Figure3.tiff", width = 6.85, height = 6.85, units = 'in', res = 300)
ggarrange(MassPlot, PhylumAbu, PhylumFacet,FamilyFacet,
          labels = c("a", "b", "c","d"),
          ncol = 2, nrow = 2)
dev.off()

#####
#Figure 4
#####
GPr  = transform_sample_counts(physeq, function(x) x / sum(x) ) #transform samples based on relative abundance
GPr = filter_taxa(GPr, function(x) mean(x) > 1e-5, TRUE)
GenusAll=tax_glom(GPr,"Genus")
GenusAllStats<-GenusAll

ForestData=GenusAllStats#Change this one so you dont have to rewrite all variables
predictors=t(otu_table(ForestData))
response <- as.factor(sample_data(ForestData)$FFG)
rf.data <- data.frame(response, predictors)
MozzieForest <- randomForest(response~., data = rf.data, ntree = 1000)
print(MozzieForest)#returns overall Random Forest results
imp <- importance(MozzieForest)#all the steps that are imp or imp. are building a dataframe that contains info about the taxa used by the Random Forest testto classify treatment
imp <- data.frame(predictors = rownames(imp), imp)
imp.sort <- arrange(imp, desc(MeanDecreaseGini))
imp.sort$predictors <- factor(imp.sort$predictors, levels = imp.sort$predictors)
imp.20 <- imp.sort[1:19, ]#22

ggplot(imp.20, aes(x = predictors, y = MeanDecreaseGini)) +
  geom_bar(stat = "identity", fill = "indianred") +
  coord_flip() +
  ggtitle("Most important genera for classifying  samples\n by FFG")#\n in a string tells it to start a new line
#imp.20$MeanDecreaseGini
otunames <- imp.20$predictors
r <- rownames(tax_table(ForestData)) %in% otunames
otunames
PredictorTable<-kable(tax_table(ForestData)[r, ])#returns a list of the most important predictors for Random Forest Classification
PredictorTable

GenusRandomForestSubset = subset_taxa(GenusAll, row.names(tax_table(GenusAll))%in% otunames)
GenusRandomForestSubset

df <- psmelt(GenusRandomForestSubset)
df$Abundance=df$Abundance*100
Trtdata <- ddply(df, c("Genus", "FFG"), summarise,
                 N    = length(Abundance),
                 mean = mean(Abundance),
                 sd   = sd(Abundance),
                 se   = sd / sqrt(N)
)
cdataplot=ggplot(Trtdata, aes(x=FFG,y=mean))+geom_bar(aes(fill = FFG),colour="black", stat="identity")+ facet_grid(~Genus)+xlab("Feeding Group")+ylab("Relative Abundance") + theme(axis.text.x = element_text(angle = 45, hjust = 1))+theme(axis.title.x=element_blank())+facet_wrap(~Genus,scales = "free_y")+geom_errorbar(aes(ymin=mean-se,ymax=mean+se))+scale_fill_manual(values=cbPalette)
cdataplot

compare_means(Abundance ~ FFG, data = df, group.by = "Genus", p.adjust.method = "fdr",method="kruskal.test")

Means<-compare_means(Abundance ~ FFG, data = df, group.by = "Genus", p.adjust.method = "fdr")
Means
Means=compare_means(Abundance ~ FFG, data = df, group.by = "Genus", p.adjust.method = "fdr")
SigList<-length(unique(Trtdata$Genus))
for (i in levels(Means$Genus)){
  Tax<-i
  TaxAbundance<-subset(Means,Genus==i )
  Hyphenated<-as.character(paste0(TaxAbundance$group1,"-",TaxAbundance$group2))
  difference<-TaxAbundance$p.adj
  names(difference)<-Hyphenated
  Letters<-multcompLetters(difference)
  #print(Letters)
  SigList[i]<-Letters

}
vec<-unlist(SigList)
vec<-vec[-1]
cdataplot=ggplot(Trtdata, aes(x=FFG,y=mean))+geom_bar(aes(fill = FFG),colour="black", stat="identity")+ facet_wrap(~Genus)+xlab("FFG")+
  ylab("Relative Abundance (%)") + theme(axis.text.x = element_text(angle = 45, hjust = 1))+theme(axis.title.x=element_blank())+
  geom_errorbar(aes(ymin=mean-se,ymax=mean+se))+geom_text(aes(x=FFG, y=mean+se+2,label=vec))+ scale_fill_manual(values=cbPalette)+
  theme_set(theme_bw(base_size = 9)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))+
  theme(legend.justification=c(0.05,0.95), legend.position=c(0.64,0.2))+ theme(legend.title = element_blank()) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))+ theme(legend.key.size = unit(0.35, "cm"))+
  theme(legend.text = element_text(size = 10))+ theme(legend.background=element_blank())+ theme(axis.title.x=element_blank())
#scale_x_discrete(labels=c("0 hrs", "24 hrs", "48 hrs","72 hrs"))+ theme(axis.text.x = element_text(angle = 45, hjust = 1))#+ scale_fill_manual(values=cbPalette)
cdataplot

dev.off()
tiff("Figures/Figure4.tiff", width = 3.3, height = 3.3, units = 'in', res = 300)
cdataplot
dev.off()

#######
#Figure 5A Faith's Div by FFG
#######
FaithByFFG<-ggplot(metadata,aes(x=Sampling_station,y=faith_pd,fill=FFG))+
  geom_boxplot()+ scale_fill_manual(values=cbPalette)+xlab("")+ylab("Faith's Phylogenetic Diversity")+labs(fill="FFG")+
  guides(fill=FALSE)+facet_wrap(~FFG)+theme(axis.title.x=element_blank())#+geom_text(aes(x=FFG, y=shannon+se+1,label=Letters$Letters2), position=position_dodge(width=0.9), size=8,color="black")#+
FaithByFFG
theme_set(theme_bw(base_size = 11)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))

dev.off()
tiff("Figures/FaithByFFG.tiff", width = 3.3, height = 3.3, units = 'in', res = 300)
FaithByFFG
dev.off()

#Figure 5B Shannon Div by FFG
#######
ShannonByFFG<-ggplot(metadata,aes(x=Sampling_station,y=shannon,fill=FFG))+
  geom_boxplot()+ scale_fill_manual(values=cbPalette)+xlab("")+ylab("Shannon Diversity")+labs(fill="FFG")+
  guides(fill=FALSE)+facet_wrap(~FFG)+theme(axis.title.x=element_blank())#+geom_text(aes(x=FFG, y=shannon+se+1,label=Letters$Letters2), position=position_dodge(width=0.9), size=8,color="black")#+
ShannonByFFG
theme_set(theme_bw(base_size = 11)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))

dev.off()
tiff("Figures/ShannonByFFG.tiff", width = 3.3, height = 3.3, units = 'in', res = 300)
ShannonByFFG
dev.off()

#####
#Figure 5C PCOA taxonomy jaccard
#####

ord=ordinate(physeq,"PCoA", "jaccard")
ordplot=plot_ordination(physeq, ord,"samples", color="FFG",shape ="FFG")+scale_colour_manual(values=cbPalette)+scale_fill_manual(values=cbPalette)
ordplotTax<-ordplot+ stat_ellipse(type= "norm",geom = "polygon", alpha = 0, aes(fill = FFG))+theme(legend.justification=c(0.05,0.95), legend.position=c(0.71,0.36))+ theme(legend.title = element_blank()) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))+#+ theme(legend.key.size = unit(0.35, "cm"))
  theme(legend.text = element_text(size = 8))+ theme(legend.background=element_blank())+geom_point(size=2.5)
ordplotTax
dev.off()
tiff("Figures/PCoATax.tiff", width = 3.3, height = 3.3, units = 'in', res = 300)
ordplotTax
dev.off()

#####
#Figure 5D PCOA PICRUSt jaccard
#####
PiCRUST<-import_biom("C:\\Users\\Joe Receveur\\Downloads\\ItalyInvertPiCRUST2.20.19.biom")
PiCRUST<-merge_phyloseq(PiCRUST,sampdat)
PiCRUST=rarefy_even_depth(PiCRUST, 750000, replace = TRUE, trimOTUs = TRUE, verbose = TRUE,rngseed = TRUE)

GPdist=phyloseq::distance(PiCRUST, "jaccard")
adonis(GPdist ~ FFG*Sampling_station, as(sample_data(PiCRUST), "data.frame"))

ord=ordinate(PiCRUST,"PCoA", "jaccard")
ordplot=plot_ordination(physeq, ord,"samples", color="FFG",shape="FFG")+geom_point(size=2.5)+scale_colour_manual(values=cbPalette)+scale_fill_manual(values=cbPalette)
ordplotFunction<-ordplot+ stat_ellipse(type= "norm",geom = "polygon", alpha = 0, aes(fill = FFG))+theme(legend.justification=c(0.05,0.95), legend.position=c(0.71,0.36))+ theme(legend.title = element_blank()) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))+#+ theme(legend.key.size = unit(0.35, "cm"))
  theme(legend.text = element_text(size = 8))+ theme(legend.background=element_blank())+geom_point(size=2.5)

ordplotFunction
dev.off()
tiff("Figures/PCoAFunction.tiff", width = 3.3, height = 3.3, units = 'in', res = 300)
ordplotFunction
dev.off()

#####
#Join together figure 5
#####

dev.off()
tiff("Figures/Figure5.tiff", width = 6.85, height = 6.85, units = 'in', res = 300)
ggarrange(FaithByFFG, ShannonByFFG, ordplotTax,ordplotFunction,
          labels = c("a", "b", "c","d"),
          ncol = 2, nrow = 2)
dev.off()

##########
#Figure Supplemental Random Forest indicator taxa Forest
############
#rm(list=ls())
set.seed(27)
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#000000","#CC79A7","#E12D00")
theme_set(theme_bw(base_size = 18)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))
biom=import_biom("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvert2018WTax.biom",parseFunction= parse_taxonomy_greengenes)
#tax_table(biom) <- tax_table(biom)[,-c(5:10,14)]#remove dummy ranks

metadata=read.csv("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvertMetadataWDiversity3.5.2019.csv",header = TRUE)
head(metadata)

tree=read_tree("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvert11.29.18Tree.nwk")

sampdat=sample_data(metadata)
sample_names(sampdat)=metadata$id
physeq=merge_phyloseq(biom,sampdat,tree)

GPr  = transform_sample_counts(physeq, function(x) x / sum(x) ) #transform samples based on relative abundance
GPr = filter_taxa(GPr, function(x) mean(x) > 1e-5, TRUE)
GenusAll=tax_glom(GPr,"Genus")
GenusAllOstanaStats<-subset_samples(GenusAll, Sampling_station=="Forest")
GenusAllOstanaStats<-subset_samples(GenusAllOstanaStats, FFG!="Predator")

ForestData=GenusAll#Change this one so you dont have to rewrite all variables
#tax_table(ForestData)[,6]
predictors=t(otu_table(ForestData))

response <- as.factor(sample_data(ForestData)$FFG)
rf.data <- data.frame(response, predictors)
MozzieForest <- randomForest(response~., data = rf.data, ntree = 1000,importance=TRUE)
varImpPlot(MozzieForest)
print(MozzieForest)#returns overall Random Forest results
imp <- importance(MozzieForest)#all the steps that are imp or imp. are building a dataframe that contains info about the taxa used by the Random Forest testto classify treatment
head((imp))

imp <- data.frame(predictors = row.names(imp), imp)
#imp
imp.sort <- arrange(imp, desc(MeanDecreaseGini))
head(imp.sort)#imp.sort$predictors <- factor(imp.sort$predictors, levels = imp.sort$predictors)
imp.sort$predictors <- factor(imp.sort$predictors, levels = imp.sort$predictors)
imp.20 <- imp.sort[1:20,]
imp.20

ggplot(imp.20, aes(x = predictors, y = MeanDecreaseGini)) +
  geom_bar(stat = "identity", fill = "indianred") +
  coord_flip() +
  ggtitle("Most important genera for classifying  samples\n by FFG")#\n in a string tells it to start a new line
#imp.20$MeanDecreaseGini
otunames <- imp.20$predictors
r <- rownames(tax_table(ForestData)) %in% otunames
otunames
PredictorTable<-kable(tax_table(ForestData)[r, ])#returns a list of the most important predictors for Random Forest Classification
PredictorTable

GenusRandomForestSubset = subset_taxa(GenusAllOstanaStats, row.names(tax_table(GenusAllOstanaStats))%in% otunames)
GenusRandomForestSubset

df <- psmelt(GenusRandomForestSubset)
df$Abundance=df$Abundance*100
Trtdata <- ddply(df, c("Genus", "FFG"), summarise,
                 N    = length(Abundance),
                 mean = mean(Abundance),
                 sd   = sd(Abundance),
                 se   = sd / sqrt(N)
)
cdataplot=ggplot(Trtdata, aes(x=FFG,y=mean))+geom_bar(aes(fill = FFG),colour="black", stat="identity")+ facet_grid(~Genus)+xlab("Feeding Group")+ylab("Relative Abundance") + theme(axis.text.x = element_text(angle = 45, hjust = 1))+theme(axis.title.x=element_blank())+facet_wrap(~Genus,scales = "free_y")+geom_errorbar(aes(ymin=mean-se,ymax=mean+se))+scale_fill_manual(values=cbPalette)
cdataplot

compare_means(Abundance ~ FFG, data = df, group.by = "Genus", p.adjust.method = "fdr",method="kruskal.test")

Means<-compare_means(Abundance ~ FFG, data = df, group.by = "Genus", p.adjust.method = "fdr")
Means
Means=compare_means(Abundance ~ FFG, data = df, group.by = "Genus", p.adjust.method = "fdr")
SigList<-length(unique(Trtdata$Genus))
for (i in levels(Means$Genus)){
  Tax<-i
  TaxAbundance<-subset(Means,Genus==i )
  Hyphenated<-as.character(paste0(TaxAbundance$group1,"-",TaxAbundance$group2))
  difference<-TaxAbundance$p.adj
  names(difference)<-Hyphenated
  Letters<-multcompLetters(difference)
  #print(Letters)
  SigList[i]<-Letters

}
vec<-unlist(SigList)
vec<-vec[-1]
cdataplot=ggplot(Trtdata, aes(x=FFG,y=mean))+geom_bar(aes(fill = FFG),colour="black", stat="identity")+ facet_wrap(~Genus)+xlab("FFG")+ylab("Relative Abundance (%) Forest") + theme(axis.text.x = element_text(angle = 45, hjust = 1))+
  theme(axis.title.x=element_blank())+geom_errorbar(aes(ymin=mean-se,ymax=mean+se))+geom_text(aes(x=FFG, y=mean+se+1,label=vec))+
  scale_fill_manual(values=cbPalette)+guides(fill=F)
cdataplot
#scale_x_discrete(labels=c("0 hrs", "24 hrs", "48 hrs","72 hrs"))+ theme(axis.text.x = element_text(angle = 45, hjust = 1))#+ scale_fill_manual(values=cbPalette)
tiff("Figures/RandomForestIndicatorsForest.tiff", width = 6.85, height = 6.85, units = 'in', res = 300)
cdataplot
dev.off()

##########
#Figure Supplemental Random Forest indicator taxa Alpine
############
rm(list=ls())
set.seed(27)
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#000000","#CC79A7","#E12D00")
theme_set(theme_bw(base_size = 18)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))
biom=import_biom("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvert2018WTax.biom",parseFunction= parse_taxonomy_greengenes)
#tax_table(biom) <- tax_table(biom)[,-c(5:10,14)]#remove dummy ranks

metadata=read.csv("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvertMetadataWDiversity3.5.2019.csv",header = TRUE)
head(metadata)

tree=read_tree("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvert11.29.18Tree.nwk")

sampdat=sample_data(metadata)
sample_names(sampdat)=metadata$id
physeq=merge_phyloseq(biom,sampdat,tree)
#physeq=rarefy_even_depth(physeq, 3000, replace = TRUE, trimOTUs = TRUE, verbose = TRUE)

GPr  = transform_sample_counts(physeq, function(x) x / sum(x) ) #transform samples based on relative abundance
GPr = filter_taxa(GPr, function(x) mean(x) > 1e-5, TRUE)
GenusAll=tax_glom(GPr,"Genus")

GenusAllOstanaStats<-subset_samples(GenusAll, Sampling_station!="Forest")

ForestData=GenusAllOstanaStats#Change this one so you dont have to rewrite all variables
predictors=t(otu_table(ForestData))
response <- as.factor(sample_data(ForestData)$FFG)
rf.data <- data.frame(response, predictors)
MozzieForest <- randomForest(response~., data = rf.data, ntree = 1000)
print(MozzieForest)#returns overall Random Forest results
imp <- importance(MozzieForest)#all the steps that are imp or imp. are building a dataframe that contains info about the taxa used by the Random Forest testto classify treatment
imp <- data.frame(predictors = rownames(imp), imp)
imp.sort <- arrange(imp, desc(MeanDecreaseGini))
imp.sort$predictors <- factor(imp.sort$predictors, levels = imp.sort$predictors)
imp.20 <- imp.sort[1:22, ]#22
ggplot(imp.20, aes(x = predictors, y = MeanDecreaseGini)) +
  geom_bar(stat = "identity", fill = "indianred") +
  coord_flip() +
  ggtitle("Most important genera for classifying  samples\n by FFG")#\n in a string tells it to start a new line
#imp.20$MeanDecreaseGini
otunames <- imp.20$predictors
r <- rownames(tax_table(ForestData)) %in% otunames
otunames
PredictorTable<-kable(tax_table(ForestData)[r, ])#returns a list of the most important predictors for Random Forest Classification
PredictorTable

GenusRandomForestSubset = subset_taxa(GenusAllOstanaStats, row.names(tax_table(GenusAllOstanaStats))%in% otunames)
GenusRandomForestSubset

df <- psmelt(GenusRandomForestSubset)
df$Abundance=df$Abundance*100
Trtdata <- ddply(df, c("Genus", "FFG"), summarise,
                 N    = length(Abundance),
                 mean = mean(Abundance),
                 sd   = sd(Abundance),
                 se   = sd / sqrt(N)
)
cdataplot=ggplot(Trtdata, aes(x=FFG,y=mean))+geom_bar(aes(fill = FFG),colour="black", stat="identity")+ facet_grid(~Genus)+xlab("Feeding Group")+ylab("Relative Abundance") + theme(axis.text.x = element_text(angle = 45, hjust = 1))+theme(axis.title.x=element_blank())+facet_wrap(~Genus,scales = "free_y")+geom_errorbar(aes(ymin=mean-se,ymax=mean+se))+scale_fill_manual(values=cbPalette)
cdataplot

compare_means(Abundance ~ FFG, data = df, group.by = "Genus", p.adjust.method = "fdr",method="kruskal.test")

Means<-compare_means(Abundance ~ FFG, data = df, group.by = "Genus", p.adjust.method = "fdr")
Means
Means=compare_means(Abundance ~ FFG, data = df, group.by = "Genus", p.adjust.method = "fdr")
SigList<-length(unique(Trtdata$Genus))
for (i in levels(Means$Genus)){
  Tax<-i
  TaxAbundance<-subset(Means,Genus==i )
  Hyphenated<-as.character(paste0(TaxAbundance$group1,"-",TaxAbundance$group2))
  difference<-TaxAbundance$p.adj
  names(difference)<-Hyphenated
  Letters<-multcompLetters(difference)
  #print(Letters)
  SigList[i]<-Letters

}
vec<-unlist(SigList)
vec<-vec[-1]
cdataplot=ggplot(Trtdata, aes(x=FFG,y=mean))+geom_bar(aes(fill = FFG),colour="black", stat="identity")+ facet_wrap(~Genus)+xlab("FFG")+
  ylab("Relative Abundance (%) Alpine Prairie") + theme(axis.text.x = element_text(angle = 45, hjust = 1))+theme(axis.title.x=element_blank())+
  geom_errorbar(aes(ymin=mean-se,ymax=mean+se))+geom_text(aes(x=FFG, y=mean+se+1,label=vec))+ scale_fill_manual(values=cbPalette)+
  guides(fill=F)
#scale_x_discrete(labels=c("0 hrs", "24 hrs", "48 hrs","72 hrs"))+ theme(axis.text.x = element_text(angle = 45, hjust = 1))#+ scale_fill_manual(values=cbPalette)
cdataplot
tiff("Figures/RandomForestIndicatorsAlpine.tiff", width = 6.85, height = 6.85, units = 'in', res = 300)
cdataplot
dev.off()

#####################
#Supplemental Fig Random Forest FFG Mean Decrease Accuracy
####################
set.seed(27)
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#000000","#CC79A7","#E12D00")
theme_set(theme_bw(base_size = 18)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))
biom=import_biom("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvert2018WTax.biom",parseFunction= parse_taxonomy_greengenes)
#tax_table(biom) <- tax_table(biom)[,-c(5:10,14)]#remove dummy ranks

metadata=read.csv("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvertMetadataWDiversity3.5.2019.csv",header = TRUE)
head(metadata)

tree=read_tree("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvert11.29.18Tree.nwk")

sampdat=sample_data(metadata)
sample_names(sampdat)=metadata$id
physeq=merge_phyloseq(biom,sampdat,tree)

GPr  = transform_sample_counts(physeq, function(x) x / sum(x) ) #transform samples based on relative abundance
GPr = filter_taxa(GPr, function(x) mean(x) > 1e-5, TRUE)
GenusAll=tax_glom(GPr,"Genus")
GenusAllOstanaStats<-subset_samples(GenusAll, Sampling_station=="Forest")
GenusAllOstanaStats<-subset_samples(GenusAllOstanaStats, FFG!="Predator")

ForestData=GenusAll#Change this one so you dont have to rewrite all variables
#tax_table(ForestData)[,6]
predictors=t(otu_table(ForestData))
#head(predictors)[,1:6]

#tax_table(ForestData)[,5:6]
#head(taxa_names(ForestData))
#colnames(predictors)<-tax_table(ForestData)[,6]
#head(predictors)
response <- as.factor(sample_data(ForestData)$FFG)
rf.data <- data.frame(response, predictors)
MozzieForest <- randomForest(response~., data = rf.data, ntree = 1000,importance=TRUE)
varImpPlot(MozzieForest)
print(MozzieForest)#returns overall Random Forest results
imp <- importance(MozzieForest)#all the steps that are imp or imp. are building a dataframe that contains info about the taxa used by the Random Forest testto classify treatment
head((imp))
#(tax_table(ForestData)[,7])<-

predictors<-paste0(tax_table(ForestData)[,6],":")

imp <- data.frame(predictors =tax_table(ForestData)[,6], imp)
imp <- data.frame(predictors =tax_table(ForestData)[,5], imp)
imp <- data.frame(predictors =row.names(tax_table(ForestData)), imp)

head(imp)
imp.sort <- arrange(imp, desc(MeanDecreaseAccuracy))
#imp.sort$predictors <- factor(imp.sort$predictors, levels = imp.sort$predictors)
head(imp.sort)

imp.20 <- imp.sort[1:20,]
imp.20$FamilyGenus<-paste0(imp.20$Family,": ",imp.20$Genus)
imp.20
RandomForestFFGMeanAccuracy<-ggplot(imp.20, aes(x = reorder(FamilyGenus,-MeanDecreaseAccuracy), y = MeanDecreaseAccuracy)) +
  geom_bar(stat = "identity", fill = "indianred") +
  coord_flip() +xlab("Family: Genus")+ylab("Mean Decrease Accuracy")
#imp.20$MeanDecreaseGini

dev.off()
tiff("Figures/FigureSupplmentalRandomForestFFGMeanAccuracyPlot.tiff", width = 3.3, height = 3.3, units = 'in', res = 300)
RandomForestFFGMeanAccuracy
dev.off()

otunames <- imp.20$predictors
r <- rownames(tax_table(ForestData)) %in% otunames
otunames
PredictorTable<-kable(tax_table(ForestData)[r, ])#returns a list of the most important predictors for Random Forest Classification
PredictorTable
#Top 10 genera for plotting
imp.10<-imp.20[1:10,]
imp.10 #
otunames <- imp.10$predictors
r <- rownames(tax_table(ForestData)) %in% otunames
otunames
PredictorTable<-kable(tax_table(ForestData)[r, ])#returns a list of the most important predictors for Random Forest Classification
PredictorTable

GenusRandomForestSubset = subset_taxa(GenusAll, row.names(tax_table(GenusAll))%in% otunames)
GenusRandomForestSubset

df <- psmelt(GenusRandomForestSubset)
df$Abundance=df$Abundance*100
Trtdata <- ddply(df, c("Genus", "FFG"), summarise,
                 N    = length(Abundance),
                 mean = mean(Abundance),
                 sd   = sd(Abundance),
                 se   = sd / sqrt(N)
)
cdataplot=ggplot(Trtdata, aes(x=FFG,y=mean))+geom_bar(aes(fill = FFG),colour="black", stat="identity")+ facet_grid(~Genus)+xlab("Feeding Group")+ylab("Relative Abundance") + theme(axis.text.x = element_text(angle = 45, hjust = 1))+theme(axis.title.x=element_blank())+facet_wrap(~Genus,scales = "free_y")+geom_errorbar(aes(ymin=mean-se,ymax=mean+se))+scale_fill_manual(values=cbPalette)
cdataplot

compare_means(Abundance ~ FFG, data = df, group.by = "Genus", p.adjust.method = "fdr",method="kruskal.test")

Means<-compare_means(Abundance ~ FFG, data = df, group.by = "Genus", p.adjust.method = "fdr")
Means
Means=compare_means(Abundance ~ FFG, data = df, group.by = "Genus", p.adjust.method = "fdr")
SigList<-length(unique(Trtdata$Genus))
for (i in levels(Means$Genus)){
  Tax<-i
  TaxAbundance<-subset(Means,Genus==i )
  Hyphenated<-as.character(paste0(TaxAbundance$group1,"-",TaxAbundance$group2))
  difference<-TaxAbundance$p.adj
  names(difference)<-Hyphenated
  Letters<-multcompLetters(difference)
  #print(Letters)
  SigList[i]<-Letters

}
vec<-unlist(SigList)
vec<-vec[-1]
cdataplot=ggplot(Trtdata, aes(x=FFG,y=mean))+geom_bar(aes(fill = FFG),colour="black", stat="identity")+ facet_wrap(~Genus)+xlab("FFG")+
  ylab("Relative Abundance (%)") + theme(axis.text.x = element_text(angle = 45, hjust = 1))+theme(axis.title.x=element_blank())+
  geom_errorbar(aes(ymin=mean-se,ymax=mean+se))+geom_text(aes(x=FFG, y=mean+se+2,label=vec))+ scale_fill_manual(values=cbPalette)+
  theme_set(theme_bw(base_size = 9)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))+
  theme(legend.justification=c(0.05,0.95), legend.position=c(0.64,0.2))+ theme(legend.title = element_blank()) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))+ theme(legend.key.size = unit(0.35, "cm"))+
  theme(legend.text = element_text(size = 10))+ theme(legend.background=element_blank())+ theme(axis.title.x=element_blank())
#scale_x_discrete(labels=c("0 hrs", "24 hrs", "48 hrs","72 hrs"))+ theme(axis.text.x = element_text(angle = 45, hjust = 1))#+ scale_fill_manual(values=cbPalette)
cdataplot

dev.off()
tiff("Figures/FigureSupplmentalRandomForestFFGMeanAccuracy.tiff", width = 3.3, height = 3.3, units = 'in', res = 300)
cdataplot
dev.off()

###############
#Supplemental Fig Random Forest Location Mean Decrease Accuracy
##############
set.seed(27)
cbPalette <- c("#999999", "#E69F00", "#56B4E9", "#009E73", "#F0E442", "#0072B2", "#D55E00", "#000000","#CC79A7","#E12D00")
theme_set(theme_bw(base_size = 18)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))
biom=import_biom("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvert2018WTax.biom",parseFunction= parse_taxonomy_greengenes)

metadata=read.csv("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvertMetadataWDiversity3.5.2019.csv",header = TRUE)
head(metadata)

tree=read_tree("C:\\Users\\Joe Receveur\\Documents\\MSU data\\ItalyInverts\\ItalyInvert11.29.18Tree.nwk")

sampdat=sample_data(metadata)
sample_names(sampdat)=metadata$id
physeq=merge_phyloseq(biom,sampdat,tree)

GPr  = transform_sample_counts(physeq, function(x) x / sum(x) ) #transform samples based on relative abundance
GPr = filter_taxa(GPr, function(x) mean(x) > 1e-5, TRUE)
GenusAll=tax_glom(GPr,"Genus")

ForestData=GenusAll#Change this one so you dont have to rewrite all variables
predictors=t(otu_table(ForestData))

response <- as.factor(sample_data(ForestData)$Sampling_Station)
rf.data <- data.frame(response, predictors)
MozzieForest <- randomForest(response~., data = rf.data, ntree = 1000,importance=TRUE)
varImpPlot(MozzieForest)
print(MozzieForest)#returns overall Random Forest results
imp <- importance(MozzieForest)#all the steps that are imp or imp. are building a dataframe that contains info about the taxa used by the Random Forest testto classify treatment
head((imp))
#(tax_table(ForestData)[,7])<-

#predictors<-paste0(tax_table(ForestData)[,6],":")

imp <- data.frame(predictors =tax_table(ForestData)[,6], imp)
imp <- data.frame(predictors =tax_table(ForestData)[,5], imp)
imp <- data.frame(predictors =row.names(tax_table(ForestData)), imp)

head(imp)
imp.sort <- arrange(imp, desc(MeanDecreaseAccuracy))
#imp.sort$predictors <- factor(imp.sort$predictors, levels = imp.sort$predictors)
head(imp.sort)

imp.20 <- imp.sort[1:20,]
imp.20$FamilyGenus<-paste0(imp.20$Family,": ",imp.20$Genus)
imp.20
RandomForestStationMeanAccuracy<-ggplot(imp.20, aes(x = reorder(FamilyGenus,-MeanDecreaseAccuracy), y = MeanDecreaseAccuracy)) +
  geom_bar(stat = "identity", fill = "indianred") +
  coord_flip() +xlab("Family: Genus")+ylab("Mean Decrease Accuracy")
#imp.20$MeanDecreaseGini
theme_set(theme_bw(base_size = 8)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))

dev.off()
tiff("Figures/FigureSupplmentalRandomForestLocationMeanAccuracyPlot.tiff", width = 3.3, height = 3.3, units = 'in', res = 300)
RandomForestStationMeanAccuracy
dev.off()

otunames <- imp.20$predictors
r <- rownames(tax_table(ForestData)) %in% otunames
otunames
PredictorTable<-kable(tax_table(ForestData)[r, ])#returns a list of the most important predictors for Random Forest Classification
PredictorTable
#Top 10 genera for plotting
imp.10<-imp.20[1:10,]
imp.10 #
otunames <- imp.10$predictors
r <- rownames(tax_table(ForestData)) %in% otunames
otunames
PredictorTable<-kable(tax_table(ForestData)[r, ])#returns a list of the most important predictors for Random Forest Classification
PredictorTable

GenusRandomForestSubset = subset_taxa(GenusAll, row.names(tax_table(GenusAll))%in% otunames)
GenusRandomForestSubset

df <- psmelt(GenusRandomForestSubset)
df$Abundance=df$Abundance*100
Trtdata <- ddply(df, c("Genus", "Sampling_station"), summarise,
                 N    = length(Abundance),
                 mean = mean(Abundance),
                 sd   = sd(Abundance),
                 se   = sd / sqrt(N)
)
cdataplot=ggplot(Trtdata, aes(x=Sampling_station,y=mean))+geom_bar(aes(fill = Sampling_station),colour="black", stat="identity")+ facet_grid(~Genus)+xlab("Sampling Station")+
  ylab("Relative Abundance") + theme(axis.text.x = element_text(angle = 45, hjust = 1))+theme(axis.title.x=element_blank())+facet_wrap(~Genus,scales = "free_y")+geom_errorbar(aes(ymin=mean-se,ymax=mean+se))+scale_fill_manual(values=cbPalette)
cdataplot

compare_means(Abundance ~ Sampling_station, data = df, group.by = "Genus", p.adjust.method = "fdr",method="kruskal.test")

Means<-compare_means(Abundance ~ Sampling_station, data = df, group.by = "Genus", p.adjust.method = "fdr")
Means
Means=compare_means(Abundance ~ Sampling_station, data = df, group.by = "Genus", p.adjust.method = "fdr")
SigList<-length(unique(Trtdata$Genus))
for (i in levels(Means$Genus)){
  Tax<-i
  TaxAbundance<-subset(Means,Genus==i )
  Hyphenated<-as.character(paste0(TaxAbundance$group1,"-",TaxAbundance$group2))
  difference<-TaxAbundance$p.adj
  names(difference)<-Hyphenated
  Letters<-multcompLetters(difference)
  #print(Letters)
  SigList[i]<-Letters

}
vec<-unlist(SigList)
vec<-vec[-1]
cdataplot=ggplot(Trtdata, aes(x=Sampling_station,y=mean))+geom_bar(aes(fill = Sampling_station),colour="black", stat="identity")+ facet_wrap(~Genus)+xlab("Sampling Station")+
  ylab("Relative Abundance (%)") + theme(axis.text.x = element_text(angle = 45, hjust = 1))+theme(axis.title.x=element_blank())+
  geom_errorbar(aes(ymin=mean-se,ymax=mean+se))+geom_text(aes(x=Sampling_station, y=mean+se+2,label=vec))+ scale_fill_manual(values=cbPalette)+
  theme_set(theme_bw(base_size = 9)+theme(panel.grid.major = element_blank(), panel.grid.minor = element_blank()))+
  theme(legend.justification=c(0.05,0.95), legend.position=c(0.64,0.2))+ theme(legend.title = element_blank()) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1))+ theme(legend.key.size = unit(0.35, "cm"))+
  theme(legend.text = element_text(size = 10))+ theme(legend.background=element_blank())+ theme(axis.title.x=element_blank())
#scale_x_discrete(labels=c("0 hrs", "24 hrs", "48 hrs","72 hrs"))+ theme(axis.text.x = element_text(angle = 45, hjust = 1))#+ scale_fill_manual(values=cbPalette)
cdataplot

dev.off()
tiff("Figures/FigureSupplmentalRandomForestSampling_StationMeanAccuracy.tiff", width = 3.3, height = 3.3, units = 'in', res = 300)
cdataplot
dev.off()