#testing for observation uncertainty at the site level for fungal functional groups.
rm(list=ls())
source('paths.r')
source('NEFI_functions/tic_toc.r')
library(doParallel)
library(DirichletReg)

#set output path.----
output.path <- NEON_sampling_effort_analysis_plot.level_16S.path

#detect and register cores.----
n.cores <- detectCores()
registerDoParallel(cores=n.cores)

#load data - focus on Harvard Forest (HARV) - 50 unique soil cores.----
dat <- readRDS(NEON_16S_phylo_fg_abundances.path)
dat <- as.data.frame(dat$phylum$abundances)

# read in obs table that links deprecatedVialID and geneticSampleID
map <- readRDS(core_obs_data.path)

#match up data, subset to mineral soil, drop stuff from identical locations.----
map <- map[,c("deprecatedVialID", "geneticSampleID")]
map$geneticSampleID <- gsub('-GEN','',map$geneticSampleID)
dat$deprecatedVialID <- rownames(dat)
dat <- merge(dat, map, by = "deprecatedVialID")
rownames(dat) <- dat$geneticSampleID
dat$deprecatedVialID <- NULL

dat$site <- substr(dat$geneticSampleID, 1, 4)
dat$plot <- substr(dat$geneticSampleID, 1, 8)
dat$horizon <- substr(dat$geneticSampleID,10,10)
dat <- dat[dat$horizon == 'M',]
all.dat <- dat
filter <- table(all.dat$plot)
filter <- filter[filter > 4]
all.dat <- all.dat[all.dat$plot %in% names(filter),]
#dat <- dat[dat$site == 'HARV',]
plots <- unique(all.dat$plot)
sites <- unique(all.dat$site)

#sampling depths and number of trials.
potential.n.samp <- c(2,3,4,5)
n.trial <- 1000

#run simulation.----
cat(paste0('Running bootstrap simulation for ',n.trial,' iterations across ',length(plots),' plots...\n'))
tic()
super.super.out <- list()
for(k in 1:length(plots)){
  dat <- all.dat[all.dat$plot == plots[k],]
  dat[,c("geneticSampleID", "plot", "site", "horizon")] <- NULL
  #  dat <- dat[,c('other','Ectomycorrhizal','Arbuscular','Saprotroph','Pathogen')]
  dat <- (dat + 1)
  dat <- dat/rowSums(dat)
  n.samp <- potential.n.samp[potential.n.samp <= nrow(dat)]
  super.out <-
    foreach(j = 1:n.trial) %dopar% {
      output <- list()
      for(i in 1:length(n.samp)){
        #sample your dataset.
        sample <- data.frame(dat[sample(nrow(dat), size = n.samp[i], replace = F),])
        sample$Y <- DR_data(sample[,1:ncol(sample)])
        #fit dirichlet interecept.
        mod <- DirichReg(Y ~ 1, data = sample)
        mult <- sum(mod$fitted.values$alpha[1,])
        output[[i]] <- mult
      }
      output <- unlist(output)
      return(output)
    }
  super.out <- do.call(rbind, super.out)
  colnames(super.out) <- n.samp
  #expand super.out into 2 column- y and n.samp.
  y <- as.vector(super.out)
  lab <- list()
  for(i in 1:length(n.samp)){
    lab[[i]] <- rep(n.samp[i],n.trial)
  }
  lab <- unlist(lab)
  super.out2 <- data.frame(y, lab)
  colnames(super.out2) <- c('mu','n.samp')
  super.super.out[[k]] <- super.out2
  cat(paste0(k,' of ',length(plots),' plots fitted.\n'))
}
names(super.super.out) <- plots
cat('Simulation complete.');toc()

#Save output for downstream analysis.----
saveRDS(super.super.out, output.path)


# Copyright 2020 The MuLT Authors. All Rights Reserved.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
# ==============================================================================

##

clinical_mic <- read.csv('output/correlation_clinical_x_m2dp.csv', sep=',', header=T)
clinical_mic$resp <- 'M2DP (MIC)'

clinical_pva <- read.csv('output/correlation_clinical_x_brft.csv', sep=',', header=T)
clinical_pva$metric = 1 - clinical_pva$metric
clinical_pva$resp <- 'BRFT_G3 (1 - pvalue)'

clinical <- rbind(clinical_mic, clinical_pva)
clinical[is.na(clinical)] = 0
clinical$feature = sapply(clinical$feature, function(x) toupper(substr(x, 0, 25)))

##

fish_mic <- read.csv('output/correlation_fish_x_m2dp.csv', sep=',', header=T)
fish_mic$resp <- 'M2DP (MIC)'

fish_pva <- read.csv('output/correlation_fish_x_brft.csv', sep=',', header=T)
fish_pva$metric = 1 - fish_pva$metric
fish_pva$resp <- 'BRFT_G3 (1 - pvalue)'

fish <- rbind(fish_mic, fish_pva)
fish[is.na(fish)] = 0
fish$feature = sapply(fish$feature, function(x) toupper(substr(x, 0, 25)))

##

genexp_mic <- read.csv('output/correlation_geneexp_x_m2dp.csv', sep=',', header=T)
genexp_mic$resp <- 'M2DP (MIC)'

genexp_pva <- read.csv('output/correlation_geneexp_x_brft.csv', sep=',', header=T)
genexp_pva$metric = 1 - genexp_pva$metric
genexp_pva$resp <- 'BRFT_G3 (1 - pvalue)'

genexp <- rbind(genexp_mic, genexp_pva)

##
require(ggplot2)

p <- ggplot(clinical) +
  geom_bar(stat='identity', aes(feature, metric), colour='gray28', alpha=.6) +
  facet_grid(. ~ resp) +
  theme(text=element_text(size=11, family='serif')) +
  xlab('Feature') + ylab('Correlation Metric Value') +
  coord_flip()

ggsave('images/correlation_clinical.png', p, width=16, height=20, units='cm')

p <- ggplot(fish) +
  geom_bar(stat='identity', aes(feature, metric), colour='gray28', alpha=.6) +
  facet_grid(. ~ resp) +
  theme(text=element_text(size=11, family='serif')) +
  xlab('Feature') + ylab('Correlation Metric Value') +
  coord_flip()

ggsave('images/correlation_fish.png', p, width=16, height=14, units='cm')

##

p <- ggplot(genexp) +
  geom_histogram(aes(metric), colour='gray28', alpha=.6) +
  facet_grid(. ~ resp, scales = "free_x") +
  theme(text=element_text(size=15, family='serif')) +
  xlab('Correlation Metric Value') + ylab('Count')

ggsave('images/correlation_genexp.png', p, width=16, height=8, units='cm')


cleanPopulationData <- function(pop_df) {
	# add missing population values:
	if(dim(pop_df)[1] != length(unique(pop_df$Identity)) * length(unique(pop_df$Generation))) {
		added_rows <- expand.grid(Identity = unique(pop_df$Identity), Generation = unique(pop_df$Generation))
		added_props <- group_by(pop_df, Identity) %>%
			slice(1) %>%
			ungroup() %>%
			select(-one_of("Generation", "Population"))
		added_rows <- merge(added_rows, added_props, all = TRUE)
		pop_df <- merge(added_rows, pop_df, all = TRUE)
		pop_df[is.na(pop_df$Population), "Population"] <- 0
		pop_df <- arrange_(pop_df, ~Generation)
		warning("missing population sizes replaced by zeroes")
	}

	if (!missing(add_zeroes)) {
		warning("argument add_zeroes is deprecated (it is now always TRUE).",
				call. = FALSE)
	}
	if (!missing(smooth_start_points)) {
		warning("argument smooth_start_points is deprecated (it is now always TRUE).",
				call. = FALSE)
	}
	if (!missing(threshold)) {
		warning("argument threshold is deprecated (use cutoff instead, noting that genotypes whose abundance never exceeds the cutoff value are removed,
            whereas previously genotypes whose abundance never exceeded *twice* the threshold value were removed).",
				call. = FALSE)
		if (missing(cutoff)) cutoff <- threshold * 2
	}

	# check/set column names:
	if(!("Generation" %in% colnames(pop_df)) | !("Identity" %in% colnames(pop_df)) | !("Generation" %in% colnames(pop_df)))
		stop("colnames(pop_df) must contain Generation (or Time), Identity and Population")

	if(!is.na(edges)[1]) {
		set1 <- unique(pop_df$Identity)
		set2 <- unique(edges$Identity)
		set3 <- unique(edges$Parent)
		# check that pop_df and edges have compatible Identity values:
		if(length(setdiff(set1, set2)) != 1) stop("Identity values in edges must match Identity values in pop_df, excluding the original genotype (which has no parent)")
		# check that Parent and Identity values in edges are consistent:
		if(length(setdiff(set3, set2)) != 1) stop("Parent values in edges must also appear as Identity values in edges, excluding the original genotype (which has no parent)")
	}

	if(!is.na(edges)[1]) {
		if("phylo" %in% class(edges)) {
			collapse.singles(edges)
			edges <- edges$edge
		}
		edges <- na.omit(edges) # remove any rows containing NA
		colnames(edges) <- c("Parent", "Identity")
		if(is.factor(edges$Parent)) edges$Parent <- levels(edges$Parent)[edges$Parent]
		if(is.factor(edges$Identity)) edges$Identity <- levels(edges$Identity)[edges$Identity]
	}

	return(pop_df)
}

find_start_positions <- function(pop_df, start_positions = 0.5) {
	# set small time interval:
	all_gens_list <- unique(pop_df$Generation)
	delta <- abs(min(1E-2 * min(diff(all_gens_list)), 1E-4 * (max(all_gens_list) - min(all_gens_list))))
	start_positions <- max(start_positions, delta)
	start_positions <- min(start_positions, 1 - delta)

	return(start_positions)
}

filename <- "/home/cld100/Documents/github/muller_diagrams/5G/tables/5_genotypes.timeseries.ggmuller.populations.tsv"
pop_df <- read.csv(filename, sep = "\t", header = TRUE)
pop_df <- cleanPopulationData(pop_df)
result <- find_start_positions(pop_df)


f <- function(x,y) -x*x - 0.5*y*y

context("Grid search")

test_that("grid_search works", {
  solution <- grid_search(f, x=c(-5,1,5), y=c(-5,1,5) )
  expect_equal( solution$stats$num_evals, 9)
  expect_equal( solution$optimum, f(1,1) )
})

test_that("grid_search works", {
  solution <- grid_search(f, x=c(-5,1,5), y=c(1) )
  expect_equal( solution$stats$num_evals, 3)
  expect_equal( solution$optimum, f(1,1) )
})

context("Random search")

test_that("random_search works", {
  solution <- random_search(f, x=c(-5,5), y=c(-5,5), num_evals=40 )
  expect_equal( solution$stats$num_evals, 40)
})

context("Nelder-mead")

test_that("nelder_mead works", {
  solution <- nelder_mead(f, x=5, y=-5, num_evals=40 )
  expect_true( solution$stats$num_evals < 40)
})

context("Particle swarm")

test_that("particle_swarm works", {
  solution <- particle_swarm(f, x=c(-5,5), y=c(-5,5), num_particles=10, num_generations=4 )
  expect_true( solution$stats$num_evals <= 40)
})

test_that("particle_swarm gives error if bound has 1 value", {
  expect_error( {particle_swarm(f, x=c(5, 10), y=c(3) )} )
})

test_that("particle_swarm gives error if bound has 3 values", {
  expect_error( {particle_swarm(f, x=c(5, 10), y=c(3,4,5) )} )
})

test_that("particle_swarm gives error if bound has 3 values", {
  expect_error( {particle_swarm(f, x=c(10, 5), y=c(3,4) )}, regex="lower bound" )
})

test_that("particle_swarm gives error if bound is not numeric", {
  expect_error( {particle_swarm(f, x=c("5", "10"), y=c(4,6), regex="have to be numeric")} )
})

#context("CMA-ES")
#
#test_that("cma_es works", {
#  solution <- cma_es(f, x=5, y=-5, num_generations=6 )
#  expect_equal( do.call(f, solution$solution), solution$optimum, tolerance=1e-5)
#})


############################################################################################################
############################################################################################################
## Loading necessary libraries
############################################################################################################
############################################################################################################

library(ggplot2)
library(gridExtra)
library(lme4)
library(lmerTest)
library(robustlmm)
library(MCMCglmm)
library(xtable)
library(shinyBS)
library(nlme)
library(combinat)

############################################################################################################
############################################################################################################
## Global functions
############################################################################################################
############################################################################################################

ggCaterpillar=function(re, QQ=TRUE, likeDotplot=TRUE)
{
  require(ggplot2)
  f = function(x) {
    pv=attr(x, "postVar")
    cols=1:(dim(pv)[1])
    se=unlist(lapply(cols, function(i) sqrt(pv[i, i, ])))
    ord=unlist(lapply(x, order)) + rep((0:(ncol(x) - 1)) * nrow(x), each=nrow(x))
    pDf=data.frame(y=unlist(x)[ord],ci=1.96*se[ord],nQQ=rep(qnorm(ppoints(nrow(x))), ncol(x)),
                   ID=factor(rep(rownames(x), ncol(x))[ord], levels=rownames(x)[ord]), ind=gl(ncol(x), nrow(x), labels=names(x)))

    if(QQ) {
      p = ggplot(pDf, aes(nQQ, y))
      p = p + facet_wrap(~ ind, scales="free")
      p = p + xlab("Standard normal quantiles") + ylab("Random effect quantiles")
    } else {
      p = ggplot(pDf, aes(ID, y)) + coord_flip() + ggtitle("Caterpillar plot showing the group-level\nerror terms for each random effect")
      if(likeDotplot) {
        p = p + facet_wrap(~ ind)
      } else {
        p = p + facet_grid(ind ~ ., scales="free_y")
      }
      p = p + xlab("Groups") + ylab("Deviations")
    }

    p = p + theme_bw() + theme(legend.position="none") + geom_hline(yintercept=0) +
      geom_errorbar(aes(ymin=y-ci, ymax=y+ci), width=0, colour="black") + geom_point(aes(size=2), shape=1)

    return(p)
  }
  lapply(re, f)
}

############################################################################################################
############################################################################################################
## Loading sample data sets
############################################################################################################
############################################################################################################

kentucky=read.csv("data/KentuckyMathScores.csv")
music=read.csv("data/musicdata.csv")

############################################################################################################
############################################################################################################
## Shiny server
############################################################################################################
############################################################################################################

shinyServer(function(input, output, session) {

  ############################################################################################################
  ############################################################################################################
  ## Upload Data Panel
  ############################################################################################################
  ############################################################################################################

  data = reactive({
    if(is.null(input$file) & !input$usesample)
    {
      return(NULL)
    } else if(!is.null(input$file) & !input$usesample)
    {
      file = read.csv(input$file$datapath, header=input$header, sep=input$sep, quote=input$quote)
      return(file)
    } else if(input$usesample)
    {
      return(music)
    }
    })

  output$datatable = renderDataTable({
    if(!input$usesample)
    {
      return(data())
    }
  })

  output$sampledata = renderDataTable({
    data()
  })

  output$selectresponse = renderUI({
    selectInput("response","Response variable:",choices=names(data()),selectize=TRUE)
  })

  output$selectlevel1fixedpred = renderUI({
    selectInput("level1.fixed.pred","Level 1 fixed predictors:",choices=names(data()),multiple=TRUE,selectize=TRUE)
  })

  output$selectlevel1randpred = renderUI({
    selectInput("level1.rand.pred","Level 1 random predictors:",choices=names(data()),multiple=TRUE,selectize=TRUE)
  })

  output$selectlevel2id = renderUI({
    selectInput("level2.id","Level 2 observational unit:",choices=names(data()),selectize=TRUE)
  })

  output$selectlevel2pred = renderUI({
    selectInput("level2.pred","Level 2 predictors",choices=names(data()),multiple=TRUE,selectize=TRUE)
  })

  ############################################################################################################
  ############################################################################################################
  ## HLM Study Panel
  ############################################################################################################
  ############################################################################################################

  ############################################################################################################
  ############################################################################################################
  ## Varying-Intercept Only
  ############################################################################################################
  ############################################################################################################

  output$selectresponse1 = renderUI({
    selectInput("response1","Response variable:",choices=names(data()),selectize=TRUE)
  })

  output$selectlevel2id1 = renderUI({
    selectInput("level2.id1","Level 2 observational unit:",choices=names(data()),selectize=TRUE)
  })

  dat.nopred = reactive({
     if(!input$usesample)
     {
       dat = data.frame(response = data()[,paste(input$response1)],
                        level2.id = factor(data()[,paste(input$level2.id1)]))
       return(dat)
     } else if (input$usesample)
    {
      dat = data.frame(response = data()$negative_affect,
                       level2.id = factor(data()$id))
    }
  })

  output$datatab1 = renderDataTable({
    if(!input$usesample) return(dat.nopred())
  })

  label = reactive({
    if(!input$usesample)
    {
      return(c(paste(input$response1),paste(input$level2.id1)))
    }else if(input$usesample)
    {
      return(c("negative affect","musicians"))
    }
  })

  ############################################################################################################
  ## Pooled Regression 1
  ############################################################################################################

  output$poolednopredgraph = renderPlot({
    ggplot(data=dat.nopred()) + geom_histogram(aes(x=response),fill="white",color="navy") +
      xlab(paste(label()[1])) + ylab("Frequency") + ggtitle(paste("Histogram of",label()[1],"with pooled mean imposed")) +
      theme_bw() + geom_vline(aes(xintercept=mean(response)),linetype="dashed",color="navy")
  })

  pooled.mod.nopred = reactive({
    lm(response~1, data=dat.nopred())
  })

  output$pooled.nopred.info = renderUI({
    mean = round(mean(dat.nopred()$response,na.rm=TRUE),digits=3)
    p(HTML("
 y&#773all = pooled mean ="), code(paste0(mean)))
  })

  ############################################################################################################
  ## Unpooled Regression 1
  ############################################################################################################

  output$unpooled.nopred.graph = renderPlot({
    ggplot(data=dat.nopred(),aes(x=level2.id,y=response)) + geom_hline(aes(yintercept=mean(response)),linetype="dashed",color="navy") +
      geom_boxplot(fill="white",color="navy") + xlab(paste(label()[2])) + ylab(paste(label()[1])) +
      ggtitle(paste("Boxplots of",label()[1],"by",label()[2],"with pooled and unpooled means imposed")) +
      theme_bw() + theme(axis.text.x=element_text(angle=90)) +
      stat_summary(fun.y="mean", geom="point", shape=1, size=3, fill="white", color="gold2")
  })

  unpooled.mod.nopred = reactive({
    lm(response~level2.id+0, data=dat.nopred())
  })

  output$unpooled.mod.summary = renderTable({
    anova(unpooled.mod.nopred())
  })

  output$unpooled.nopred.info = renderDataTable({
    mean.dat = data.frame(tapply(dat.nopred()$response,dat.nopred()$level2.id,mean,na.rm=TRUE))
    mean = round(as.numeric(mean.dat[,1]),digits=3)
    var = round(as.numeric(tapply(dat.nopred()$response,dat.nopred()$level2.id,var,na.rm=TRUE)))
    n = as.numeric(tapply(dat.nopred()$response,dat.nopred()$level2.id, function(x) length(!is.na(x))))

    dat = data.frame(ID=rownames(mean.dat),Mean=mean,Variance=var,n=n)
    return(dat)
  })

  ############################################################################################################
  ## Hierarchical Linear Model 1
  ############################################################################################################

  hlm.mod.nopred = reactive({
    lmer(response ~ 1 + (1|level2.id), data=dat.nopred(),
         control=lmerControl(optCtrl=list(maxfun=50000)))
  })

  output$hlm.nopred1 = renderPrint({
    summary(hlm.mod.nopred())
  })

  coefs = reactive({
    data.frame(coef=coef(hlm.mod.nopred())$level2.id,ran=ranef(hlm.mod.nopred())$level2.id)
  })

  output$hlm.nopred2 = renderTable({
    conf = confint(hlm.mod.nopred(),method="boot")
    colnames(conf) = c("95% Lower Bound","95% Upper Bound")
    rownames(conf) = c("Between-group SD","Within-group SD","Intercept")
    return(conf)
  })

  output$intraclass1 = renderUI({
    withMathJax("$$\\hat{\\rho} = \\frac{\\hat{\\sigma}_\\alpha^{2}}{\\hat{\\sigma}_\\alpha^{2}+\\hat{\\sigma}_y^{2}}$$")
  })

  variances = reactive({
    c(round(as.numeric(attr(VarCorr(hlm.mod.nopred())[[1]],"stddev")^2),digits=3),
      round(as.numeric(attr(VarCorr(hlm.mod.nopred()),"sc")^2),digits=3))
  })

  output$calcintraclass1 = renderUI({
    icc = round(variances()[1]/sum(variances()),digits=3)

    p("ICC =",code(paste(variances()[1]))," / (",
      code(paste(variances()[1])),"+",
      code(paste(variances()[2])),") = ",
      code(paste(icc)))
  })

  output$ratio1 = renderUI({
    withMathJax("$$Variance\\,ratio = \\frac{\\hat{\\sigma}_y^{2}}{\\hat{\\sigma}_\\alpha^{2}}$$")
  })

  output$calcratiovariances1 = renderUI({
    ratio = round(variances()[2]/variances()[1],digits=3)

    p("Ratio =",code(paste(variances()[2]))," / ",
      code(paste(variances()[1])), " = ", code(paste(ratio)))
  })

  output$hlmdist1 = renderPlot({
    ggplot(data=coefs(),aes(x=X.Intercept.)) + geom_histogram(color="seagreen2",fill="white") +
      xlab("HLM means") + ylab("Frequency") + ggtitle("Histogram of HLM means") + theme_bw()
  })

  output$hlmdisterror1 = renderPlot({
    ggplot(data=coefs(),aes(x=X.Intercept..1)) + geom_histogram(color="salmon",fill="white") +
      xlab("Group-level intercept errors") + ylab("Frequency") +
      ggtitle("Histogram of group-level intercept errors") + theme_bw()
  })

  output$hlmdistinfo1 = renderUI({
    p(HTML("

"),withMathJax("\\(\\hat{\\mu}_{\\alpha} =\\)"),code(paste(round(as.numeric(fixef(hlm.mod.nopred())),digits=3))),
      HTML("

"),withMathJax("\\(\\hat{\\sigma}_\\alpha^{2} =\\)"),code(paste(variances()[1])),HTML("
"))
  })

  output$hlmtable = renderDataTable({
    mean.dat = data.frame(tapply(dat.nopred()$response,dat.nopred()$level2.id,mean,na.rm=TRUE))
    n = as.numeric(tapply(dat.nopred()$response,dat.nopred()$level2.id, function(x) length(!is.na(x))))
    rancoefs = round(coefs()$X.Intercept..1,digits=3)
    coefs = round(coefs()$X.Intercept.,digits=3)

    dat = matrix(c(rownames(mean.dat),coefs,rancoefs,n),ncol=4)
    colnames(dat) = c("Group","Estimated intercept","Group-level error","Sample size")
    return(dat)
  })

  output$ggcat1 = renderPlot({
    ggCaterpillar(ranef(hlm.mod.nopred(), condVar=TRUE), QQ=FALSE)
  })

  ############################################################################################################
  ## Comparison of Methods 1
  ############################################################################################################

  output$shrinkplot = renderPlot({
    samplesize = tapply(dat.nopred()$response,dat.nopred()$level2.id, function(x) length(x))
    ind = order(samplesize)
    hlmmean = as.vector(unlist(coef(hlm.mod.nopred())))
    hlmmean = hlmmean[ind]
    hlmse = sqrt(attr(ranef(hlm.mod.nopred(), condVar = TRUE)[[1]], "postVar")[1, , ])/samplesize
    hlmse = hlmse[ind]
    unpooledse = tapply(dat.nopred()$response,dat.nopred()$level2.id, function(x) sd(x,na.rm=TRUE)/sqrt(length(x)))
    unpooledse = unpooledse[ind]
    unpooledmean = tapply(dat.nopred()$response,dat.nopred()$level2.id,mean,na.rm=TRUE)
    unpooledmean = unpooledmean[ind]
    groups = levels(factor(dat.nopred()$level2.id))
    groups = groups[ind]
    samplesize1 = samplesize[ind]
    dat = data.frame(hlmse=hlmse,hlmmean=hlmmean,unpooledse=unpooledse,unpooledmean=unpooledmean,groups=groups,
                     n=samplesize1)
    mean = data.frame(x=mean(dat.nopred()$response),na.rm=TRUE)

    g1=ggplot() + theme_bw() + geom_point(data=dat,aes(x=groups,y=unpooledmean,color="Unpooled"),shape=1) +
      geom_point(data=dat,aes(x=groups,y=hlmmean,color="HLM"),shape=16) +
      geom_hline(data=mean,aes(yintercept=x,color="Pooled"),linetype="dashed") +
      geom_errorbar(data=dat,aes(x=groups,y=unpooledmean,ymin=unpooledmean-1.96*unpooledse,ymax=unpooledmean+1.96*unpooledse,color="Unpooled")) +
      geom_errorbar(data=dat,aes(x=groups,y=hlmmean,ymin=hlmmean-1.96*hlmse,ymax=hlmmean+1.96*hlmse,color="HLM")) +
      ylab("Mean") + xlab("Group") + ggtitle("Shrinkage plot: 95% CIs using unpooled method and HLM with pooled mean imposed") +
      scale_color_manual(name="Modelling method",values=c("HLM"="tomato","Unpooled"="gold2","Pooled"="navy")) + theme(legend.position="bottom")

    g2=ggplot() + theme_bw() + geom_histogram(data=dat,aes(x=unpooledmean,y=..density..,fill="Unpooled"),alpha=.5) +
      geom_histogram(data=dat,aes(x=hlmmean,y=..density..,fill="HLM"),alpha=.5) +
      geom_density(data=dat,aes(x=unpooledmean),color="gold2") +
      geom_density(data=dat,aes(x=hlmmean),color="tomato") +
      geom_vline(data=mean,aes(xintercept=x,fill="Pooled"),color="navy",linetype="dashed") +
      scale_fill_manual(name="Modelling method",values=c("HLM"="tomato","Unpooled"="gold2","Pooled"="navy")) +
      theme(legend.position="bottom") + ylab("Relative frequency") + xlab("Mean") + ggtitle("Histogram of unpooled and HLM means with pooled mean imposed")

    g3 = arrangeGrob(g1,g2,nrow=1)
    return(g3)
  },height=500)

  ############################################################################################################
  ## Bayesian Hierarchical Linear Model 1
  ############################################################################################################

  hlmbayes1 = reactive({
    MCMCglmm(response ~ 1, random=~level2.id, data=dat.nopred(), verbose=FALSE, pr=TRUE)
  })

  output$hlm.bayes1 = renderPrint({
    summary(hlmbayes1())
  })

  output$postdist = renderPlot({
    group.error = data.frame(x=as.vector(hlmbayes1()$VCV[,1]))
    indiv.error = data.frame(x=as.vector(hlmbayes1()$VCV[,2]))
    int = data.frame(x=as.vector(hlmbayes1()$Sol[,1]))

    group.plot = ggplot(data=group.error) + geom_density(aes(x=x)) + theme_bw() + ylab("") + xlab("Between-group var in response") +
                   geom_vline(aes(xintercept=mean(x)),color="seagreen2",size=1)
    group.trace = ggplot(data=group.error) + geom_line(aes(x=1:length(x),y=x)) + theme_bw() +
                    geom_hline(aes(yintercept=mean(x)),color="seagreen2",size=1) +
                    xlab("Iteration") + ylab("Between-group\nvar in response")
    indiv.plot = ggplot(data=indiv.error) + geom_density(aes(x=x)) + theme_bw() + ylab("") + xlab("Within-group var in response") +
                   geom_vline(aes(xintercept=mean(x)),color="seagreen2",size=1)
    indiv.trace = ggplot(data=indiv.error) + geom_line(aes(x=1:length(x),y=x)) + theme_bw() +
                    geom_hline(aes(yintercept=mean(x)),color="seagreen2",size=1) +
                    xlab("Iteration") + ylab("Within-group\nvar in response")
    int.plot = ggplot(data=int) + geom_density(aes(x=x)) + theme_bw() + ylab("") + xlab("Intercept") +
                 geom_vline(aes(xintercept=mean(x)),color="seagreen2",size=1)
    int.trace = ggplot(data=int) + geom_line(aes(x=1:length(x),y=x)) + theme_bw() +
                  geom_hline(aes(yintercept=mean(x)),color="seagreen2",size=1) +
                  xlab("Iteration") + ylab("Intercept")
    graph = arrangeGrob(group.trace,group.plot,indiv.trace,indiv.plot,int.trace,int.plot,nrow=3,ncol=2,
                        main=textGrob("Traceplots and Posterior Distributions",gp=gpar(fontsize=15)))
    graph
  },height=500)

  ############################################################################################################
  ############################################################################################################
  ## Varying-intercept and varying-slope
  ############################################################################################################
  ############################################################################################################

  output$selectresponse2 = renderUI({
    selectInput("response2","Response variable:",choices=names(data()),selectize=TRUE)
  })

  output$selectlevel2id2 = renderUI({
    selectInput("level2.id2","Level 2 observational unit:",choices=names(data()),selectize=TRUE)
  })

  output$selectlevel1pred1 = renderUI({
    selectInput("level1.pred1","Level 1 predictor:",choices=names(data()),selectize=TRUE)
  })

  dat.pred1 = reactive({
    if(!input$usesample)
    {
      dat = data.frame(predictor = data()[,paste(input$level1.pred1)],
                       response = data()[,paste(input$response2)],
                       level2.id = factor(data()[,paste(input$level2.id2)]))
    } else if (input$usesample)
    {
      dat = data.frame(predictor = data()$previous,
                       response = data()$negative_affect,
                       level2.id = factor(data()$id))
      return(dat)
    }
  })

  label1 = reactive({
    if(!input$usesample)
    {
      return(c(paste(input$response2),paste(input$level1.pred1),paste(input$level2.id2)))
    }else if(input$usesample)
    {
      return(c("negative affect","previous","musicians"))
    }
  })

  ############################################################################################################
  ## Pooled Regression 2
  ############################################################################################################

  output$pooled.graph = renderPlot({
      ggplot(data=dat.pred1(), aes(x=predictor,y=response)) +
        geom_point(position = "jitter", size=3, shape=1) +
        geom_smooth(method="lm",color="navy",se=FALSE) + xlab(paste(label1()[2])) + ylab(paste(label1()[1])) +
        ggtitle(paste("Scatterplot of",label1()[1],"versus", label1()[2],"with pooled line imposed")) + theme_bw()
  })

  pooled.mod = reactive({
      lm(response~predictor, data=dat.pred1())
  })

  output$pooled.output = renderTable({
    return(summary(pooled.mod()))
  })

  output$pooled.info = renderText({
    paste0("R-squared=",round(summary(pooled.mod())$r.squared,digits=3),"; Residual df=",pooled.mod()$df.residual)
  })

  ############################################################################################################
  ## Unpooled Regression 2
  ############################################################################################################

  output$unpooled.graph = renderPlot({
      ggplot(data=dat.pred1(), aes(x=predictor,y=response)) + geom_point(position = "jitter", size=3, shape=1) +
        geom_smooth(aes(group=level2.id),method="lm",color="gold2",se=FALSE) +
        geom_smooth(aes(group=1),method="lm",color="navy",se=FALSE) + xlab(paste(label1()[2])) + ylab(paste(label1()[1])) +
        ggtitle(paste("Scatterplot of",label1()[1],"versus",label1()[2],"with unpooled lines imposed")) + theme_bw()
  })

  unpooled.mod = reactive({
    lm(response~0+predictor+factor(level2.id)+factor(level2.id)*predictor, data=dat.pred1())
  })

  output$unpooled.output = renderTable({
    return(anova(unpooled.mod()))
  })

  output$unpooled.info = renderText({
    paste0("R-squared=",round(sum(anova(unpooled.mod())$Sum[1:3])/sum(anova(unpooled.mod())$Sum),digits=3))
  })

  slope.intercept = reactive({
    id = unique(dat.pred1()$level2.id)
    slope=NULL
    intercept=NULL
    n=NULL
    i=0
    while(i<length(id))
    {
      i=i+1
      sub.dat = dat.pred1()[which(dat.pred1()$level2.id==id[i]),]
      n[i] = dim(sub.dat[which(complete.cases(sub.dat)),])[1]
      mod = lm(response~predictor,data=sub.dat)
      intercept[i] = mod$coefficients[1]
      slope[i] = mod$coefficients[2]
    }
    intercept = round(intercept,digits=3)
    slope = round(slope,digits=3)

    return(data.frame(intercept=intercept,slope=slope,n=n))
  })

  output$unpooled.est = renderDataTable({
    mat = matrix(c(unique(dat.pred1()$level2.id),slope.intercept()$intercept,
                   slope.intercept()$slope,slope.intercept()$n),ncol=4)
    colnames(mat) = c("ID","Intercept","Slope","n")
    return(mat)
  })

  ############################################################################################################
  ## Hierarchical Linear Model 2
  ############################################################################################################

  hlm = reactive({
    return(lmer(response ~ predictor + (predictor|level2.id), data=dat.pred1(),
                control=lmerControl(optCtrl=list(maxfun=50000))))
  })

  output$hlm.summary = renderPrint({
    summary(hlm())
  })

  output$hlm.confint1 = renderTable({
    conf = confint(hlm(),method="boot")
    colnames(conf) = c("95% Lower Bound","95% Upper Bound")
    rownames(conf) = c("Between-group Intercept SD","Correlation","Between-group Slope SD","Within-group SD",
                       "Intercept","Slope")
    return(conf)
  })

  output$hlm.graph = renderPlot({
    sub.dat = dat.pred1()[which(complete.cases(dat.pred1())),]
    sub.dat$predicted = predict(hlm())

    ggplot(data=sub.dat) + geom_point(aes(x=predictor,y=response), position = "jitter", size=3, shape=1) +
      xlab(paste(label1()[2])) + ylab(paste(label1()[1])) +
      ggtitle(paste("Scatterplot of",label1()[1],"versus\n",label1()[2],"with HLM lines imposed")) +
      geom_smooth(data=sub.dat, aes(x=predictor,y=predicted,group=level2.id),method="lm",color="tomato",se=FALSE) +
      geom_smooth(data=sub.dat, aes(x=predictor,y=response,group=1),method="lm",color="navy",se=FALSE) + theme_bw()
  })

  hlm.slope.intercept = reactive({
    coef = coefficients(hlm())

    id = unique(dat.pred1()$level2.id)
    n=NULL
    i=0
    while(i<length(id))
    {
      i=i+1
      sub.dat = dat.pred1()[which(dat.pred1()$level2.id==id[i]),]
      n[i] = dim(sub.dat[which(complete.cases(sub.dat)),])[1]
    }
    coef[[1]][,1] = round(coef[[1]][,1],digits=3)
    coef[[1]][,2] = round(coef[[1]][,2],digits=3)

    return(data.frame(int.vec=coef[[1]][,1], slope.vec=coef[[1]][,2],n=n))
  })

  output$hlm.est = renderDataTable({
    dat = data.frame(ranef(hlm())$level2.id)
    mat = matrix(c(unique(dat.pred1()$level2.id),hlm.slope.intercept()$int.vec,
                   round(dat$X.Intercept.,digits=3),hlm.slope.intercept()$slope.vec,
                   round(dat$predictor,digits=3),hlm.slope.intercept()$n),ncol=6)
    colnames(mat) = c("ID","Intercept","Group-level Intercept Error","Slope","Group-level Slope Error","n")
    return(mat)
  })

  output$hlmparamdist1 = renderPlot({
    dat = data.frame(coef(hlm())$level2.id)
    plot1 = ggplot(dat) + geom_histogram(aes(x=X.Intercept.), color="seagreen2",fill="white") +
              xlab("HLM intercepts") + ylab("Frequency") + ggtitle("Histogram of HLM intercepts") + theme_bw()
    plot2 = ggplot(dat) + geom_histogram(aes(x=predictor), color="seagreen2",fill="white") +
              xlab("HLM slopes") + ylab("Frequency") + ggtitle("Histogram of HLM slopes") + theme_bw()
    plot3 = arrangeGrob(plot1,plot2,nrow=1)
    return(plot3)
  })

  output$hlmparamdistinfo1 = renderUI({
    p(HTML("

"),withMathJax("\\(\\hat{\\mu}_{\\alpha} =\\)"),code(paste(round(as.numeric(fixef(hlm.mod.nopred())),digits=3))),
      HTML("

"),withMathJax("\\(\\hat{\\sigma}_\\alpha^{2} =\\)"),code(paste(variances()[2])),HTML("
"))
  })

  output$hlmparamdist2 = renderPlot({
    dat = data.frame(ranef(hlm())$level2.id)
    plot1 = ggplot(dat) + geom_histogram(aes(x=X.Intercept.), color="salmon",fill="white") +
              xlab("Group-level intercept errors") + ylab("Frequency") +
              ggtitle("Histogram of group-level\nintercept errors") + theme_bw()
    plot2 = ggplot(dat) + geom_histogram(aes(x=predictor), color="salmon",fill="white") +
              xlab("Group-level slope errors") + ylab("Frequency") +
              ggtitle("Histogram of group-level\nslope errors") + theme_bw()
    plot3 = arrangeGrob(plot1,plot2,nrow=1)
    return(plot3)
  })

  output$ggcat2 = renderPlot({
    ggCaterpillar(ranef(hlm(), condVar=TRUE), QQ=FALSE)
  })

  ############################################################################################################
  ## Comparison of Methods 2
  ############################################################################################################

  output$slopeint.comp = renderPlot({
    dat = dat.pred1()
    mod = lm(response~predictor,data=dat)
    datline = data.frame(x=as.numeric(mod$coef[1]),y=as.numeric(mod$coef[2]))

    intercept = ggplot() + geom_histogram(data=slope.intercept(),aes(x=intercept,y=..density..,fill="Unpooled"),alpha=.5) +
      geom_histogram(data=hlm.slope.intercept(),aes(x=int.vec,y=..density..,fill="HLM"),alpha=.5) +
      geom_density(data=slope.intercept(),aes(x=intercept),color="gold2") +
      geom_vline(data=datline,aes(xintercept=x),color="navy",linetype="dashed") +
      geom_density(data=hlm.slope.intercept(),aes(x=int.vec),color="tomato") +
      ggtitle("Histogram of sample intercepts") + xlab("Sample intercepts") + ylab("Relative frequency") +
      scale_fill_manual(name="Model",values=c("HLM"="tomato","Unpooled"="gold2","Pooled"="navy")) +
      guides(fill=FALSE) + theme_bw()

    slope = ggplot() + geom_histogram(data=slope.intercept(),aes(x=slope,y=..density..,fill="Unpooled"),alpha=.5) +
      geom_histogram(data=hlm.slope.intercept(),aes(x=slope.vec,y=..density..,fill="HLM"),alpha=.5) +
      geom_density(data=slope.intercept(),aes(x=slope),color="gold2") +
      geom_vline(data=datline,aes(xintercept=y),color="navy",linetype="dashed") +
      geom_density(data=hlm.slope.intercept(),aes(x=slope.vec),color="tomato") +
      ggtitle("Histogram of sample slopes") + xlab("Sample slopes") + ylab("Relative frequency") +
      scale_fill_manual(name="Model",values=c("HLM"="tomato","Unpooled"="gold2","Pooled"="navy")) +
      guides(fill=FALSE) + theme_bw()

    graph1 = arrangeGrob(intercept,slope,nrow=1)

    graph2 = ggplot() + geom_vline(data=datline,aes(xintercept=x),color="navy",linetype="dashed") +
      geom_hline(data=datline,aes(yintercept=y),color="navy",linetype="dashed") +
      geom_point(data=hlm.slope.intercept(),aes(x=int.vec,y=slope.vec,color="HLM"),size=3,shape=1) +
      geom_point(data=slope.intercept(),aes(x=intercept,y=slope,color="Unpooled"),size=3,shape=1) +
      geom_smooth(data=hlm.slope.intercept(),aes(x=int.vec,y=slope.vec,color="HLM"),method="lm",se=FALSE) +
      geom_smooth(data=slope.intercept(),aes(x=intercept,y=slope,color="Unpooled"),method="lm",se=FALSE) +
      ggtitle("Scatterplot of sample slopes versus intercepts with pooled estimates imposed") +
      xlab("Intercepts") + ylab("Slopes") + scale_color_manual(name="Modelling method",values=c("HLM"="tomato","Unpooled"="gold2")) +
      theme_bw() + theme(legend.position="bottom")

    graph3 = arrangeGrob(graph2,graph1,ncol=1)

    return(graph3)
  },height=800)

  output$comp.method = renderPlot({
    dat = dat.pred1()
    dat$hlmpred = fitted(hlm())

    mod = lm(response~predictor,data=dat)
    dat$x=as.numeric(mod$coef[1])
    dat$y=as.numeric(mod$coef[2])

    ggplot(data=dat) + geom_point(aes(x=predictor,y=response),shape=1) + facet_wrap(~level2.id) + theme_bw() +
      geom_smooth(aes(x=predictor,y=response, color="Unpooled"), method="lm", se=FALSE) +
      geom_abline(aes(intercept=x,slope=y, color="Pooled"),size=.5) +
      geom_smooth(aes(x=predictor,y=hlmpred,color="HLM"),method="lm",se=FALSE) +
      scale_color_manual(name="Modelling method", values=c("Pooled"="navy","Unpooled"="gold2","HLM"="tomato")) +
      theme(legend.position="bottom", legend.direction="horizontal") + xlab(paste(label1()[2])) + ylab(paste(label1()[1])) +
      ggtitle("Comparison of the three modelling methods")
  },height=800)

  ############################################################################################################
  ## Bayesian Hierarchical Linear Model 2
  ############################################################################################################

  hlmbayes2 = reactive({
    MCMCglmm(response ~ predictor, random=~level2.id+predictor, data=dat.pred1(),
             verbose=FALSE, pr=TRUE)
  })

  output$hlm.bayes2 = renderPrint({
    summary(hlmbayes2())
  })

  output$postdist2 = renderPlot({
    slope.error = data.frame(x=as.vector(hlmbayes2()$VCV[,2]))
    indiv.error = data.frame(x=as.vector(hlmbayes2()$VCV[,3]))
    group.error = data.frame(x=as.vector(hlmbayes2()$VCV[,1]))
    int = data.frame(x=as.vector(hlmbayes2()$Sol[,1]))
    group.slope.plot = ggplot(data=slope.error) + geom_density(aes(x=x)) + theme_bw() + ylab("") + xlab("Between-group var in slopes") +
                         geom_vline(aes(xintercept=mean(x)),color="seagreen2",size=1)
    group.slope.trace = ggplot(data=slope.error) + geom_line(aes(x=1:length(x),y=x)) + theme_bw() +
                          geom_hline(aes(yintercept=mean(x)),color="seagreen2",size=1) +
                          xlab("Iteration") + ylab("Between-group\nvar in slopes")
    group.error.plot = ggplot(data=group.error) + geom_density(aes(x=x)) + theme_bw() + ylab("") + xlab("Between-group var in intercepts") +
                         geom_vline(aes(xintercept=mean(x)),color="seagreen2",size=1)
    group.error.trace = ggplot(data=group.error) + geom_line(aes(x=1:length(x),y=x)) + theme_bw() +
                        geom_hline(aes(yintercept=mean(x)),color="seagreen2",size=1) +
                        xlab("Iteration") + ylab("Between-group\nvar in intercepts")
    indiv.plot = ggplot(data=indiv.error) + geom_density(aes(x=x)) + theme_bw() + ylab("") + xlab("Within-group var in response") +
                   geom_vline(aes(xintercept=mean(x)),color="seagreen2",size=1)
    indiv.trace = ggplot(data=indiv.error) + geom_line(aes(x=1:length(x),y=x)) + theme_bw() +
                    geom_hline(aes(yintercept=mean(x)),color="seagreen2",size=1) +
                    xlab("Iteration") + ylab("Within-group\nvar in response")
    int.plot = ggplot(data=int) + geom_density(aes(x=x)) + theme_bw() + ylab("") + xlab("Intercept") +
                 geom_vline(aes(xintercept=mean(x)),color="seagreen2",size=1)
    int.trace = ggplot(data=int) + geom_line(aes(x=1:length(x),y=x)) + theme_bw() +
                  geom_hline(aes(yintercept=mean(x)),color="seagreen2",size=1) +
                  xlab("Iteration") + ylab("Intercept")
    graph = arrangeGrob(group.error.trace,group.error.plot,group.slope.trace,group.slope.plot,indiv.trace,
                        indiv.plot,int.trace,int.plot,nrow=4,ncol=2,main=textGrob("Traceplots and Posterior Distributions",gp=gpar(fontsize=15)))
    return(graph)
  },height=600)

  ############################################################################################################
  ############################################################################################################
  ## Varying-intercept and varying-slope with level 2 predictor
  ############################################################################################################
  ############################################################################################################

  output$selectresponse3 = renderUI({
    selectInput("response3","Response variable:",choices=names(data()),selectize=TRUE)
  })

  output$selectlevel2id3 = renderUI({
    selectInput("level2.id3","Level 2 observational unit:",choices=names(data()),selectize=TRUE)
  })

  output$selectlevel1pred2 = renderUI({
    selectInput("level1.pred2","Level 1 predictor:",choices=names(data()),selectize=TRUE)
  })

  output$selectlevel2pred1 = renderUI({
    selectInput("level2.pred1","Level 2 predictor:",choices=names(data()),selectize=TRUE)
  })

  dat.pred2 = reactive({
    if(!input$usesample)
    {
      dat = data.frame(predictor = data()[,paste(input$level1.pred2)],
                       response = data()[,paste(input$response3)],
                       level2.id = factor(data()[,paste(input$level2.id3)]),
                       level2.predictor = data()[,paste(input$level2.pred1)])
      return(dat)
    }else if(input$usesample)
    {
      dat = data.frame(predictor = data()$previous,
                       response = data()$negative_affect,
                       level2.id = factor(data()$id),
                       level2.predictor = data()$years_study)
      return(dat)
    }
  })

  label2 = reactive({
    if(!input$usesample)
    {
      return(c(paste(input$response3),paste(input$level1.pred2),paste(input$level2.id3),paste(input$level2.pred1)))
    } else if(input$usesample)
    {
      return(c("negative affect","previous","musicians","years study"))
    }
  })

  ############################################################################################################
  ## Two stage modelling
  ############################################################################################################

  stage2 = reactive({
    dat.pred2()[!duplicated(dat.pred2()$level2.id),]
  })

  output$int.mod = renderTable({
    dat = data.frame(intercept=slope.intercept()$intercept,level2.predictor=stage2()$level2.predictor)

    lm(intercept ~ level2.predictor, data=dat)
  })

  output$slope.mod = renderTable({
    dat = data.frame(slope=slope.intercept()$slope,level2.predictor=stage2()$level2.predictor)

    lm(slope ~ level2.predictor, data=dat)
  })

  output$stage2graph = renderPlot({
    dat = data.frame(int=slope.intercept()$intercept,slope=slope.intercept()$slope,pred=stage2()$level2.predictor)

    g1 = ggplot(data=dat,aes(x=pred,y=int)) + geom_point(shape=1) + geom_smooth(method="lm",se=FALSE,color="gold2") +
      xlab(paste(label2()[4])) + ylab("Unpooled intercepts") + theme_bw() +
      ggtitle(paste("Scatterplot of unpooled\nintercepts versus",label2()[4]))

    g2 = ggplot(data=dat,aes(x=pred,y=slope)) + geom_point(shape=1) + geom_smooth(method="lm",se=FALSE,color="gold2") +
      xlab(paste(label2()[4])) + ylab("Unpooled slopes") + theme_bw() +
      ggtitle(paste("Scatterplot of unpooled\nslopes versus",label2()[4]))

    g3 = arrangeGrob(g1,g2,nrow=1)
    return(g3)
  })

  ############################################################################################################
  ## Hierarchical Linear Model 3
  ############################################################################################################

  hlm2 = reactive({
    return(lmer(response ~ predictor + level2.predictor + predictor:level2.predictor +
                  (1 + predictor|level2.id), data=dat.pred2(),
                control=lmerControl(optCtrl=list(maxfun=50000))))
  })

  output$hlm.summary1 = renderPrint({
    summary(hlm2())
  })

  output$hlm.confint2 = renderTable({
    conf = confint(hlm2(),method="boot")
    colnames(conf) = c("95% Lower Bound","95% Upper Bound")
    rownames(conf) = c("Between-group Intercept SD","Correlation","Between-group Slope SD","Within-group SD",
                       "Intercept","Level 1 Predictor","Level 2 Predictor","Cross-level Interaction")
    return(conf)
  })

  output$hlmhyper1 = renderTable({
    vec = as.vector(fixef(hlm2()))
    tab = matrix(vec,nrow=1)
    colnames(tab) = c("Intercept","Level 1 Predictor","Level 2 Predictor","Cross-level Interaction")
    rownames(tab) = "Estimates"
    return(tab)
  })

  output$hlmhyper2 = renderPrint({
    VarCorr(hlm2())
  })

  output$ggcat3 = renderPlot({
    ggCaterpillar(ranef(hlm2(), condVar=TRUE), QQ=FALSE)
  })

  ############################################################################################################
  ## Comparison of Methods 3
  ############################################################################################################

  output$compgraph = renderPlot({
    dat = data.frame(int=slope.intercept()$intercept,slope=slope.intercept()$slope,pred=stage2()$level2.predictor)
    dat1 = data.frame(int1=fixef(hlm2())[1],slope1=fixef(hlm2())[3],int2=fixef(hlm2())[2],slope2=fixef(hlm2())[4])

    g1 = ggplot() + geom_point(data=dat,aes(x=pred,y=int,color="Unpooled"),shape=1) +
      geom_smooth(data=dat,aes(x=pred,y=int,color="Unpooled"),method="lm",se=FALSE) +
      xlab(paste(label2()[4])) + ylab("Intercepts") + theme_bw() +
      geom_abline(data=dat1,aes(intercept=int1,slope=slope1,color="HLM")) +
      scale_color_manual(name="Modelling method", values=c("Unpooled"="gold2","HLM"="tomato")) +
      theme(legend.position="bottom", legend.direction="horizontal") +
      ggtitle(paste("Scatterplot of intercepts versus",label2()[4],"\ncomparing the unpooled method and HLM"))

    g2 = ggplot() + geom_point(data=dat,aes(x=pred,y=slope,color="Unpooled"),shape=1) +
      geom_smooth(data=dat,aes(x=pred,y=slope,color="Unpooled"),method="lm",se=FALSE) +
      xlab(paste(label2()[4])) + ylab("Slopes") + theme_bw() +
      geom_abline(data=dat1,aes(intercept=int2,slope=slope2,color="HLM")) +
      scale_color_manual(name="Modelling method", values=c("Unpooled"="gold2","HLM"="tomato")) +
      theme(legend.position="bottom", legend.direction="horizontal") +
      ggtitle(paste("Scatterplot of slopes versus",label2()[4],"\ncomparing the unpooled method and HLM"))

    g3 = arrangeGrob(g1,g2,nrow=1)
    return(g3)
  },height=500)

  ############################################################################################################
  ############################################################################################################
  ## Analyze Data Tab
  ############################################################################################################
  ############################################################################################################

  output$selectresponse.analyze = renderUI({
    selectInput("responseanalyze","Response variable:",choices=names(data()),selectize=TRUE)
  })

  output$selectlevel2id.anaylze = renderUI({
    selectInput("level2.idanalyze","Level 2 observational unit:",choices=names(data()),selectize=TRUE)
  })

  output$selectlevel1pred.analyze = renderUI({
    selectizeInput("level1.predanalyze","Level 1 predictor(s):",choices=names(data()),
                multiple=TRUE,options=list(placeholder="level 1 predictor(s)"))
  })

  output$selectlevel1pred.analyze.rand = renderUI({
    selectizeInput("level1.predanalyze.rand","Random predictor(s):",choices=input$level1.predanalyze,
                   multiple=TRUE,options=list(placeholder="random predictor(s)"))
  })

  output$selectlevel2pred.analyze = renderUI({
    selectizeInput("level2.predanalyze","Level 2 predictor(s):",choices=names(data()),
                multiple=TRUE,options=list(placeholder="level 2 predictor(s)"))
  })

  output$selectcrosslevint = renderUI({
    selectizeInput("crosslevelint", "Cross-level interaction(s):",
                   choices=as.vector(outer(input$level1.predanalyze.rand, input$level2.predanalyze, paste, sep=":")),
                   multiple=TRUE,options=list(placeholder="cross-level interaction(s)"))
  })

  dat.analyze = reactive({
    dat.pred1=matrix(nrow=dim(data())[1],ncol=length(input$level1.predanalyze))
    i=0
    formula1 = NULL
    formula1 = input$level1.predanalyze[1]
    while(i<length(input$level1.predanalyze))
    {
      i=i+1
      dat.pred1[,i] = data()[,paste(input$level1.predanalyze[i])]
      if(i>1) formula1 = paste0(formula1,"+",input$level1.predanalyze[i])
    }
    colnames(dat.pred1) = input$level1.predanalyze
    dat.pred1 = data.frame(dat.pred1)

    formula2=NULL
    dat.pred2=matrix(nrow=dim(data())[1],ncol=length(input$responseanalyze))
    if(length(input$level2.predanalyze)>0)
    {
      j=0
      formula2 = paste("+",input$level2.predanalyze[1])
      while(j<length(input$level2.predanalyze))
      {
        j=j+1
        dat.pred2[,j] = data()[,paste(input$level2.predanalyze[j])]
        if(j>1) formula2 = paste0(formula2,"+",input$level2.predanalyze[j])
      }
      colnames(dat.pred2) = input$level2.predanalyze
      dat.pred2 = data.frame(dat.pred2)
    }

    formula3=NULL
    if(length(input$level1.predanalyze.rand)>0)
    {
      k=1
      formula3 = paste0("+",input$level1.predanalyze.rand[1])
      while(k<length(input$level1.predanalyze.rand))
      {
        k=k+1
        formula3 = paste0(formula3,"+",input$level1.predanalyze.rand[k])
      }
    }

    formula4=NULL
    if(length(input$crosslevelint)>0)
    {
      l=1
      formula4 = paste0("+",input$crosslevelint[1])
      while(l<length(input$crosslevelint))
      {
        l=l+1
        formula4 = paste0(formula4,"+",input$crosslevelint[l])
      }
    }

    dat = data.frame(response = data()[,paste(input$responseanalyze)],
                     level2.id = factor(data()[,paste(input$level2.idanalyze)]),
                     dat.pred1,dat.pred2)
    names(dat)[1] = input$responseanalyze
    names(dat)[2] = input$level2.idanalyze

    return(list(dat=dat,formula1=formula1,formula2=formula2,formula3=formula3,formula4=formula4))
  })

  mod.analyze = reactive({
    do.call(paste("lmer"),list(formula=paste0(input$responseanalyze,"~",dat.analyze()[[2]],dat.analyze()[[3]],
                                              dat.analyze()[[5]],"+ (1",dat.analyze()[[4]],"|",input$level2.idanalyze,")"),
                               data=dat.analyze()[[1]],control=lmerControl(optCtrl=list(maxfun=50000))))
  })

  output$summary.analyze = renderPrint({
    input$runmod
    isolate({
      if(input$runmod>0)
      {
        summary = summary(mod.analyze())
        summary$call=NULL
        return(summary)
      }
    })
  })

})


# 3. faza: Vizualizacija podatkov
#Delež ljudi glede na BDP, ki je v zadnjih 3 mesecih opravilo spletni nakup
graf1 <- ggplot(tabela1) + aes(x = BDPpc, y = Value, color = Education) + geom_point() + xlab("BDP na prebivalca") + ylab("Delež ljudi, ki je v zadnjih 3 mesecih opravil spletni nakup") + ggtitle("Delež ljudi glede na BDP na prebivalca, ki je opravil spletni nakup v zadnjih 3 mesecih") + labs(color = "Odstotek prebivalstva s 3. stopnjo izobrazbe")
"Delež ljudi glede na delež ljudi s tretjo st izobrazbe, ki je opravil spletni nakup v zadnjih 3 mesecih"
graf2 <- ggplot(tabela1) + aes(x = Education, y = Value, color = Area ) + geom_point() + xlab("Delež ljudi s tretjo stopnjo izobrazbe") + ylab("Delež ljudi, ki je v zadnjih 3 mesecih opravil spletni nakup") + ggtitle("Delež ljudi glede na delež ljudi s tretjo stopnjo izobrazbe, ki je opravilo spletni nakup v zadnjih 3 mesecih") + scale_color_discrete(name="Predel", labels=c("Živeči v mestih", "Živeči na ruralnih območjih"))

#tabela2 %>%
#  ggplot(
#    mapping = aes(x = tabela2)
#  ) +
#  geom_histogram()
#

graf3 <- tabela1 %>%
  ggplot(
    mapping = aes(group= Country, x = Country, y = Value)
  ) +
  geom_boxplot() +
  xlab("Država") + ylab("Kolikšen delež ljudi je v zadnjih 3 mesecih kupil nekaj preko spleta") + theme(axis.text.x = element_text(angle = 45, vjust = 1, hjust = 1))

n <- tabela1 %>% dplyr::group_by(Country) %>% dplyr::summarise(mean = mean(Value, na.rm = TRUE))
v <- tabela1 %>% dplyr::group_by(Country) %>% dplyr::summarise(BDPmean = mean(BDPpc, na.rm = TRUE))
n$BDP_mean <- v$BDPmean

graf4 <- ggplot(data = tabela1, aes(x = Year, y = Value, color = Country)) +
  geom_line() + xlab("Leto") + ylab("Delež ljudi, ki je v zadnjih 3 mesecih kupil nekaj prek spleta") + ggtitle("Spreminjanje odstotka ljudi po državah, ki so nakupovali prek spleta, čez leta") + labs(color = "Država")

graf5 <- ggplot(data = tabela1, aes(x = Year, y = Value, color = Area)) +
  geom_line() +
  facet_wrap(facets = vars(Country)) + xlab('Leto') + ylab("Delež ljudi, ki je v zadnjih 3 mesecih kupil nekaj prek spleta") + ggtitle("Spreminjanje odstotka ljudi po državah, ki so nakupovali prek spleta, čez leta") + scale_color_discrete(name="Predel", labels=c("Živeči v mestih", "Živeči na ruralnih območjih"))

graf6 <- ggplot(data = tabela2, mapping = aes(x = Year, y = Koliko_vseh_nakupov_je_opravila_ta_skupina, color = Stopnja)) +
  geom_line() +
  facet_wrap(facets =  vars(Country)) + xlab('Leto') + ylab("Kolikšen delež vseh nakupov je opravila določena skupina") + ggtitle("Spreminjanje odstotka ljudi po državah in doseženi izobrazbi, ki so nakupovali prek spleta, čez leta") + scale_color_discrete(name="Dosežena stopnja izobrazbe", labels=c("Posamezniki z visoko formalno izobrazbo", "Posamezniki s srednjo formalno izobrazbo", "Posamezniki brez ali z nizko izobrazbo", "Študenti"))

graf7 <- ggplot(data=n, aes(x=Country, y=mean, fill = BDP_mean)) +
  geom_bar(stat="identity") + coord_flip() + scale_fill_gradient(low="pink", high="magenta")+ xlab('Država') + ylab('Povprečen odstotek ljudi, ki kupuje prek spleta v tej državi') + labs(fill = "Povprečni BDP per capita") + ggtitle("Odstotek ljudi, ki nakupuje prek spleta glede na BDP")

spr <- tabela1
spr["Education"] <- as.integer(unlist(spr["Education"]))
izobrazba <- spr %>% dplyr::group_by(Country) %>% dplyr::summarise(Edmean = mean(Education, na.rm = TRUE))

n$Edmean <- izobrazba$Edmean
graf8 <- ggplot(data=n, aes(x=Country, y=mean, fill = Edmean)) +
  geom_bar(stat="identity") + coord_flip() + scale_fill_gradient(low="yellow", high="red")+ ylab('Povprečen odstotek ljudi, ki nakupuje prek spleta v tej državi') + xlab('Država') + labs(fill = "Povprečen delež ljudi s tretjo stopnjo izobrazbe") + ggtitle("Odstotek ljudi, ki nakupuje prek spleta glede na odstotek ljudi z doseženo tretjo stopnjo izobrazbe")

tabela3_c[,3] <- as.integer(as.character(unlist(tabela3_c[,3])))
tabela3_c[,4] <- as.integer(unlist(tabela3_c[,4]))
tabela3_c[,5] <- as.integer(unlist(tabela3_c[,5]))
tabela3_c[,6] <- as.integer(unlist(tabela3_c[,6]))
tabela3_c[,7] <- as.integer(unlist(tabela3_c[,7]))

ttt <- tabela3_c %>% dplyr::filter(year == 2019, country == 'Slovenia') %>% pivot_longer(c(3, 4, 5, 6, 7), names_to = 'type', values_to =  "value")
graf9 <- ggplot(data = ttt, mapping = aes(x = country, y = value, fill = type)) +
  geom_bar(width = 1, stat = 'identity') + coord_polar("y", start=0) + xlab('') + ylab('') + ggtitle("Kaj kupujejo ljudje v posamezni državi?") + scale_fill_discrete(name = "Vrsta kupljenega izdelka", labels = c("Knjige, revije, učenje,...", "Obleke, šport", "Filmi, glasba", "Gospodinjski pripomočki", "Potovanja, hoteli,..."))

tabela2_c[,4] <- as.integer(unlist(tabela2_c[,4]))
tabela2_c[,5] <- as.integer(unlist(tabela2_c[,5]))
fff1 <- tabela2_c %>% dplyr::filter(year == 2019, country == 'United Kingdom', stopnja == 'Individuals with high formal education') %>% pivot_longer(c(4, 5), names_to = 'type', values_to = 'value')
graf10 <- ggplot(data = fff1, mapping = aes(x = country, y = value, fill = type)) +
  geom_bar(width = 1, stat = 'identity') + coord_polar("y", start=0) + ggtitle("Kaj kupujejo ljudje\nz doseženo visoko izobrazbo\nv Združenem kraljestvu?") + xlab('') + ylab('') + scale_fill_discrete(name = 'Vrsta kupljenega izdelka', labels = c('Knjige, revije, učenje,...', "Obleke, šport")) +
  theme(legend.position = "none", axis.text = element_blank(), axis.ticks = element_blank(), panel.grid = element_blank())

fff2 <- tabela2_c %>% dplyr::filter(year == 2019, country == 'United Kingdom', stopnja == 'Individuals with no or low formal education') %>% pivot_longer(c(4, 5), names_to = 'type', values_to = 'value')
graf11 <- ggplot(data = fff2, mapping = aes(x = country, y = value, fill = type)) +
  geom_bar(width = 1, stat = 'identity') + coord_polar("y", start=0) + ggtitle("Kaj kupujejo ljudje \nbrez izobrazbe ali \nnizko izobrazbo\nv Združenem kraljestvu?") + xlab('') + ylab('') + scale_fill_discrete(name = 'Vrsta kupljenega izdelka', labels = c('Knjige, revije, učenje,...', "Obleke, šport")) +
  theme(axis.text = element_blank(),
      axis.ticks = element_blank(),
      panel.grid  = element_blank())

library(tmap)

world <- ne_countries(scale = "medium", returnclass = "sf")
Europe <- world[which(world$continent == "Europe"),]
ggplot(Europe) +
  geom_sf() +
  coord_sf(xlim = c(-25,50), ylim = c(35,70), expand = FALSE) +
  aes(fill = 'pink')

lvls <-(Europe$sovereignt)
primerjava <- data.frame(Country = lvls) %>% left_join(tabela1, by = "Country")
manjkajoci <- primerjava[is.na(primerjava$BDPpc), ]

df = data.frame(drzava = manjkajoci$Country, Country = c("Albania",
                                                         "Andorra",
                                                         "Bosnia and Herzegovina",
                                                         "Belarus",
                                                         "Czechia",
                                                         "Germany (until 1990 former territory of the FRG)",
                                                         "Kosovo",
                                                         "Liechtenstein",
                                                         "Monaco",
                                                         "Moldova",
                                                         "North Macedonia",
                                                         "Montenegro",
                                                         "Russia",
                                                         "San Marino",
                                                         "Serbia",
                                                         "Ukraine",
                                                         "Vatican"))
tabela1 <- tabela1 %>% left_join(df) %>% dplyr::mutate(Country=ifelse(is.na(drzava), Country, drzava))
tabela1 <- tabela1 %>% dplyr::select(-drzava)
n2 <- tabela1 %>% dplyr::group_by(sovereignt = Country) %>% dplyr::summarise(mean = mean(Value, na.rm = TRUE))
m <- merge(Europe, n2)
z3 <- ggplot(m) +
  geom_sf() +
  coord_sf(xlim = c(-25,50), ylim = c(35,70), expand = FALSE) +
  aes(fill = mean) +
  scale_fill_gradient(low="yellow", high="magenta") + ggtitle('Katera država v povprečju največ spletno nakupuje?') + labs(fill = "Odstotek ljudi,\nki je v zadnjih 3 mesecih\nspletno nakupoval\n(povprečno)")


#!/bin/env Rscript

N = 6
D = 512
a = matrix(rnorm(N*D), nrow = N, ncol = D)
write.table(a, 'test512.txt', append = F, quote = F, sep = ' ', col.names = T, row.names = F)


#' @export
#' @title duplicates.toremove
#' @description This function looks for rows that contain identical values as other rows, irrespective of position
#' @param \code{m}  The matrix to examine
#' @return the indices of values that have duplicates
#' @family poorly documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @examples duplicates.toremove(c(1,2,3,4,5))
#' integer(0)
#' duplicates.toremove(c(1,1,3,4,5))
#' [1] 1 2
#'
#' m
#' [,1] [,2] [,3]
#' [1,]    2    3    3
#' [2,]    2    1    2
#' [3,]    3    3    2
#' [4,]    2    1    1
#' [5,]    2    1    2
#' #duplicates.toremove(m)
#' [1]  1  2  4  5 12 13 15
#' @export
  duplicates.toremove = function(x) {
    e = NULL
    d = which(duplicated(x))
    e = which(x %in% x[d])
    return(e)
  }


#' List all edges descendant from a node
#'
#' @param tree an object of class 'phylo'.
#' @param node number of interest.
#' @return vector of edge numbers.

#' @export

getEdges<-function(tree,node){
      Desc<-getDescendants(tree,node)
      Edges<-c()
      for(i in 1:length(Desc)){Edges<-c(Edges,which(tree$edge[,2]==Desc[i]))}
      Edges<-c(Edges,which(tree$edge[,2]==node))
      return(Edges)}


# Load `raster` and `rhdf5` packages and read NIS data into R
library(raster)
# install.packages("BiocManager")
# BiocManager::install("rhdf5")
library(rhdf5)
library(rgdal)
library(stringr)
library(entropy)
library(TSA)

#setwd(dir = "//marthathegreat/SAL/NEON/NEON_Biodiversity/Data/Derived_Data/Hyperspectral/GRSM/GRSM_2017")
#setwd(dir = "D:/GRSM_2018")
## change the data path
setwd(dir = "D:/2017_GRSM_3/L1/Spectrometer/ReflectanceH5/2017101216")
file_list<-list.files(pattern="*.h5")

## count the number of files in the folder
n_file<-length(file_list)

## number 16 is n_file, used the number here because if the n_file is too large, there will be a memory issue
for(i in 1:2){

f <- file_list[i]
print(f)
h5ls(f,all=T)
### for different NEON sites, replace all "GRSM" with the other sites name, such as "HARV" for Harvard Forests
spInfo <- h5readAttributes(f,"/GRSM/Reflectance/Metadata/Coordinate_System/Map_Info")
reflInfo <- h5readAttributes(f,"/GRSM/Reflectance/Reflectance_Data")
wavelengths<- h5read(f,"/GRSM/Reflectance/Metadata/Spectral_Data/Wavelength")
nRows <- reflInfo$Dimensions[1]
nCols <- reflInfo$Dimensions[2]
nBands <- reflInfo$Dimensions[3]
myCRS <- h5read(f,"/GRSM/Reflectance/Metadata/Coordinate_System/Proj4")
print(myCRS)
b<-list()
filter_bands <- c(c(1:283),c(322:419))
filter_bands <-data.frame(filter_bands)

x<-stack()
#for (j in 1:4)  {
for (j in 1:nrow(filter_bands))  {
  print(j)
  b<-list()
  b[[j]] <- list()
  b[[j]] <- h5read(f,"/GRSM/Reflectance/Reflectance_Data",index=list(j,1:nCols,1:nRows))
  b[[j]] <- b[[j]][1,,]

  ### remember to transpose the image

  b[[j]] <-t(b[[j]])

  h5readAttributes(f,"/GRSM/Reflectance/Reflectance_Data")

  #Check the myNoDataValue to make sure the noDatavalue and here it shows to be -9999
  # myNoDataValue <- as.numeric(reflInfo$`Data_Ignore_Value`)
  # myNoDataValue
 # hist(b[[j]],breaks=40,col="darkmagenta")
  myNoDataValue <- -9999
  b[[j]][b[[j]] == myNoDataValue] <- 0

  mapInfo<-h5read(f,"/GRSM/Reflectance/Metadata/Coordinate_System/Map_Info")
  mapInfo<-unlist(strsplit(mapInfo, ","))

  myCRS <- h5read(f,"/GRSM/Reflectance/Metadata/Coordinate_System/Proj4")
  ##change projection: HARV -> 18N. More info here: https://www.neonscience.org/field-sites/about-field-sites
  b[[j]] <-raster(b[[j]],crs = "+proj=utm +zone=17N +ellps=WGS84 +datum=WGS84" )

  res <-reflInfo$Spatial_Resolution_X_Y
  xMin <- as.numeric(mapInfo[4])
  #grab the top corner coordinate (yMax)
  yMax <- as.numeric(mapInfo[5])
  xMax <- (xMin + (ncol(b[[j]]))*1)
  yMin <- (yMax - (nrow(b[[j]]))*1)

  rasExt <- extent(xMin,xMax,yMin,yMax)
  extent(b[[j]]) <- rasExt

  name <-paste("band_",j,".tif",sep="")
  #image(b[[j]])

  x <-stack(x,b[[j]])
  #writeRaster(b[[j]], filename=name, format="GTiff",overwrite=TRUE)

  h5closeAll()

}

##change the filename if is not BRDF corrected
writeRaster(x,paste('Reflectance_',str_sub(file_list[i],1,nchar(file_list[i])-3),'.tif', sep=' '),format="GTiff",overwrite=T)

r_mean <- calc(x, mean)
writeRaster(r_mean,paste('Mean_',str_sub(file_list[i],1,nchar(file_list[i])-3),'.tif', sep=' '),format="GTiff")
plot(r_mean)
r_coefficient <- calc(x,cv)
plot(r_coefficient)
writeRaster(r_coefficient,paste('CV_',str_sub(file_list[i],1,nchar(file_list[i])-3),'.tif', sep=' '),format="GTiff")
r_median <- calc(x, median)
writeRaster(r_median,paste('Median_',str_sub(file_list[i],1,nchar(file_list[i])-3),'.tif', sep=' '),format="GTiff")
r_sd <- calc(x, sd)
writeRaster(r_sd,paste('SD_',str_sub(file_list[i],1,nchar(file_list[i])-3),'.tif', sep=' '),format="GTiff")
r_max <-calc(x,max)
writeRaster(r_max,paste('Max_',str_sub(file_list[i],1,nchar(file_list[i])-3),'.tif', sep=' '),format="GTiff")

ts_entropy <- function(x) {
  ##		x is assumed to already be a timeseries object:
  Ps <- spec(x, log="no", plot=FALSE)
  Ps_spec <- Ps$spec
  Pk <- Ps_spec / sum(Ps_spec)
  Hsn_x <- -1 * sum(Pk * log(Pk)) / (log(length(Pk)+0.0000000001))
  as.numeric(Hsn_x)
  ##  Hsn_x[is.na(Hsn_x)]<-0
  # x_null <- sample(x)
  #
  # Ps <- spec(x_null, log="no", plot=FALSE)
  # Ps_spec <- Ps$spec
  # Pk <- Ps_spec / sum(Ps_spec)
  #  Hsn_null <- -1 * sum(Pk * log(Pk)) / log(length(Pk))
  ##	The following would be the start to performing the bootstrap for
  ##		confidence interval generation, but for now we'll just return the
  ##		normalized spectral entropy (Hsn) from the series and call it good.
  return(Hsn_x)
}

# tile_cols <- 2
# tile_rows <- 4
#
# nrows_for_subset <- round(f_brick@nrows/tile_rows)
# ncols_for_subset <- round(f_brick@ncols/tile_cols)
#
# subset_extent_1 <- extent(f_brick, 1, nrows_for_subset, 1, ncols_for_subset)
# subset_extent_2 <- extent(f_brick, 1, nrows_for_subset, ncols_for_subset+1, f_brick@ncols)
# subset_extent_3 <- extent(f_brick, nrows_for_subset+1, 2*nrows_for_subset, 1, ncols_for_subset)
# subset_extent_4 <- extent(f_brick, nrows_for_subset+1, 2*nrows_for_subset, ncols_for_subset+1, f_brick@ncols)
# subset_extent_5 <- extent(f_brick, 2*nrows_for_subset+1, 3*nrows_for_subset, 1, ncols_for_subset)
# subset_extent_6 <- extent(f_brick, 2*nrows_for_subset+1, 3*nrows_for_subset, ncols_for_subset+1, f_brick@ncols)
# subset_extent_7 <- extent(f_brick, 3*nrows_for_subset+1, f_brick@nrows, 1, ncols_for_subset)
# subset_extent_8 <- extent(f_brick, 3*nrows_for_subset+1, f_brick@nrows, ncols_for_subset+1, f_brick@ncols)
#
# raster_subset <- crop(f_brick, subset_extent_3)
# raster_subset <-brick(raster_subset)
#plot(raster_subset)
#is.na(f_brick)==0
#plot(f_brick)
#calculate the spectral entropy
r_entropy <- calc(x, entropy)
#calculate the spectral normalized entropy
r_normalised_entropy <- calc(x, ts_entropy)
writeRaster(r_entropy,paste('Entropy_',str_sub(file_list[i],1,nchar(file_list[i])-3),'.tif', sep=' '),format="GTiff")
writeRaster(r_normalised_entropy,paste('N_Entropy_',str_sub(file_list[i],1,nchar(file_list[i])-3),'.tif', sep=' '),format="GTiff")
plot(r_normalised_entropy)
}


# Intersect the WDPA data with our analysis grid

require(maptools)
require(RColorBrewer)
require(rgdal)
require(rgeos)
library(sf) # for st_intersection
require(raster) # for crop

#######################
## Make gridded WDPA data ##
#######################

# read in the analysis grid from a species projection datafile
load('dataDL/morley/acanthephyra pelagica_Atl_rcp26_jas_prediction_AGG.RData') # an Atlantic projection grid. loads pred.agg
Atl<- pred.agg[!duplicated(pred.agg[, c('latitude', 'longitude')]), c('latitude', 'longitude')]
    #plot(Atl$longitude, Atl$latitude)
load('dataDL/morley/actinauge verrilli_Pac_rcp26_jas_prediction_AGG.RData') # a Pacific projection grid. loads pred.agg
Pac<- pred.agg[!duplicated(pred.agg[, c('latitude', 'longitude')]), c('latitude', 'longitude')]
    #plot(Pac$longitude, Pac$latitude, cex=0.1)

clim <- rbind(Atl, Pac)
rm(pred.agg, Atl, Pac)
clim$lon <- clim$longitude
clim$lat <- clim$latitude
clim <- clim[,c('lat', 'lon')]

clim$lon[clim$lon>180] = clim$lon[clim$lon>180] - 360 # convert lon to shp format (-180 to 180)
clim$lon[clim$lon< -180] = clim$lon[clim$lon< -180] + 360 # convert lon to shp format (-180 to 180)
gridsz = unique(round(diff(sort(unique(clim$lat))),3)) # grid size 0.05
gridsz <- gridsz[gridsz>0]

# read in the MPAs
wdpa = readOGR(dsn='dataDL/WDPA/WDPA_Aug2019_marine-shapefile/WDPA_Aug2019_marine-shapefile', layer='WDPA_Aug2019_marine-shapefile-polygons')
# plot(wdpa) # very slow
nrow(wdpa)
wdpa = wdpa[wdpa$MARINE != 0,] # trim out 100% terrestrial (remove 185)
nrow(wdpa)

# some data exploration
#table(wdpa$MARINE)
#sort(unique(wdpa$DESIG))
#sort(unique(wdpa$DESIG_ENG))
#as.matrix(table(wdpa$IUCN_CAT))
#as.matrix(table(wdpa$NO_TAKE))

# Make the grid based on corner points
y = numeric(5*length(clim$lat)) # all the Y coords, in order
# lower right, lower left, upper left, upper right, lower right
for(i in 1:length(clim$lat)){ y[(5*(i-1)+1):(5*(i-1)+5)] <- c(clim$lat[i]-gridsz/2, clim$lat[i]-gridsz/2, clim$lat[i]+gridsz/2, clim$lat[i]+gridsz/2, clim$lat[i]-gridsz/2)}

x = numeric(5*length(clim$lon))
# lower right, lower left, upper left, upper right, lower right: clockwise so that sp sees it as an island, not a hole
for(i in 1:length(clim$lon)){ x[(5*(i-1)+1):(5*(i-1)+5)] = c(clim$lon[i]+gridsz/2, clim$lon[i]-gridsz/2, clim$lon[i]-gridsz/2, clim$lon[i]+gridsz/2, clim$lon[i]+gridsz/2) }

# Create a SpatialPolygonsDataFrame (a list of "Polygons", each of which is a list of "Polygon")
# Would be faster to create sf object directly
pgns = vector('list', length(clim$lat))
for(i in 1:length(pgns)){
    inds2 = (5*(i-1)+1):(5*(i-1)+5)
    pgns[[i]] = Polygons(list(Polygon(cbind(x[inds2],y[inds2]))), i)
}
SP <- SpatialPolygons(pgns, proj4string=CRS(proj4string(wdpa)))
SPdata <- data.frame(gridpolyID = as.numeric(sapply(slot(SP, 'polygons'), slot, 'ID')), lat = clim$lat, lon = clim$lon) # would be better to put this in SP as a SpatialPolygonsDataFrame
    length(SP)
SPsf <- st_as_sf(SP)
SPsf2 <- dplyr::bind_cols(SPsf, SPdata)
#plot(SP[1:10])
#plot(SP[1:1000]) # slow for so many
#plot(SP) # very slow

# Write out SP for use later
saveRDS(SPsf2, file='temp/SPsf2.rds')

# Trim wdpa to our analysis area
wdpacrop <- crop(wdpa, SP) # drop from 14561 to 925 elements. Slow but worth it (10 min?)
rm(wdpa)

# Find which grids intersect which PAs
# note, it would probably be faster to skip this just do the full intersection directly: out <- st_intersection(SPsf2, wdpasf). Would take a few hours, but not overnight
wdpasf <- st_as_sf(wdpacrop)
gI <- st_intersects(SPsf2, wdpasf) # results stored as sparse binary matrix. list elements show TRUE columns for a given row: gI[[1]] is row one
    dim(gI) # matches dim SP x wdpa
    sum(sapply(gI, length)) # number of pairwise intersections 73659
ng = sum(sapply(gI, length)>0); ng # number of SP polygons that intersect at least one wdpa element
cols = which(sapply(gI, length)>0) # ids of SP polygons that intersect wdpa

# do the intersection
# takes ovenight
warnings <- character(0) # to hold warnings from the loop
messages <- character(0) # to hold messages from the loop
withCallingHandlers({ # store messages and warnings for viewing later, rather than scrolling to screen
    for(i in 1:ng){ # Steps through each grid cell
        if(i %% 1000 == 0) print(paste(i, 'of', ng))
        if(i==1){ # initialize the out object
            out <- st_intersection(SPsf2[cols[i],], wdpasf[gI[[cols[i]]],]) # only calc intersections for those polygons that actually intersect (according to st_intersects)
        } else { # add to the out object
            temp <- st_intersection(SPsf2[cols[i],], wdpasf[gI[[cols[i]]],]) # only calc intersections for those polygons that actually intersect (according to st_intersects)
            out <- rbind(out, temp)
        }
    }
}, warning=function(w){
    warnings <<- c(warnings, w$message) # catch warnings and save them
    invokeRestart("muffleWarning") # don't report the warning now
}, error=function(e){
    stop(e) # stop if there's an error
}, message=function(m){
    messages<<-c(messages,m$message)
    invokeRestart("muffleMessage")
})

dim(out)

# save the result
saveRDS(out, file=paste('temp/wdpa_by_grid', gridsz, '_intersect.rds', sep='')) # save


#' @export
paraboot = function(obj, n.bw, n.draws) {
    if (!is(obj, "lagr.tune")) { stop("Error: obj must be an object of class lagr!") }

    n.loc = length(obj[['fits']])
    response = vector()

    #draw from the EDF interpolated from the bw trace:
    obj$trace = obj$trace[order(obj$trace$bw),]
    ll = -0.5 * obj$trace$loss
    ll = ll - min(ll)
    lik = exp(ll) - exp(min(ll))
    cumLik = cumsum(lik)
    cs = cumsum(c(0,diff(cumLik) * diff(obj$trace$bw) ))

    cumLik = (cs - min(cs)) / diff(range(cs))
    slope = diff(obj$trace$bw) / diff(cumLik)

    len = length(lik)
    obj$trace$bw[1:(len-1)] - slope*lik[1:(len-1)]

#> a[-10,1]-b*a[-10,2] -> int
#> int[5]+b[5]*0.5
#[1] 0.5364039
#> which(diff(0.5<a[,2]))
#Error in which(diff(0.5 < a[, 2])) : argument to 'which' is not logical
#> which(diff(0.5<a[,2])==1)
#[1] 5
#> int[5]+b[5]*0.5

    q = runif(n.bw)
    bws = quantile(obj$trace$b, q, type=4)

    for (i in 1:n.bw) {
        quantile(bw, q, type=4)
    }

    for (i in 1:n.loc) {
        response = c(response, (m[[i]]$coef + (sqrtm(Sigma) %*% y.hat.seed))[1])
    }
}


# Packages ----------------------------------------------------------------
library(here)
library(dplyr)
library(brms)
library(parallel)

# Options -----------------------------------------------------------------
options(mc.cores = detectCores())

# Get data ----------------------------------------------------------------
utla_rt_with_covariates <-
  readRDS(here("data", "utla_rt_with_covariates.rds")) %>%
  filter(week_infection > "2020-10-01") %>%
  mutate(tier = if_else(tier == tier[1], paste0("_", tier), tier)) %>%
  mutate(prop = 1 - prop) %>%
  mutate(tier = if_else(tier == "none", "_none", tier)) %>%
  mutate(positive_samples = as.integer(prop * samples),
         id = 1:n(), positive_prop = NA_real_)

# model with uncertainty ------------------------------------------------

source(here("R", "variant_rt.r"))

# no uncertainty on sgtf
fit_cert <- variant_rt(
  log_rt = ~ 1,
  data = utla_rt_with_covariates %>%
    rename(rt_mean = rt_mean_long_gt, rt_sd = rt_sd_long_gt)%>%
    mutate(positive_prop = prop) %>%
    mutate(
      positive_prop = ifelse(positive_prop <= 0, 1e-5, ifelse(prop >= 1, 0.9999, prop))
    ),
  brm_fn = brm
)

summary(fit_cert)

# uncertainty on sgtf
fit_ <- variant_rt(
  log_rt = ~ 1,
  data = utla_rt_with_covariates %>%
    rename(rt_mean = rt_mean_long_gt, rt_sd = rt_sd_long_gt),
  brm_fn = brm
)

summary(fit)


rm(list=ls())
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)
library("viridis")
# set dataset

#dataset <- "SinghalOG"
dataset <- "Streicher"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

# Colors
# https://www.w3schools.com/colors/colors_picker.asp
color_S <- "orange"
color_TP <- "springgreen4"
color_AI <- "#2BB07FFF"
color_SA <- "#38598CFF"
color_SI <- "yellow4" # 8b8b00

# Add column to name type of support
mLGL <- mutate(mLGL, supportType = case_when(TvS != 'a' ~ "dGLS")) %>%
  mutate_if(is.numeric,round,2)
mLBF <- mutate(mLBF, supportType = case_when(TvS != 'a' ~ "BF")) %>%
  mutate_if(is.numeric,round,2)

# Get total number of loci
loci <- length(mLGL$Locus)

# Change from 2ln(BF) to ln(BF) by dividing all comparisons by 2 7-10 - not including average calcs
names(mLBF[7:10])
mLBF[7:10] <- mLBF[7:10]/2
# for singhal OG
#names(mLBF[4])
#mLBF[4] <- mLBF[4]/2

# Want to stack datasets so GL and BF columns have both comparisons for each hypothesis.

reformatdf <- function(df,h,h1,s1,keepCols){
  # keepCols is a vector of the locus and support type column indices
  # Grab column number
  c1 <- match(h1,names(df))
  # Grab and rename column, add hypothesis column
  a.df <- df[,append(keepCols,c1)]
  names(a.df)[names(a.df) == h1] <- h
  a.df$Hypothesis <- rep(h1,length(a.df[,1]))
  c <- match(h,names(a.df))
  # Adjust direction of support if needed. ie if column is AIvSA, but you want to know SAvAI
  a.df[,c] <- a.df[,c]*(s1)
  return(a.df)
}

# reformat
AI.g <- bind_rows(reformatdf(mLGL,"AI","AIvSA",1,c(1,13)),
                  reformatdf(mLGL,"AI","AIvSI",1,c(1,13)))

SA.g <- bind_rows(reformatdf(mLGL,"SA","AIvSA",-1,c(1,13)),
                  reformatdf(mLGL,"SA","SAvSI",1,c(1,13)))

SI.g <- bind_rows(reformatdf(mLGL,"SI","AIvSI",-1,c(1,13)),
                  reformatdf(mLGL,"SI","SAvSI",-1,c(1,13)))

AI.b <- bind_rows(reformatdf(mLBF,"AI","AIvSA",1,c(1,13)),
                  reformatdf(mLBF,"AI","AIvSI",1,c(1,13)))

SA.b <- bind_rows(reformatdf(mLBF,"SA","AIvSA",-1,c(1,13)),
                  reformatdf(mLBF,"SA","SAvSI",1,c(1,13)))

SI.b <- bind_rows(reformatdf(mLBF,"SI","AIvSI",-1,c(1,13)),
                  reformatdf(mLBF,"SI","SAvSI",-1,c(1,13)))

TS.g <- reformatdf(mLGL,"TS","TvS",1,c(1,13)) %>% select(-SIvAvg)
TS.b <- reformatdf(mLBF,"TS","TvS",1,c(1,13)) %>% select(-SIvAvg)

# Singhal OG
#TS.g <- reformatdf(mLGL,"TS","TvS",1,c(1,3))
#TS.b <- reformatdf(mLBF,"TS","TvS",1,c(1,3))

# MERGE

AI.a <- left_join(AI.g, AI.b, by=c("Locus","Hypothesis"), suffix = c(".g", ".b"))
SA.a <- left_join(SA.g, SA.b, by=c("Locus","Hypothesis"), suffix = c(".g", ".b"))
SI.a <- left_join(SI.g, SI.b, by=c("Locus","Hypothesis"), suffix = c(".g", ".b"))
TS.a <- left_join(TS.g, TS.b, by=c("Locus","Hypothesis"), suffix = c(".g", ".b"))

rm(AI.g,AI.b,SA.b,SA.g,SI.b,SI.g,TS.b,TS.g)

library(xlsx)

fname <- paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_TvSLoci.xlsx",sep='')

#write.xlsx2(as.data.frame(TS.a), file=fname, sheetName="loci", row.names=FALSE)

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

# Scatter ---------------------------------------------- Scatter BF vs dGLS --------------------------------------------------------------------------------------------------------

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

## Scatter graph, colored by hypothesis

S <- function(df,xcol,ycol,x.tic,y.tic,cc){
  scat <- ggplot(df, aes(x=df[[xcol]],y=df[[ycol]])) +
    geom_point(alpha=1, aes(color=df$Hypothesis), size=0.5) + theme_bw() + theme(panel.border = element_blank()) +
    theme_classic() +
    theme(
      axis.text = element_text(size=12, color="black"),
      text = element_text(size=14),
      panel.border = element_blank(),
      panel.background = element_rect(fill = "transparent"), # bg of the panel
      plot.background = element_rect(fill = "transparent", color = NA), # bg of the plot
      panel.grid = element_blank(), # get rid of major grid
      plot.title = element_text(hjust = 0.5)
    ) +
    coord_cartesian(ylim=y.tic,xlim = x.tic) +
    scale_y_continuous(breaks = y.tic) +
    scale_x_continuous(breaks = x.tic) +
    labs(x='dGLS',y='ln(BF)',color="Hypothesis") +
    scale_color_manual(values=cc) +
    guides(colour = guide_legend(override.aes = list(size=2)))

  return(scat)
}

df <- TS.a

# Get max min for graph x = dgls y=bf
max(abs(df[[2]]))
x.lims <- 60 # 50, 45
x.ts <- seq(-x.lims,x.lims,20)
max(abs(df[[4]]))
y.lims <- 60 #1000, 120
y.ts <- seq(-y.lims,y.lims,20)

cc <- c("springgreen4")
TS.s <- S(TS.a,2,4,x.ts,y.ts,cc) + geom_hline(yintercept=c(-5,5),color=c("black"), linetype="dashed", size=0.5) +
  geom_vline(xintercept=c(-0.5,0.5),color=c("black"), linetype="dashed", size=0.5)
quartz()
x <- TS.s + geom_point(size=1.5, color=color_TP) + theme(legend.position = "none")
x
ggsave(paste(dataset,"_scatterTS.pdf",sep=""), plot=x,width = 4, height = 3, units = "in", device = 'pdf',bg = "transparent")

df <- AI.a

# Get max min for graph x = dgls y=bf
max(abs(df[[3]]))
x.lim <- 180 # 50, 45
x.t <- seq(-x.lim,x.lim,50)
max(abs(df[[6]]))
y.lim <- 90 #1000, 120
y.t <- seq(-y.lim,y.lim,20)

# Set colors
cc <- c('#1e7b59','#46d29f') # 3 up and 3 down from original

AI.s <- S(AI.a,3,6,x.t,y.t,cc) + geom_hline(yintercept=c(-5,5),color=c("black"), linetype="dashed", size=0.5) +
  geom_vline(xintercept=c(-0.5,0.5),color=c("black"), linetype="dashed", size=0.5)

AI.s

# Set colors
cc <- c('#243a5b','#4975b6')

SA.s <- S(SA.a,3,6,x.t,y.t,cc) + geom_hline(yintercept=c(-5,5),color=c("black"), linetype="dashed", size=0.5) +
  geom_vline(xintercept=c(-0.5,0.5),color=c("black"), linetype="dashed", size=0.5)

SA.s

# Set colors
cc <- c('#4d4d00','#cccc00')

SI.s <- S(SI.a,3,6,x.t,y.t,cc) + geom_hline(yintercept=c(-5,5),color=c("black"), linetype="dashed", size=0.5) +
  geom_vline(xintercept=c(-0.5,0.5),color=c("black"), linetype="dashed", size=0.5)

SI.s

SP <- ggarrange(TS.s,AI.s, SA.s, SI.s, ncol=2, nrow=2, align="h")
quartz()
SP

#ggsave(paste(dataset,"_scatter.pdf",sep=""), plot=SP,width = 8, height = 6, units = "in", device = 'pdf',bg = "transparent")

# Color disagreements ------------------------------------------ Color disagreements ---------------------------------------------------------------------------------------------

# Graph Function------------------------------------------------------------------------------------------------------------------------------------------------------

SL <- function(df,x.val,y.val,x.tic,y.tic,cc,x.y){
  scat <- ggplot(df, aes(x=x.val,y=y.val)) +
    geom_point(alpha=0.75, aes(color=as.factor(df[[5]])), size=0.75) + theme_bw() + theme(panel.border = element_blank()) +
    theme_classic() +
    theme(
      axis.text = element_text(size=8, color="black"),
      text = element_text(size=10),
      panel.border = element_blank(),
      panel.background = element_rect(fill = "transparent"), # bg of the panel
      plot.background = element_rect(fill = "transparent", color = NA), # bg of the plot
      panel.grid = element_blank(), # get rid of major grid
      plot.title = element_text(hjust = 0.5),
      legend.background = element_rect(colour = "transparent",fill = "transparent")) +
    coord_cartesian(ylim=y.tic,xlim = x.tic) +
    scale_y_continuous(breaks = y.tic) +
    scale_x_continuous(breaks = x.tic) +
    labs(x="dGLS",y="ln(BF)", color="Metric Disagreement") +
    scale_color_manual(values=cc)
  return(scat)
}

df <- TS.a %>%
  mutate(diff = case_when(between(TS.g,-0.5,0.5) & TS.b > 5 ~ "BF strong dGLS neutral",
                          between(TS.g,-0.5,0.5) & TS.b < -5 ~ "BF strong dGLS neutral",
                          between(TS.b,-5,5) & TS.g > 0.5 ~ "dGLS strong BF neutral",
                          between(TS.b,-5,5) & TS.g < -0.5 ~ "dGLS strong BF neutral",
                          TS.b < -5 & TS.g > 0.5 ~ "opposite strong support",
                          TS.b > 5 & TS.g < -0.5 ~ "opposite strong support",
                          TS.b > 5 & TS.g > 0.5 ~ "agree",
                          TS.b < -5 & TS.g < -0.5 ~ "agree",
                          between(TS.b,-5,5) & between(TS.g,-0.5,0.5) ~ "agree"))

max(c(abs(df$TS.g),abs(df$TS.b)))
lower <- 20 # 45
upper <- 20
x.t <- seq(-lower,upper,5) # 15
y.t <- seq(-lower,upper,5)

x.v1 <- df$TS.g
y.v1 <- df$TS.b
cc1 <- c('grey80','orange3','slateblue','black')
#quartz()
SP <- SL(df,x.v1,y.v1,x.t,y.t,cc1,x.y1) +
  geom_vline(xintercept=c(0.5,-0.5),color=c("black"), linetype="dashed", size=0.25) +
  geom_hline(yintercept=c(-5,5),color=c("black"), linetype="dashed", size=0.25)

SP

#ggsave(paste(dataset,"_scatter_disagreeTS.pdf",sep=""), plot=SP,width = 6, height = 4, units = "in", device = 'pdf',bg = "transparent")
ggsave(paste(dataset,"_scatter_disagreeTSzoom.pdf",sep=""), plot=SP,width = 5, height = 3, units = "in", device = 'pdf',bg = "transparent")


#!/usr/bin/env Rscript
args <- commandArgs(trailingOnly = TRUE)

library(ggplot2)

csv_data <- read.csv(args[1])
print(args[1])

ggplot(csv_data, aes(x,y)) + geom_point()
png("r_orig.png")
dev.off()

ggplot(csv_data, aes(x,y)) + geom_point() + geom_smooth(method = "lm", se = F)
png("r_lm.png")
dev.off()

linmod <- lm(y ~ x, data = csv_data)
summary(linmod)

plot(y ~ x, data = csv_data)
abline(linmod)


#!/usr/bin/Rscript

##
# Calcute the "normal" gsi for group "A" twice for every simulation, onece with
# tips for all four groups, and a second time with groups "C" and "D" dropped.
#
# Note: the 'main' function relies on filenames to identify the tree files to
# read and the paramater values for each simulation (so, if you change
# 'make_samples.py' you'll need to change the main function too )
##

library(stringr)
library(genealogicalSorting)
library(plyr)

gsi_a <- function(tr, imap, nperm=1000){
    grp <- as.factor("A")
    assigns <- imap[tr$tip.label,2]
    gsi_val <- gsi(tr, grp, assigns)
    p_val <- permutationTest(tr, grp, assigns, nperm)
    return(c(gsi=gsi_val, P=p_val))
}

per_tree <- function(tr, imap, nperm=1000){
    dropped_tr <- drop.tip(tr, as.character(21:40))
    res_2 <- gsi_a(dropped_tr, imap=imap)
    res_4 <- gsi_a(tr, imap=imap)
    final <-  cbind(c(2,4),rbind(res_2, res_4))
    colnames(final) <- c("comp", "gsi", "P")
    return(final)
}

is_gsi <- function(fname) {
    str_split(fname, "_")[[1]][1] == "gsi"
}

main <- function(){

    tfiles <- paste("trees/", Filter(is_gsi, list.files("trees/")), sep="")
    div_time <- as.numeric(sapply(tfiles, str_extract,  "\\d\\.\\d+"))

    message(paste("loading data from", length(tfiles), "tree files..."))
    all_trees <- do.call("c", lapply(tfiles, read.tree))
    sp_map <- read.table("sample.imap")
    n <- length(all_trees)

    message("calcuating gsi...")
    res <- llply(all_trees, per_tree, sp_map, .progress="text")
    res <- do.call('rbind', res)

    message("writing data...")
    df0 <- data.frame(res, t_div = rep(div_time, each=2*n/21))
    write.csv(df0, "data/gsi_2v4.csv", row.names=FALSE)
}

if(!interactive()){
    main()
}


library(Seurat)
library(pROC)

dn.fig = "figures/adt_vs_response"
dir.create(dn.fig, showWarnings = F, recursive = T)

fn = "data/H1_day0_scranNorm_adtbatchNorm_dist_clustered_TSNE_labels.rds"
h1 = readRDS(fn)

df.subj = h1@meta.data %>% dplyr::mutate(response = str_remove(adjmfc.time, "d0 ")) %>%
  dplyr::select(subject=sampleid, response) %>%
  dplyr::mutate(subject = factor(subject)) %>%
  distinct() %>%
  dplyr::arrange(subject)

clustering = 1
h1 = SetAllIdent(h1, id = glue::glue("K{clustering}"))

cl = "C9"
tobj = SubsetData(h1, ident.use = cl)
dat = tobj@assay$CITE@data
meta = tobj@meta.data %>%
  dplyr::rename(subject = sampleid) %>%
  dplyr::mutate(subject = factor(subject, levels=df.subj$subject))

gi = rownames(dat) %in% c("CD86_PROT", "HLA-DR_PROT")
sum(gi)
dat2 = aggregate(t(as.matrix(dat[gi,,drop=F])), list(subject = meta$subject), mean, drop=F)
dat2[is.na(dat2)] = 0
mat = dat2 %>%
  tibble::column_to_rownames("subject") %>%
  data.matrix()

df = dat2 %>%left_join(df.subj, by="subject")

test.col.levels = c("low","high")
df.test = data.frame()
for(prot in colnames(mat)) {
  X = mat[,prot]
  Y = df$response %>% factor(levels=test.col.levels)
  r = roc(Y,X, direction="<", quiet = T)
  w.pv = wilcox.test(X[Y==test.col.levels[2]], X[Y==test.col.levels[1]], alternative = "greater", exact=F)$p.value
  mean.diff = mean(X[Y==test.col.levels[2]], na.rm=T) - mean(X[Y==test.col.levels[1]], na.rm=T)
  t.stat = ifelse(length(unique(X)) == 1, 0,
                  t.test(X[Y==test.col.levels[2]], X[Y==test.col.levels[1]], alternative = "two")$statistic)

  df.test = rbind(df.test,
                  data.frame(protein = prot, auc=r$auc, w.pv, mean.diff, t.stat, N = length(tobj@cell.names)) %>%
                    dplyr::mutate(cluster = cl, clustering)
  )

}

fwrite(df.test, "results/CITEseq_CD80_CD86_HLA-DR_vs_Response.txt", sep="\t")

df.fig = df %>%
  gather("protein","value",-c(subject, response)) %>%
  dplyr::mutate(protein = sub("_PROT", "", protein)) %>%
  dplyr::mutate(response = factor(response, levels = test.col.levels))
df.txt = df.test %>%
  dplyr::mutate(label = glue::glue("p = {format(w.pv, digits=2)}")) %>%
  dplyr::mutate(protein = sub("_PROT", "", protein))
ggplot(df.fig, aes(response, value, fill=response)) +
  geom_boxplot(fill = NA) +
  geom_dotplot(binaxis = "y", stackdir = "center") +
  scale_fill_manual(values = c("white","black")) +
  geom_text(data=df.txt, aes(label=label), x = 1.5, y=Inf, hjust = 0.5, vjust = 1.5,
            col="black", inherit.aes = F) +
  xlab("Response") +
  ylab("Background-corrected relative expression") +
  facet_wrap(~protein, scales = "free_y") +
  theme_bw() +
  theme(strip.background = element_blank())
ggsave(file.path(dn.fig, "CITEseq_CD86_HLA-DR_vs_Response.png"), w=5, h=4)
ggsave(file.path(dn.fig, "CITEseq_CD86_HLA-DR_vs_Response.pdf"), w=5, h=4, useDingbats = F)


#---------------------------------------------------------------------
# Calculates the first-differenced waveform for preemphasis.
#---------------------------------------------------------------------
preemp <- function(s, coef=1.0) {
  n <- length(s)
  return(c(0,s[2:n]-coef*s[1:(n-1)]))
}