# Run init.r before other scripts
rm(list=ls())
 # for use in R console.
 # set own relevant directory if working in R console, otherwise ignore if in terminal
setwd("/Users/davidbeauchesne/Dropbox/PhD/PhD_obj2/Structure_Comm_EGSL/EGSL_species_distribution/")
# -----------------------------------------------------------------------------
# PROJECT:
#    Evaluating the structure of the communities of the estuary
#       and gulf of St.Lawrence
# -----------------------------------------------------------------------------

# -----------------------------------------------------------------------------
# DETAILS:
#   The goal of this script is to run JSDMs from the HMSC package on data from
#       the annual northern Gulf DFO trawl survey
# -----------------------------------------------------------------------------
library(reshape2)
library(tidyr)
library(dplyr)
library(magrittr)
# Dependencies
    library(Rcpp)
    library(RcppArmadillo)
    library(coda)

# Installing the package
    # library(devtools)
    # install_github("guiblanchet/HMSC")
    library(HMSC)

# Other libraries
    # install.packages('beanplot', dependencies = T)
    # install.packages('corrplot', dependencies = T)
    # install.packages('circlize', dependencies = T)
    library(beanplot)
    library(corrplot)
    library(circlize)

# Functions
    source('./Script/crossValid.r')

# Importing data required data from RawData
    northPluri <- readRDS('./RData/northPluriCor.rds')
    fig <- "../../../Wiki/docs/img/"

# Basic parameters needed for the analysis
    # Name of environmental covariables
        # , # add at some point
        envCov <- c('Prof','SSAL_MEAN','SalMoyMoy','TempMoyMoy','STEMMEAN','BTEMMEAN','O2_Sat_Mea','LaDeTow','LoDeTow')

    # Groups of environmental covariables, for variance partitioning
        # length(envGroup) == length(envCov) + 1; because of Intercept
        envGroup <- c('Intercept','Bathymetry','Salinity','Salinity','Temperature','Temperature','Temperature','Oxygen', 'Spatial', 'Spatial')

# -------------------------------------------------------------
# Remove NAs from environmental variables selected for analysis
# -------------------------------------------------------------

    NAs <- northPluri[, envCov] %>%
            lapply(X = ., FUN = function(x) which(is.na(x))) %>%
            unlist(.) %>%
            unique(.)

    northPluri <- northPluri[-NAs, ]

# ========================================
# 1. Formatting the data for HMSC analysis
# ========================================

    # Species list
        sp <- northPluri[, c('EspGen','N_EspSci')] %>%
                .[!duplicated(.), ] %>%
                .[order(.[, 'EspGen']), ]

    # ---------------------------------
    # Y: sample units by species matrix
    # ---------------------------------

        # The data has to be formatted so that lines are trawl sessions and columns are species
        # Creating wide version of dataset to have stations as rows and species captured as columns
        # Only for presence absence
        # Other fields could also be used for count or weight
        northPluri_wide <- dcast(northPluri,
                                 formula = No_Rel + No_Stn + DatDeTow + DatFiTow + HreDeb + HreFin + LaDeTow + LoDeTow + LaFiTow + LoFiTow + Prof + SSAL_MEAN + STEMMEAN + BTEMMEAN + HAB_C_E + O2_Sat_Mea + SalMoyMoy + TempMoyMoy + Megahabita + MHVar_3x3 ~ EspGen,
                                 value.var = 'EspGen',
                                 fun.aggregate = length)

        # Extracting only presence/absence data
        # This corresponds to the Y matrix for the HMSC package
        # A unique ID for each station is created by combining survey number (i.e. year) and station number
            Station <- paste(northPluri_wide[, 'No_Rel'], '_', northPluri_wide[, 'No_Stn'], sep = '')
            Y <- northPluri_wide[, as.character(sp[,'EspGen'])]
            rownames(Y) <- Station

    # -----------------------------------------
    # Pi: sample units by random effects matrix
    # -----------------------------------------

        # Create a dataframe for random effects, columns have to be factors
        # Using survey nomber, which correspond to years, as a random effect in the analysis
        # Ultimately, there is likely a correlation between stations done during a single year in a single strata
        # It would be a good thing to analyze spatial dependence between stations
            Pi <- data.frame(sampling_unit = as.factor(Station),
                             survey_number = as.factor(northPluri_wide[, 'No_Rel']))

    # ----------------------------------------------------
    # X: sampling units by environmental covariates matrix
    # ----------------------------------------------------

        # Create a matrix for the values of environmental covariates at each sampling unit location
        # The values have to be numeric
        # Bathymetry used, extracted from northPluri rather than epipelagic and benthic habitat data

            X <- matrix(ncol = length(envCov),
                        nrow = nrow(northPluri_wide))
            X <- northPluri_wide[, envCov]
            rownames(X) <- Station

    # ----------------------------
    # as.HMSCdata for HMSC package
    # ----------------------------
        # Creating HMSC dataset for analyses
            northPluri_HMSC <- as.HMSCdata(Y = Y, X = X, Random = Pi, interceptX = T, scaleX = T)
            saveRDS(northPluri_HMSC, file = './RData/northPluri_HMSC.rds')

# ===============================
# 2. Performing the MCMC sampling
# ===============================

    # # Sampling of posterior distribution
    # # Simpler version when uninformative priors are sufficient and a priori parameters do not need to be set
    #     model <- hmsc(northPluri_HMSC,
    #                   family = "probit",
    #                   niter = 10000,
    #                   nburn = 1000,
    #                   thin = 10)

        model <- hmsc(northPluri_HMSC,
                      family = "probit",
                      niter = 10000,
                      nburn = 1000,
                      thin = 100)

    # save model
        saveRDS(model, file = './RData/modelHSMC.rds')

# =========================================
# 3. Producing MCMC trace and density plots
# =========================================

    # Mixing objects
        mixingParamX <- as.mcmc(model, parameters = "paramX")
        mixingMeansParamX <- as.mcmc(model, parameters = "meansParamX")
        mixingMeansVarX <- as.mcmc(model, parameters = "varX")
        mixingParamLatent <- as.mcmc(model, parameters = "paramLatent")

    # Save meanParamX for trace and density plots
    saveRDS(mixingMeansParamX, file = './RData/mixingMeansParamX.rds')

    # Trace and density plots to visually diagnose mcmc chains
    # Another way to check for convergence is to use diagnostic tests such as Geweke's convergence diagnostic (geweke.diag function in coda) and the Gelman and Rubin's convergence diagnostic (gelman.diag function in coda).
        paramModel <- colnames(mixingMeansParamX)
        nParam <- length(paramModel)

        jpeg(paste(fig,'MCMCTracePlot.jpeg',sep=''), width = 6, height = (1.5*nParam), res = 150, units = 'in')
        par(mfrow = c(nParam, 2), mar = rep(2, 4))
        for(i in 1:ncol(mixingMeansParamX)) {
          traceplot(mixingMeansParamX[,i], col = "blue", main = paste('Trace of ', paramModel[i]))
          densplot(mixingMeansParamX[,i], col = "orange", main = paste('Density of ', paramModel[i]))
        }
        dev.off()

# ================================
# 4. Producing posterior summaries
# ================================
    # # Violin plot
    #     par(mar=c(6,4,1,1))
    #     mixingParamXDF <- as.data.frame(mixingParamX)
    #     beanplot(mixingParamXDF, las = 2)
    #     points(1:30, as.vector(param$param$paramX), pch=19, col="blue", cex=2)
    #
    # # Box plot
    #     par(mar=c(6,4,1,1))
    #     boxplot(mixingParamXDF, las = 2)
    #     points(1:30, as.vector(param$param$paramX), pch=19, col="blue", cex=2)
    #
    # Average
        average <- apply(model$results$estimation$paramX, 1:2, mean)
    # 95% confidence intervals
        CI.025 <- apply(model$results$estimation$paramX, 1:2, quantile, probs = 0.025)
        CI.975 <- apply(model$results$estimation$paramX, 1:2, quantile, probs = 0.975)

    # Summary table
        paramXCITable <- cbind(unlist(as.data.frame(average)),
                             unlist(as.data.frame(CI.025)),
                             unlist(as.data.frame(CI.975)))
        colnames(paramXCITable) <- c("average", "lowerCI", "upperCI")
        rownames(paramXCITable) <- paste(rep(colnames(average), each = nrow(average)), "_", rep(rownames(average), ncol(average)), sep="")

      # Save summary table
        saveRDS(paramXCITable, file = './RData/modelPostSumm.rds')

    # Credible intervals
        paramXCITable_Full <- paramXCITable

        beg <- seq(1,nrow(paramXCITable_Full), by = 124)
        end <- seq(124,nrow(paramXCITable_Full), by = 124)
        sign <- abs(as.numeric(paramXCITable_Full[, 'lowerCI'] <= 0 & paramXCITable_Full[, 'upperCI'] >=0) - 3)
        sp <- northPluri[, c('EspGen','N_EspSci')] %>%
                .[!duplicated(.), ] %>%
                .[order(.[, 'EspGen']), ]

    # Export figure
        jpeg(paste(fig,'credibleInterval.jpeg',sep=''), width = 6, height = (1.5*nParam), res = 150, units = 'in')
        par(mfrow = c((length(beg)+1),1))
        for(i in 1:length(beg)) {
            paramXCITable <- paramXCITable_Full[beg[i]:end[i], ]
            cols <- sign[beg[i]:end[i]]
            par(mar=c(1,2,1,1))
            plot(0, 0, xlim = c(1, nrow(paramXCITable)), ylim = round(range(paramXCITable)), type = "n", xlab = "", ylab = "", main=paste(colnames(mixingMeansParamX)[i]), xaxt="n", bty = 'n')
            axis(1,1:124,las=2, labels = rep('',124))
            abline(h = 0,col = 'grey')
            arrows(x0 = 1:nrow(paramXCITable), x1 = 1:nrow(paramXCITable), y0 = paramXCITable[, 2], y1 = paramXCITable[, 3], code = 3, angle = 90, length = 0.05, col = cols)
            points(1:nrow(paramXCITable), paramXCITable[,1], pch = 15, cex = 1, col = cols)
        }
        mtext(text = sp[,'N_EspSci'], side = 1, line = 1, outer = FALSE, at = 1:124, col = 1, las = 2, cex = 0.4)
        dev.off()

# =========================
# 5.1 Variance partitioning
# =========================

    # for parameter names: colnames(mixingMeansParamX)
    nGroup <- length(unique(envGroup)) + 2
    variationPart <- variPart(model, envGroup)
    saveRDS(variationPart, file = './RData/variPart.rds')

    Colour <- rainbow(n = nGroup, s = 1, v = 1, start = 0, end = max(1, nGroup - 1)/nGroup, alpha = 1)

    jpeg(paste(fig,'variancePartitioning.jpeg',sep=''), width = 6, height = 4, res = 150, units = 'in')
        par(mfrow = c(1,1), mar = c(6,3,1,1))
        barplot(t(variationPart), col=Colour, names.arg = sp[, 'N_EspSci'], las = 2, cex.names = 0.4, cex.axis = 0.6)

        # Create legend elements
            legendVector <- character(nGroup)
            variPartLabel <- c(unique(envGroup), 'Random site', 'Random plot')

            for(i in 1:nGroup) {
                legendVector[i] <- paste(variPartLabel[i], ' (mean = ', round(mean(variationPart[, i]), 4)*100, "%)", sep="")
            }

        legend('bottomleft', legend = legendVector, fill = Colour, bg = 'white', cex = 0.5)
    dev.off()

# ========================================================================
# 5.2 Variance partitioning for individual parameters (species diagnotics)
# ========================================================================

    # Extract variance partitioning per parameters for individual taxa diagnostics
        nGroup <- length(envCov) + 2
        variationPart <- variPart(model, c('Intercept',envCov))
        saveRDS(variationPart, file = './RData/variPartInd.rds')

# =======================
# 6. Association networks
# =======================
    # Extract all estimated associatin matrix
        assoMat <- corRandomEff(model)

    # Average
        siteMean <- apply(assoMat[, , , 1], 1:2, mean)
        plotMean <- apply(assoMat[, , , 2], 1:2, mean)
        colnames(plotMean) <- rownames(plotMean) <- sp[,'N_EspSci']
        saveRDS(plotMean, file = './RData/plotMean.rds')

    #--------------------
    ### Site level effect
    #--------------------
    # Build matrix of colours for chordDiagram
        siteDrawCol <- matrix(NA, nrow = nrow(siteMean), ncol = ncol(siteMean))
        siteDrawCol[which(siteMean > 0.4, arr.ind=TRUE)]<-"red"
        siteDrawCol[which(siteMean < -0.4, arr.ind=TRUE)]<-"blue"
    # Build matrix of "significance" for corrplot
        siteDraw <- siteDrawCol
        siteDraw[which(!is.na(siteDraw), arr.ind = TRUE)] <- 0
        siteDraw[which(is.na(siteDraw), arr.ind = TRUE)] <- 1
        siteDraw <- matrix(as.numeric(siteDraw), nrow = nrow(siteMean), ncol = ncol(siteMean))
    #--------------------
    ### Plot level effect
    #--------------------
    # Build matrix of colours for chordDiagram
        plotDrawCol <- matrix(NA, nrow = nrow(plotMean), ncol = ncol(plotMean))
        plotDrawCol[which(plotMean > 0.4, arr.ind=TRUE)]<-"red"
        plotDrawCol[which(plotMean < -0.4, arr.ind=TRUE)]<-"blue"
    # Build matrix of "significance" for corrplot
        plotDraw <- plotDrawCol
        plotDraw[which(!is.na(plotDraw), arr.ind = TRUE)] <- 0
        plotDraw[which(is.na(plotDraw), arr.ind = TRUE)] <- 1
        plotDraw <- matrix(as.numeric(plotDraw), nrow = nrow(plotMean), ncol = ncol(plotMean))

    # # plotDraw plots
        # par(mfrow=c(1,2))
        # # Matrix plot
        # Colour <- colorRampPalette(c("blue", "white", "red"))(200)
        # corrplot::corrplot(siteMean, method = "color", col = Colour, type = "lower", diag = FALSE, p.mat = siteDraw, tl.srt = 45)
        # # Chord diagram
        # circlize::chordDiagram(siteMean, symmetric = TRUE, annotationTrack = c("name", "grid"), grid.col = "grey", col = siteDrawCol)

    # siteDraw plots
        jpeg(paste(fig,'correlationPlot.jpeg',sep=''), width = 7, height = 7, res = 150, units = 'in')
        # Matrix plot
        Colour <- colorRampPalette(c("blue", "white", "red"))(200)
        corrplot::corrplot(plotMean, method = "color", col = Colour, type = "lower", diag = FALSE, p.mat = plotDraw, tl.srt = 65, tl.cex = 0.4, pch.cex = 0.3, tl.col = 'black')
        dev.off()

        jpeg(paste(fig,'chordDiagram.jpeg',sep=''), width = 7, height = 7, res = 150, units = 'in')
        # Chord diagram
        circlize::chordDiagram(plotMean, symmetric = TRUE, annotationTrack = 'grid', grid.col = "grey", col = plotDrawCol, preAllocateTracks = 1)
        circlize::circos.trackPlotRegion(track.index = 1, panel.fun = function(x, y) {
          xlim = circlize::get.cell.meta.data("xlim")
          ylim = circlize::get.cell.meta.data("ylim")
          sector.name = circlize::get.cell.meta.data("sector.index")
          circlize::circos.text(mean(xlim), ylim[1] + .1, sector.name, facing = "clockwise", niceFacing = TRUE, adj = c(0, 0.5), cex = 0.4)
        #   circlize::circos.axis(h = "top", labels.cex = 0.5, major.tick.percentage = 0.2, sector.index = sector.name, track.index = 2)
        }, bg.border = NA)
        dev.off()

# ===============================================
# 7. Computing the explanatory power of the model
# ===============================================
    # Prevalence
        prevSp <- colSums(northPluri_HMSC$Y)
    # Coefficient of multiple determination
        R2 <- Rsquared(model, averageSp = FALSE)
        R2comm <- Rsquared(model, averageSp = TRUE)

    # Save R^2 calculation for individual summaries
        saveRDS(R2, file = './RData/modelR2.rds')
        saveRDS(R2comm, file = './RData/modelR2comm.rds')

    # Draw figure
        jpeg(paste(fig,'r2summaries.jpeg',sep=''), width = 6, height = 5, res = 150, units = 'in')
        plot(prevSp, R2, xlab = "Prevalence", ylab = expression(R^2), cex = 0.8, pch=19, las=1, cex.lab = 1, main = 'Explanatory power of the model')
        abline(h = R2comm, col = "blue", lwd = 2)
        dev.off()

    # Extract all MCMC of paramX
        # model$results$estimation$paramX

    ### Full joint probability distribution
        # fullPost <- jposterior(model)

# =============================================
# 8. Generating predictions for validation data
# =============================================

    modelAUC <- crossValidation(data = northPluri_HMSC,  nCV = 20, validPct = 0.2)
    saveRDS(modelAUC, file = './RData/modelAUC.rds')

    meanAUC <- colMeans(modelAUC)
    sdAUC <- apply(modelAUC, MARGIN = 2, FUN = sd)

    jpeg(paste(fig,'crossValidation.jpeg',sep=''), width = 6, height = 5, res = 150, units = 'in')
        plot(prevSp, meanAUC, ylim = c(0,1), xlab = "Prevalence", ylab = 'AUC', cex = 0.8, pch=19, las=1, cex.lab = 1, main = 'Monte Carlo cross-validation with AUC of ROC curves')
        abline(h = 0.5, col = 'grey')
        arrows(x0 = prevSp, x1 = prevSp, y0 = (meanAUC - sdAUC), y1 = (meanAUC + sdAUC), code = 3, angle = 90, length = 0.05)
        points(prevSp, meanAUC, pch = 19, cex = 0.8)
    dev.off()

# # =============================================
# # 9. Generating predictions from complete model
# # =============================================
#
#     modelPredictions <- predict(model)
#     saveRDS(modelPredictions, file = './RData/modelPredictions.rds')

# =========================================
# 10. Generating predictions study area grid
# =========================================

    # Load HMSC model
        model <- readRDS('./RData/modelHSMC.rds')

    # Importing data for study grid that I wish to use for species distribution predictions
        egsl <- readRDS('./RData/egsl_grid.rds')

    # Use 'Bathy_Mean' instead of 'Prof', as 'Prof' comes from northPluri data
        colnames(egsl)[which(colnames(egsl) == 'Bathy_Mean')] <- 'Prof'

    # 'Prof' is positive, while 'Bathy_Mean' is negative, uniformize for model
        egsl[, 'Prof'] <- -egsl[, 'Prof']

    # 'x' and 'y' in egsl grid data, change to match environmental variables used
        colN <- colnames(egsl)
        colnames(egsl)[colN == 'x'] <- 'LoDeTow'
        colnames(egsl)[colN == 'y'] <- 'LaDeTow'

    # Remove NAs
        envCov <- c('Prof','SSAL_MEAN','SalMoyMoy','TempMoyMoy','STEMMEAN','BTEMMEAN','O2_Sat_Mea','LaDeTow','LoDeTow')
        NAs <- egsl[, envCov] %>%
                lapply(X = ., FUN = function(x) which(is.na(x))) %>%
                unlist(.) %>%
                unique(.)

        egsl <- egsl[-NAs, ]

    # New environmental covariables matrix (X matrix)
        Xnew <- egsl[, envCov]

    # New site- and plot-level random effect (Pi matrix)
        PiNew <- data.frame(sampling_unit = as.factor(egsl[, 'ID']),
                         survey_number = as.factor(rep(1, nrow(egsl))))

    # Organize the data into an HMSCdata object
        dataEGSL <- as.HMSCdata(X = Xnew, Random = PiNew, scaleX = T, interceptX = T)

    # Generate predictions
        predEGSL <- predict(model, newdata = dataEGSL)

    # Replace NAs in grid
        data <- matrix(nrow = (length(NAs) + nrow(predEGSL)), ncol = ncol(predEGSL), data = 0)
        dimnames(data) = list(paste('ID',seq(1:nrow(data)), sep = ''), colnames(predEGSL))
        data[NAs, ] <- NA
        data[seq(1:nrow(data))[-NAs], ] <- predEGSL
        predEGSL <- data

    # Save predictions
        saveRDS(predEGSL, file = './RData/predEGSL.rds')


engScript_add <- function(engScript_a, engScript_b){
    return((engScript_a + engScript_b))
}


# Code to generate plots for manuscript
library(rstan)
library(plyr)
library(magrittr)
library(lubridate)
library(ggplot2)
library(gridExtra)
library(patchwork)
library(reshape2)

# Loading and processing mosquito and case data
tseries <- read.csv("Data/Vitoria.data.csv")

post <- ddply(tseries, .(tot.week), summarise,
              qobs = sum(Mosquitoes, na.rm = T),
              yobs = sum(Cases, na.rm = T),
              tau = sum(Trap, na.rm = T),
              week = unique(Week),
              year = unique(Year),
              epiweek = 0,
              epiyear = 0)

# Generating epidemic weeks/years that count from peak to peak (week 16)
post$epiweek[16:243] <- c(1:52)
post$epiyear <- cumsum(post$epiweek == 1)

# Population size
pop <- 327801

# Loading and processing the weather data
weather <- read.csv("Data/Vitoria.weather.csv") %>%
  mutate(date = ymd(BRST), year = year(date), week = week(date))

weather <- subset(weather, date < date[1] + weeks(243))
weather$control <- rep(c(1:243), each = 7)

temp <- ddply(weather, .(control), summarise, temp = mean(Mean.TemperatureC, na.rm = T),
              humid = mean(Mean.Humidity, na.rm = T))

post$temp <- temp$temp
post$rov <- 7 * exp(0.21 * temp$temp - 7.9)

# Loading MCMC results
sim <- readRDS("Results/chain.rds")

# Effect of control in the number of cases in the following year
moving <- readRDS("Results/moving_control.rds")

# Figure 1: Observed and estimated time series =================================

# Case reports
yhat <- rstan::extract(sim, c("y_meas"), permute = T)[[1]] %>%
  reshape2::melt(varnames = c("rep", "week"), value.name = "yhat") %>%
  ddply(.(week), summarise,
        ymed = median(yhat),
        ymin = quantile(yhat, 0.1),
        ymax = quantile(yhat, 0.9))

# Trapped mosquitoes
qhat <- rstan::extract(sim, c("q_meas"), permute = T)[[1]] %>%
  reshape2::melt(varnames = c("rep", "week"), value.name = "qhat") %>%
  ddply(.(week), summarise,
        qmed = median(qhat),
        qmin = quantile(qhat, 0.1),
        qmax = quantile(qhat, 0.9))

# Mosquito mortality rate
system <- rstan::extract(sim, "state", permute = T)[[1]]

dvmu <- data.frame(rep = 1:dim(system)[1],
                   dvmu = 1.47 * rstan::extract(sim, "dvmu_c", permute = T)[[1]])

dv <- system[, 2:244, 12] %>%
  reshape2::melt(varnames = c("rep", "control"), value.name = "dv") %>%
  mutate(dvnat = exp(dv)) %>%
  join(dvmu) %>%
  mutate(dvnat = dvnat * dvmu) %>%
  join(temp)

# Plotting
yhat %>%
  ggplot(aes(week, ymin = ymin, ymax = ymax)) +
  geom_ribbon(fill = "grey70") +
  geom_line(aes(week, ymed)) +
  geom_point(aes(tot.week, yobs), data = post, inherit.aes = FALSE, size = 0.5) +
  theme_classic() +
  scale_y_continuous(expand = c(0, 0)) +
  scale_x_continuous(expand = c(0, 1), breaks = c(1, 54, 106, 158, 210), labels = c(2008, 2009, 2010, 2011, 2012)) +
  ylab("case reports") +
  xlab("year") +
  ggtitle("A") -> fig1a

qhat %>%
  ggplot(aes(week, ymin = qmin, ymax = qmax)) +
  geom_ribbon(fill = "grey70") +
  geom_line(aes(week, qmed)) +
  geom_point(aes(tot.week, qobs), data = post, inherit.aes = FALSE, size = 0.5) +
  theme_classic() +
  scale_y_continuous(expand = c(0, 0)) +
  scale_x_continuous(expand = c(0, 1), breaks = c(1, 54, 106, 158, 210), labels = c(2008, 2009, 2010, 2011, 2012)) +
  ylab("mosquitoes trapped") +
  xlab("year") +
  ggtitle("B") -> fig1b

post %>%
  ggplot(aes(tot.week, 1 / rov)) +
  geom_line() +
  theme_classic() +
  scale_y_continuous(expand = c(0.05, 0)) +
  scale_x_continuous(expand = c(0, 1), breaks = c(1, 54, 106, 158, 210), labels = c(2008, 2009, 2010, 2011, 2012)) +
  ylab("EIP (weeks)") +
  xlab("year") +
  ggtitle("C") -> fig1c

dv %>%
  ggplot(aes(control, dvnat)) +
  stat_summary(fun.ymin = function(x) quantile(x, 0.05),
               fun.ymax = function(x) quantile(x, 0.95),
               geom = "ribbon", fill = "gray70") +
  stat_summary(fun.y = "median", geom = "line") +
  theme_classic() +
  scale_y_continuous(expand = c(0.05, 0)) +
  scale_x_continuous(expand = c(0, 1), breaks = c(1, 54, 106, 158, 210), labels = c(2008, 2009, 2010, 2011, 2012)) +
  ylab("mosquito mortality rate") +
  xlab("year") +
  ggtitle("D") -> fig1d

postscript("Manuscript/figures/fig1.eps",
     width = 5, height = 7, paper = "special", horizontal = FALSE,
     family = "ArialMT")

fig1a + fig1b + fig1c + fig1d + plot_layout(ncol = 1)

dev.off()

# Figure 2: Estimates of latent mosquito mortality rate ========================

postscript("Manuscript/figures/fig2.eps",
           width = 4, height = 3, paper = "special", horizontal = FALSE,
           family = "ArialMT")

dv %>%
  ddply(.(control), summarise,
        dvnat = median(dvnat),
        temp = median(temp)) %>%
  ggplot(aes(temp, dvnat)) +
  geom_point() +
  theme_classic() +
  scale_y_continuous(expand = c(0.05, 0)) +
  scale_x_continuous(expand = c(0, 1)) +
  ylab("mosquito mortality rate") +
  xlab("weekly mean temperature")

dev.off()

# Figure 3: Effect of adult control implemented in different weeks ===================

# Adding week and year to moving window control results
moving <- moving %>%
  dplyr::rename("dv0" = "dvmu") %>%
  mutate(week = week(ymd("2008-01-01") + weeks(control - 1)),
         year = year(ymd("2008-01-01") + weeks(control - 1))) %>%
  join(dv)

# Computing the overall effect of control over 2008-2010
overall <- moving %>%
  subset(year < 2011) %>%
  ddply(.(rep, week), summarise,
        tcases = sum(tcases),
        tcases0 = sum(tcases0),
        ratio = tcases / tcases0,
        diff = tcases0 - tcases,
        dv0 = mean(dv0),
        dvmu = mean(dvmu),
        delta = mean(delta),
        phi = mean(phi))

overall <- dplyr::bind_rows(overall, moving) %>%
  mutate(year = factor(year, exclude = NULL, labels = c("2008","2009", "2010", "2011", "2012", "overall")))

# Computing the median overall best week for control
overall %>%
  ddply(.(rep, year), summarise,
        argmin = week[which.min(ratio)]) %>%
  ddply(.(year), summarise,
        argmin = median(argmin))

# Plotting

postscript("Manuscript/figures/fig3.eps",
           width = 4, height = 5, paper = "special", horizontal = FALSE,
           family = "ArialMT")

overall %>%
  subset(year %in% c("2008", "2009", "2010", "overall") & week < 53) %>%
  ggplot(aes(week, ratio)) +
  stat_summary(fun.ymin = function(x) quantile(x, 0.1),
               fun.ymax = function(x) quantile(x, 0.9),
               geom = "ribbon", fill = "gray70") +
  stat_summary(fun.y = "median", geom = "line") +
  facet_grid(year ~.) +
  geom_hline(yintercept = 1.0, color = "gray50", linetype = 2) +
  theme_classic() +
  theme(strip.background = element_blank()) +
  scale_x_continuous(expand = c(0, 0)) +
  xlab("week of control") +
  ylab("case ratio over following year")

dev.off()

# Figure 4: effect of phi on effectiveness of control ==========================

overall%>%
  subset(week == 34 & year == "overall") %>%
  ggplot(aes(dvmu, ratio)) +
  geom_point(size = 0.5) +
  theme_classic() +
  theme(strip.background = element_blank()) +
  labs(x = "mosquito mortality rate", y = "case ratio") -> fig4a

overall%>%
  subset(week == 34 & year == "overall") %>%
  ggplot(aes(phi, ratio)) +
  geom_point(size = 0.5) +
  theme_classic() +
  theme(strip.background = element_blank()) +
  labs(x = "case reporting probability", y = "case ratio") -> fig4b

postscript("Manuscript/figures/fig4.eps",
           width = 6, height = 3, paper = "special", horizontal = FALSE,
           family = "ArialMT")

fig4a + fig4b

dev.off()

# State var and control correlations ===========================================

# Cases
cases <- system[, , 11] %>%
  aaply(1, diff) %>%
  multiply_by(pop) %>%
  reshape2::melt(varnames = c("rep", "control"), value.name = "cases")

# Mosquitoes
mosq <- system[, 2:244, 9] %>%
  reshape2::melt(varnames = c("rep", "control"), value.name = "mosq")

# Probability of surviving EIP
infmosq <- system[, , 17] %>%
  aaply(1, diff) %>%
  melt(varnames = c("rep", "control"), value.name = "inf")

deadmosq <- system[, , 16] %>%
  aaply(1, diff) %>%
  reshape2::melt(varnames = c("rep", "control"), value.name = "dead")

surv <- join(infmosq, deadmosq) %>%
  mutate(total_exits = dead + inf,
         psurv = inf / total_exits)

# Joining everything
moving <- join(moving, cases) %>%
  join(mosq) %>%
  join(surv)

postcorr <- moving %>%
  subset(control < 191) %>%
  ddply(.(rep), summarise,
        dv = cor(ratio, dvnat),
        mosq = cor(ratio, mosq),
        cases = cor(ratio, cases),
        psurv = cor(ratio, psurv),
        temp = cor(ratio, temp))

colwise(median)(postcorr)

#===============================================================================
# Supplemental figures
#===============================================================================

# Figure S1: epsilons ==========================================================

eps_dv <- rstan::extract(sim, "eps_dv", permute = T)[[1]] %>%
  adply(2, quantile, c(0.1, 0.5, 0.9)) %>%
  mutate(week = as.numeric(X1))
names(eps_dv) <- c("X1", "min", "med", "max", "week")

eps_rv <- rstan::extract(sim, "eps_rv", permute = T)[[1]] %>%
  adply(2, quantile, c(0.1, 0.5, 0.9)) %>%
  mutate(week = as.numeric(X1))
names(eps_rv) <- c("X1", "min", "med", "max", "week")

postscript("Manuscript/figures/figS1.eps",
           width = 5.2, height = 3,
           family = "ArialMT")

ggplot(eps_dv, aes(week, med)) +
  geom_ribbon(aes(ymin = min, ymax = max), fill = "grey70") +
  geom_line() +
  geom_hline(yintercept = 0, linetype = 2) +
  theme_classic() +
  scale_x_continuous(expand = c(0, 1)) +
  ylab(expression(epsilon[nu])) +
  ggtitle("A") -> figs1.a

ggplot(eps_rv, aes(week, med)) +
  geom_ribbon(aes(ymin = min, ymax = max), fill = "grey70") +
  geom_line() +
  theme_classic() +
  scale_x_continuous(expand = c(0, 1)) +
  ylab(expression(epsilon[r])) +
  ggtitle("B") -> figs2.b

grid.arrange(figs1.a, figs2.b, nrow = 1)

dev.off()

# Figure S2: sigmas ============================================================

postscript("Manuscript/figures/figS2.eps",
           width = 6, height = 4,
           family = "ArialMT")

par(mfrow = c(1, 2))
rstan::extract(sim, "sigmadv", permute = T)[[1]] %>% hist(main = "A", xlab = expression(sigma[d]), freq = F)
rstan::extract(sim, "sigmarv", permute = T)[[1]] %>% hist(main = "B", xlab = expression(sigma[r]), freq = F)

dev.off()

# Figure S3: epidemiological parameters ===================================================

epiparams <- rstan::extract(sim, c("ro_c", "gamma_c", "delta_c", "dvmu_c"), permute = T)

postscript("Manuscript/figures/figS3.eps",
           width = 6, height = 6,
           family = "ArialMT")

par(mfrow = c(2, 2))

hist(epiparams[[1]], main = "A", xlab = "scaled latent period", freq = F, breaks = 30, ylim = c(0, 1.2))
curve(dgamma(x, 8.3, 8.3), add = T, lwd = 2)

hist(epiparams[[2]], main = "B", xlab = "scaled rate of infectious decay", freq = F, breaks = 30)
curve(dgamma(x, 100, 100), add = T, lwd = 2)

hist(epiparams[[3]], main = "C", xlab = "scaled period of cross-immunity", freq = F, breaks = 30, ylim = c(0, 1.3))
curve(dgamma(x, 10, 10), add = T, lwd = 2)

hist(epiparams[[4]], main = "D", xlab = "scaled mosquito mortality rate", freq = F, breaks = 30)
curve(dgamma(x, 100, 10), add = T, lwd = 2)

dev.off()

# Figure S4: initial conditions ===========================================================

ics <- rstan::extract(sim, c("S0", "E0","I0", "logNv", "dv0", "rv0"), permute = T)

postscript("Manuscript/figures/figS4.eps",
           width = 6, height = 5,
           family = "ArialMT")

par(mfrow = c(2, 3))

hist(ics$S0, freq = F, main = "A", xlab = expression(S[0]))
curve(dbeta(x, 4, 6), add = T, lwd = 2)

hist(ics$E0, freq = F, main = "B", xlab = expression(E[0]), ylim = c(0, 0.015))
curve(dgamma(x, 10, 0.1), add = T, lwd = 2)

hist(ics$I0, freq = F, main = "C", xlab = expression(I[0]), ylim = c(0, 0.02))
curve(dgamma(x, 6, 0.1), add = T, lwd = 2)

hist(ics$logNv, freq = F, main = "D", xlab = expression(log(V[N0])))
curve(dnorm(x, 0.7, 0.3), add = T, lwd = 2)

hist(ics$dv0, freq = F, main = "E", xlab = expression(nu[0]))
curve(dnorm(x, 0, 0.5), add = T, lwd = 2)

hist(ics$rv0, freq = F, main = "F", xlab = expression(r[0]))
curve(dnorm(x, 0, 0.5), add = T, lwd = 2)

dev.off()

# Figure S5: Measurement parameters ============================================

library(truncnorm)

meas <- rstan::extract(sim, c("log_phi_q", "phi_y", "eta_inv_q", "eta_inv_y"), permute = T)

postscript("Manuscript/figures/figS5.eps",
           width = 6, height = 6,
           family = "ArialMT")

par(mfrow = c(2, 2))

hist(meas$log_phi_q, freq = F, main = "A", xlab = expression(log(phi[q])))
curve(dnorm(x, -13, 0.5), add = T, lwd = 2)

hist(meas$phi_y, freq = F, main = "B", xlab = expression(phi[y]))
curve(dbeta(x, 7, 77), add = T, lwd = 2)

hist(meas$eta_inv_q, freq = F, main = "C", xlab = expression(eta[q]))
curve(dtruncnorm(x, a = 0, b = Inf, mean = 0, sd = 5), add = T)

hist(meas$eta_inv_y, freq = F, main = "D", xlab = expression(eta[y]))
curve(dtruncnorm(x, a = 0, b = Inf, mean = 0, sd = 5), add = T)

dev.off()

# Model checking ===============================================================

yrep <- rstan::extract(sim, "y_meas", permute = T)[[1]]
qrep <- rstan::extract(sim, "q_meas", permute = T)[[1]]

# Figure S6: ACF plots =========================================================

# Calculating the observed autocorrelation function
yacf <- acf(post$yobs, lag.max = 55, plot = F)$acf
qacf <- acf(post$qobs, lag.max = 55, plot = F)$acf

# Summarizing the posterior acf
yacfrange <- apply(yrep, 1, function(x){acf(x, lag.max = 55, plot = F)$acf}) %>%
  apply(1, quantile, probs = c(0.1,0.5, 0.9))

qacfrange <- apply(qrep, 1, function(x){acf(x, lag.max = 55, plot = F)$acf}) %>%
  apply(1, quantile, probs = c(0.1,0.5, 0.9))

# Assembling data frame for ggplot
acfdf <- data.frame("lag" = c(0:55),
                    "yobs" = yacf,
                    "qobs" = qacf,
                    "ymed" = yacfrange[2, ],
                    "ymin" = yacfrange[1, ],
                    "ymax" = yacfrange[3, ],
                    "qmed" = qacfrange[2, ],
                    "qmin" = qacfrange[1, ],
                    "qmax" = qacfrange[3, ]
                    )

# Plots
ggplot(acfdf, aes(lag, yobs)) +
  geom_hline(yintercept = 0, color = "gray50") +
  geom_linerange(aes(lag, ymin = ymin, ymax = ymax)) +
  geom_point() +
  theme_classic() +
  xlab("lag (weeks)") +
  ylab("case autocorrelation") +
  scale_x_continuous(expand = c(0, 0.1)) +
  ggtitle("A") -> figs5.a

ggplot(acfdf, aes(lag, qobs)) +
  geom_hline(yintercept = 0, color = "gray50") +
  geom_linerange(aes(lag, ymin = qmin, ymax = qmax)) +
  geom_point() +
  theme_classic() +
  xlab("lag (weeks)") +
  ylab("mosquito autocorrelation") +
  scale_x_continuous(expand = c(0, 0.1)) +
  ggtitle("B") -> figs5.b

postscript("Manuscript/figures/figS6.eps",
           width = 5.2, height = 3,
           family = "ArialMT")

grid.arrange(figs5.a, figs5.b, nrow = 1)

dev.off()

# Figure S7: Totals ============================================================

postscript("Manuscript/figures/figS7.eps",
           width = 6, height = 4,
           family = "ArialMT")

par(mfrow = c(1, 2))

hist(rowSums(yrep), main = "A", xlab = "total cases", freq = F, breaks = 20)
abline(v = sum(post$yobs), lwd = 2)

hist(rowSums(qrep), main = "B", xlab = "total captured mosquitoes", freq = F, breaks = 20)
abline(v = sum(post$qobs), lwd = 2)

dev.off()

# Figure S8: Min and max ===========================================================

postscript("Manuscript/figures/figS8.eps",
           width = 6, height = 6,
           family = "ArialMT")

par(mfrow = c(2, 2))

hist(apply(yrep, 1, max), main = "A", xlab = "maximum weekly cases", freq = F)
abline(v = max(post$yobs), lwd = 2)

hist(apply(qrep, 1, max), main = "B", xlab = "maximum weekly trap count", freq = F)
abline(v = max(post$qobs), lwd = 2)

hist(apply(yrep, 1, min), main = "C", xlab = "minimum weekly cases", freq = F)
abline(v = min(post$yobs), lwd = 2)

hist(apply(qrep, 1, min), main = "D", xlab = "minimum weekly trap count", freq = F)
abline(v = min(post$qobs), lwd = 2)

dev.off()

# Figure S9: Probability of surviving EIP ======================================

postscript("Manuscript/figures/figS9.eps",
           width = 6, height = 5,
           family = "ArialMT")

moving %>%
  ggplot(aes(control, psurv)) +
  stat_summary(fun.ymin = function(x) quantile(x, 0.1),
               fun.ymax = function(x) quantile(x, 0.9),
               geom = "ribbon", fill = "gray70") +
  stat_summary(fun.y = "median", geom = "line") +
  theme_classic() +
  scale_x_continuous(expand = c(0, 1), breaks = c(1, 54, 106, 158, 210), labels = c(2008, 2009, 2010, 2011, 2012)) +
  xlab("year") +
  ylab("probability of surviving EIP") -> figS9a

fig1d + ggtitle("") + figS9a + plot_layout(ncol = 1)

dev.off()


# All load of data goes here

moocs <- read.csv("./data/HMXPC13_DI_v2_5-14-14.csv" ,header=TRUE, sep=",");
# We keep only information from users that have obtained a certificate of completion
data <- moocs[moocs$certified == "1",]
# We keep data only for registrants
data <- moocs[moocs$registered == "1",]
# Years of students (we traduce year of birth to age)
years <- 2014 - data$YoB
# Variable for range of studies
studies <- data$LoE_DI

#tcertified <- table(studies,certified) # Number of#certified users by its LoE
# t1 <- table(studies, courses) # Count ocurrences of level of studies per course
# t2 <- table(studies)          # Count ocurrences of level of studies in all courses

#2
categories <- c(10,18,25,30,35,45,55,65,80,90)
agecat <- cut(years, categories)
table(agecat)

# 3
gender <- table(data$gender)
genderpercent <- gender/sum(gender)*100
labels <- c("Missing","Female","Male","Other")
genderpercent <- round(genderpercent, digits=0)
labels <- paste(labels, genderpercent)
labels <- paste(labels,"%",sep="") # ad % to labels

# 4
dataf <- table(data$final_cc_cname_DI)
Countries <- as.data.frame(dataf)
Countries[1] <- countrycode(Countries$Var1,"country.name", "iso3c")

sPDF <- joinCountryData2Map(Countries, joinCode = "NAME", nameJoinColumn = "Var1")
mapCountryData(sPDF, nameColumnToPlot="Freq", mapTitle="Nº de alumnos certificados atendiendo al País", colourPalette="terrain")

# Adding courses list
course_id <- as.data.frame(unique(data$course_id))
df4 <- course_id
df4 <- cbind(fullname = names, df4)

names = c("CB22x, The Ancient Greek Hero (Launched Spring, 2013)",
          "CS50x, Introduction to Computer Science (Launched Fall, 2012)",
          "ER22x, Justice (Launched Spring, 2013)",
          "PH207x, Health in Numbers: Quantitative Methods in Clinical & Public Health Research (Launched Fall, 2012)",
          "PH278x, Human Health and Global Environmental Change (Launched Spring, 2013)",
          "6.002x, Circuits and Electronics (Launched Fall, 2012)",
          "6.002x, Circuits and Electronics (Launched Spring, 2013)",
          "14.73x, The Challenges of Global Poverty (Launched Spring, 2013)",
          "2.01x, Elements of Structures (Launched Spring, 2013)",
          "3.091x, Introduction to Solid State Chemistry (Launched Fall, 2012)",
          "3.091x, Introduction to Solid State Chemistry (Launched Spring, 2013)",
          "6.00x, Introduction to Computer Science Programming (Launched Fall, 2012)",
          "6.00x, Introduction to Computer Science Programming (Launched Spring, 2013)",
          "7.00x, Introduction to Biology - The Secret of Life (Launched Spring, 2013)",
          "8.02x, Electricity and Magnetism (Launched Spring, 2013)",
          "8.MReV, Mechanics ReView (Launched Summer, 2013)")

colnames(df4)[2] <- "course_id"


#### continuous_rqa_parameters-DCC.r: Part of `dual-conversation-constraints.Rmd` ####
#
# This script explores the parameters for the continuous cross-recurrence analysis
# that we'll run over the movement data. Because this is a lengthy process,
# we create a series of files along the way that can be re-run in pieces if needed.
# This allows us to keep this file commented by default.
#
# Written by: A. Paxton (University of California, Berkeley)
# Date last modified: 15 May 2017
#####################################################################################

#### 1. Preliminaries ####

# read in libraries and functions
source('./supplementary-code/libraries_and_functions-DCC.r')

# prep workspace and libraries
invisible(lapply(c('tseriesChaos',
                   'nonlinearTseries',
                   'crqa',
                   'quantmod',
                   'beepr'),
                 require,
                 character.only = TRUE))

# read in coords dataset
coords = read.table('./data/DCC-trimmed-data.csv', sep=',', header = TRUE)

#### 2. Determine delay with average mutual information (AMI) ####

# set maximum AMI
ami.lag.max = 100

# get AMI (lag and value) for both participants in each dyad
amis = coords %>% ungroup() %>%
  group_by(dyad,conv.type) %>%
  mutate(ami.val0 = min(as.numeric(mutual(euclid0, lag.max = ami.lag.max, plot = FALSE)),na.rm=TRUE)) %>%
  mutate(ami.val1 = min(as.numeric(mutual(euclid1, lag.max = ami.lag.max, plot = FALSE)),na.rm=TRUE)) %>%
  mutate(ami.loc0 = which.min(as.numeric(mutual(euclid0, lag.max = ami.lag.max, plot = FALSE)))-1) %>%
  mutate(ami.loc1 = which.min(as.numeric(mutual(euclid1, lag.max = ami.lag.max, plot = FALSE)))-1) %>%
  group_by(dyad,conv.num,conv.type,ami.val0,ami.val1,ami.loc0,ami.loc1) %>%
  distinct() %>%
  mutate(ami.selected = min(ami.loc1,ami.loc0))

# write AMI information to file
write.table(amis,'./data/crqa_parameters/ami_calculations-DCC.csv', sep=',',row.names=FALSE,col.names=TRUE)

# if we've already run it, load it in
amis = read.table('./data/crqa_parameters/ami_calculations-DCC.csv', sep=',',header=TRUE)

# join the AMI information to our whole dataframe
coords = join(coords,amis,by=c("dyad",'conv.type','conv.num'))

#### 3. Determing embedding dimension with FNN ####

# set maximum percentage of false nearest neighbors
fnnpercent = 10

# create empty dataframe
fnns = data.frame(dyad = numeric(),
                  partic = numeric(),
                  conv.type = numeric(),
                  head.embed = numeric(),
                  tail.embed = numeric())

# cycle through both conversations for each dyad
convo.dfs = split(coords,list(coords$dyad,coords$conv.type))
for (conv.code in names(convo.dfs)){

  # cycle through participants
  for (partic in 0:1){

    # print update
    print(paste("Beginning FNN calculations for P",partic," of Conversation ",conv.code,sep=""))

    # grab next participant's data
    p.data = select(convo.dfs[[conv.code]],matches(paste("euclid",partic,sep="")))[,1]
    p.ami = unique(convo.dfs[[conv.code]]$ami.selected)

    # only proceed if we have the dyad's data
    if (length(p.data) > 0) {

      # calculate false nearest neighbors
      fnn = false.nearest(p.data,
                          m = fnnpercent,
                          d = p.ami,
                          t = 0,
                          rt = 10,
                          eps = sd(p.data)/10)
      fnn = fnn[1,][complete.cases(fnn[1,])]
      threshold = fnn[1]/fnnpercent

      # identify the largest dimension after a large drop
      embed.dim.index = as.numeric(which(diff(fnn) < -threshold)) + 1
      head.embed = head(embed.dim.index,1)
      tail.embed = tail(embed.dim.index,1)
      if (length(embed.dim.index) == 0){
        head.embed = 1
        tail.embed = 1
      }

      # identify conversation type and dyad number from information
      conv.info = unlist(strsplit(conv.code,'[.]'))
      dyad = as.integer(conv.info[1])
      conv.type = as.integer(conv.info[2])

      # bind everything to data frame
      fnns = rbind.data.frame(fnns,
                              cbind.data.frame(dyad,
                                               partic,
                                               conv.type,
                                               head.embed,
                                               tail.embed))

    }}}

# change table configuration so that we get participants' embedding dimensions as columns, not rows
fnn.partic = split(fnns,fnns$partic)
fnn.partic.0 = plyr::rename(as.data.frame(fnn.partic[["0"]]),c('head.embed' = 'embed.0')) %>%
  select(dyad,conv.type,embed.0)
fnn.partic.1 = plyr::rename(as.data.frame(fnn.partic[["1"]]),c('head.embed' = 'embed.1')) %>%
  select(dyad,conv.type,embed.1)
fnn.merged = join(fnn.partic.0,fnn.partic.1,by=c("dyad","conv.type"))

# choose the largest embedding dimension
fnn.merged = fnn.merged %>% ungroup() %>%
  group_by(dyad,conv.type) %>%
  mutate(embed.selected = max(c(embed.0,embed.1)))

# save false nearest neighbor calculations to file
write.table(fnn.merged,'./data/crqa_parameters/fnn_calculations-DCC.csv', sep=',',row.names=FALSE,col.names=TRUE)

# if we've already run it, load it in
fnn.merged = read.table('./data/crqa_parameters/fnn_calculations-DCC.csv', sep=',',header=TRUE)

# merge with coords dataset
coords = join(coords, fnn.merged, by = c("dyad","conv.type"))

#### 4. Determine optimal radius ####

# rescale by mean distance
coords_crqa = coords %>% ungroup() %>%
  dplyr::select(dyad,conv.num,conv.type,euclid0,euclid1,conv.num,ami.selected,embed.selected) %>%
  group_by(dyad,conv.num) %>%
  mutate(rescale.euclid0 = euclid0/mean(euclid0)) %>%
  mutate(rescale.euclid1 = euclid1/mean(euclid1))

# create an empty dataframe to hold the parameter information
radius_selection = data.frame(dyad = numeric(),
                              conv.num = numeric(),
                              chosen.delay = numeric(),
                              chosen.embed = numeric(),
                              chosen.radius = numeric(),
                              rr = numeric())

# identify radius for calculations
radius.list = seq(.04,.26,by=.02)

# cycle through all conversations of all dyads
crqa.data = split(coords_crqa,
                  list(coords$dyad,
                       coords$conv.type))
for (next.conv in crqa.data){

  # make sure we only proceed if we have data for the conversation
  if (dim(next.conv)[1] != 0){

    # reset `target` variables for new radius (above what RR can be)
    from.target = 101
    last.from.target = 102

    # cycle through radii
    for (chosen.radius in radius.list){

      # if we're still improving, keep going
      if (from.target < last.from.target){

        # keep the previous iteration's performance
        last.from.target = from.target

        # print update
        print(paste("Dyad ", unique(next.conv$dyad),
                    ", conversation ",unique(next.conv$conv.num),
                    ": radius ",chosen.radius,sep=""))

        # identify parameters
        chosen.delay = unique(next.conv$ami.selected)
        chosen.embed = unique(next.conv$embed.selected)

        # run CRQA and grab recurrence rate (RR)
        rec_analysis = crqa(next.conv$rescale.euclid0,
                            next.conv$rescale.euclid1,
                            delay = chosen.delay,
                            embed = chosen.embed,
                            r = chosen.radius,
                            normalize = 0,
                            rescale = 0,
                            mindiagline = 2,
                            minvertline = 2,
                            tw = 0,
                            whiteline = FALSE,
                            recpt=FALSE)
        rr = rec_analysis$RR

        # clear it so we don't take up too much memory (optional)
        rm(rec_analysis)

        # identify how far off the RR is from our target (5%)
        from.target = abs(rr - 5)

        # save individual radius calculations
        dyad = unique(next.conv$dyad)
        conv.num = unique(next.conv$conv.num)
        write.table(cbind.data.frame(dyad,
                                     conv.num,
                                     chosen.delay,
                                     chosen.embed,
                                     chosen.radius,
                                     rr,
                                     from.target),
                    paste('./data/crqa_parameters/radius_calculations-mean_scaled-r',chosen.radius,'-',dyad,'_',conv.num,'-DCC.csv', sep=''),
                    sep=',',row.names=FALSE,col.names=TRUE)

        # append to dataframe
        radius_selection = rbind.data.frame(radius_selection,
                                            cbind.data.frame(dyad,
                                                             conv.num,
                                                             chosen.delay,
                                                             chosen.embed,
                                                             chosen.radius,
                                                             rr,
                                                             from.target))
      } else {

        # if we're no longer improving, break
        break

      }}}}

# save the radius explorations to file
write.table(radius_selection,'./data/crqa_parameters/radius_calculations-mean_scaled-DCC.csv', sep=',',row.names=FALSE,col.names=TRUE)

# let us know when it's finished
beepr::beep("fanfare")

# if we've already run it, load it in
radius_selection = read.table('./data/crqa_parameters/radius_calculations-mean_scaled-DCC.csv', sep=',',header=TRUE)

#### 5. Expand radius where necessary ####

# load back in the data
radius_selection = read.table('./data/crqa_parameters/radius_calculations-mean_scaled-DCC.csv', sep=',',header=TRUE)
radius_stats = radius_selection %>% ungroup() %>%
  group_by(dyad,conv.num) %>%
  dplyr::filter(from.target==min(from.target)) %>%
  dplyr::arrange(dyad,conv.num)

# check whether some conversations are further than 1% from our target recurrence rate
recheck_radii = radius_stats %>% ungroup() %>%
  dplyr::filter(from.target > 1) %>%
  dplyr::select(dyad,conv.num)

# link conversation numbers to types
checking_numbers = coords_crqa %>%
  ungroup() %>%
  dplyr::select(dyad,conv.type,conv.num) %>%
  distinct()
recheck_radii = recheck_radii %>%
  dplyr::left_join(x=.,
                   y=checking_numbers,
                   by=c("dyad"="dyad","conv.num"="conv.num")) %>%
  mutate(recheck.conv = paste(dyad,conv.type,sep='.'))

# create an empty dataframe to hold the parameter information
recheck_radius_selection = data.frame(dyad = numeric(),
                                      conv.num = numeric(),
                                      chosen.delay = numeric(),
                                      chosen.embed = numeric(),
                                      chosen.radius = numeric(),
                                      rr = numeric())

# cycle through the conversations
recheck_radii = crqa.data[recheck_radii$recheck.conv]
recheck_radius_list = seq(.28,1.4,by=.02)
for (next.conv in recheck_radii){

  # make sure we only proceed if we have data for the conversation
  if (dim(next.conv)[1] != 0){

    # reset `target` variables for new radius (above what RR can be)
    from.target = 101
    last.from.target = 102

    # cycle through radii
    for (chosen.radius in recheck_radius_list){

      # if we're still improving, keep going
      if (from.target < last.from.target){

        # keep the previous iteration's performance
        last.from.target = from.target

        # print update
        print(paste("Dyad ", unique(next.conv$dyad),
                    ", conversation ",unique(next.conv$conv.num),
                    ": radius ",chosen.radius,sep=""))

        # identify parameters
        chosen.delay = unique(next.conv$ami.selected)
        chosen.embed = unique(next.conv$embed.selected)

        # run CRQA and grab recurrence rate (RR)
        rec_analysis = crqa(next.conv$rescale.euclid0,
                            next.conv$rescale.euclid1,
                            delay = chosen.delay,
                            embed = chosen.embed,
                            r = chosen.radius,
                            normalize = 0,
                            rescale = 0,
                            mindiagline = 2,
                            minvertline = 2,
                            tw = 0,
                            whiteline = FALSE,
                            recpt=FALSE)
        rr = rec_analysis$RR

        # clear it so we don't take up too much memory (optional)
        rm(rec_analysis)

        # identify how far off the RR is from our target (5%)
        from.target = abs(rr - 5)

        # save individual radius calculations
        dyad = unique(next.conv$dyad)
        conv.num = unique(next.conv$conv.num)
        write.table(cbind.data.frame(dyad,
                                     conv.num,
                                     chosen.delay,
                                     chosen.embed,
                                     chosen.radius,
                                     rr,
                                     from.target),
                    paste('./data/crqa_parameters/radius_calculations-mean_scaled-r',chosen.radius,'-',dyad,'_',conv.num,'-DCC.csv', sep=''),
                    sep=',',row.names=FALSE,col.names=TRUE)

        # append to dataframe
        recheck_radius_selection = rbind.data.frame(recheck_radius_selection,
                                                    cbind.data.frame(dyad,
                                                                     conv.num,
                                                                     chosen.delay,
                                                                     chosen.embed,
                                                                     chosen.radius,
                                                                     rr,
                                                                     from.target))
      } else {

        # if we're no longer improving, break
        break

      }}}}

# save the radius explorations to file
write.table(recheck_radius_selection,'./data/crqa_parameters/radius_recheck_calculations-mean_scaled-DCC.csv', sep=',',row.names=FALSE,col.names=TRUE)

# let us know when it's finished
beepr::beep("fanfare")

# if we've already run it, load it in
recheck_radius_selection = read.table('./data/crqa_parameters/radius_recheck_calculations-mean_scaled-DCC.csv', sep=',',header=TRUE)

#### 6. Export chosen radii for all conversations ####

# load in files
radius_files = list.files('./data/crqa_parameters',
                          pattern='radius_calculations-mean_scaled*',
                          full.names = TRUE)

# identify the target radii
radius_stats = rbind.data.frame(rbindlist(lapply(radius_files, fread, sep=","))) %>%
  ungroup() %>%
  group_by(dyad,conv.num) %>%
  dplyr::filter(from.target==min(from.target)) %>%
  dplyr::arrange(dyad,conv.num) %>%
  ungroup() %>%
  distinct()

# rename our rescaled variables here
coords_crqa = coords_crqa %>% ungroup() %>%
  select(dyad,conv.num,rescale.euclid0,rescale.euclid1)

# join the dataframes
coords_crqa = plyr::join(x=coords_crqa,
                         y=radius_stats, by=c("dyad"="dyad","conv.num"="conv.num"))

# save to file
write.table(coords_crqa,'./data/crqa_data_and_parameters-DCC.csv', sep=',',row.names=FALSE,col.names=TRUE)


# DATA CLEANING DAY 2
SEER_Data<- read.csv("scratch/codeathon1.csv", header=TRUE)
library(ggplot2)

# DATA CLEANING

drops <- c("Site.recode.B.ICD.O.3.WHO.2008", "Lymphoma.subtype.recode.WHO.2008", "Laterality", "Histology.recode...Brain.groupings",
           "Summary.stage.2000..1998..", "SEER.summary.stage.1977..1995.2000.", "AJCC.stage.3rd.edition..1988.2003." , "SEER.modified.AJCC.stage.3rd..1988.2003.",
           "RX.Summ..Surg.Prim.Site..1998..", "Site.specific.surgery..1973.1997.varying.detail.by.year.and.site.", "Radiation.to.Brain.or.CNS.Recode..1988.1997.",
           "CS.extension..2004.2015.", "Tumor.marker.1..1990.2003." , "Tumor.marker.2..1990.2003."  , "Tumor.marker.3..1990.2003." ,
           "Type.of.Reporting.Source", "Primary.Site...labeled", "Race.recode..W..B..AI..API."   ,
           "Origin.recode.NHIA..Hispanic..Non.Hisp." )
SEER_Data<- SEER_Data[ , !(names(SEER_Data) %in% drops)]

SEER_Data<-SEER_Data[SEER_Data$Year.of.diagnosis>=1997 & SEER_Data$Year.of.diagnosis<=2016,]

SEER_Data$Survival.months.flag.new<- ifelse(SEER_Data$Survival.months.flag=="Complete dates are available and there are more than 0 days of survival",1,0)

SEER_Data$Survival.months.new<- as.integer(ifelse(SEER_Data$Survival.months.flag.new==0, NA, SEER_Data$Survival.months))

SEER_Data$Radiation.code.new <- ifelse(SEER_Data$Radiation.recode!="None/Unknown", 1,0)

SEER_Data$Site.recode.ICD.O.3.WHO.2008 <- ifelse(SEER_Data$Site.recode.ICD.O.3.WHO.2008 %in% c("NHL - Nodal","NHL - Extranodal" ), "NHL", SEER_Data$Site.recode.ICD.O.3.WHO.2008)
SEER_Data$Site.recode.ICD.O.3.WHO.2008 <- ifelse(SEER_Data$Site.recode.ICD.O.3.WHO.2008 %in% c("Rectum", "Sigmoid Colon", "Cecum", "Rectosigmoid Junction", "Ascending Colon", "Transverse Colon", "Descending Colon", "Large Intestine, NOS",
                                                                                "Hepatic Flexure", "Splenic Flexure"), "Colorectal", SEER_Data$Site.recode.ICD.O.3.WHO.2008)

SEER_Data<- SEER_Data[ , !(names(SEER_Data) %in% c("Survival.months.flag", "Survival.months","Radiation.recode"))]

names(SEER_Data)[names(SEER_Data) == 'Survival.months.flag.new'] <- 'Survival.months.flag'
names(SEER_Data)[names(SEER_Data) == 'Survival.months.new'] <- 'Survival.months'
names(SEER_Data)[names(SEER_Data) == 'Radiation.code.new'] <- 'Radiation.recode'

write.csv(SEER_Data, "scratch/codeathon_RECODE.csv")

### UPDATES ###

## ("scratch/codeathon_RECODE_Day3_v02.csv") --> v01 is the same as v02 but I had to re-run it as I don't have permision to re-write the v01.
SEER_Cleaned <- read_csv("scratch/codeathon_RECODE_Day3_v02.csv")
SEER_Cleaned_updated <- SEER_Cleaned
#SEER_Cleaned_updated<- SEER_Cleaned[!SEER_Cleaned$X....High.school.education.ACS.2013.2017=="Blank(s)",]
#SEER_Cleaned_updated<- SEER_Cleaned_updated[SEER_Cleaned_updated$Age.recode.with..1.year.olds %in% c("35-39 years", "25-29 years", "30-34 years", "20-24 years", "15-19 years"),]
SEER_Cleaned_updated$X..Unemployed.ACS.2013.2017 <- as.double(SEER_Cleaned_updated$X..Unemployed.ACS.2013.2017)/100
SEER_Cleaned_updated$X....High.school.education.ACS.2013.2017<-as.double(SEER_Cleaned$X....High.school.education.ACS.2013.2017)/100

## NEW VARIABLES
SEER_Cleaned_updated<- SEER_Cleaned_updated %>% mutate(HighSchoolEdCat = cut(X....High.school.education.ACS.2013.2017, breaks = c(0,10,20,30, 100)),
                                                       Unemployed_cat = cut(X..Unemployed.ACS.2013.2017, breaks = c(0,5,10,15, 100)),
                                                       median_income_household_group = ntile(Median.household.income..in.tens..ACS.2013.2017 , 4))

# AGE GROUP COUNTS
#SEER_Cleaned_updated %>% group_by(Decade,Age.recode.with..1.year.olds) %>% summarize(count=n()) %>% mutate(freq = count/sum(count))
write.csv(SEER_Cleaned_updated, "scratch/codeathon_RECODE_v03.csv")


#################################################
#################################################
# Shapefiles
#################################################
#################################################

# We need:
# ukcp18-uk-land-country-hires
# contains the borders of the UK, and the internal borders between Wales, England and Scotland

uk_borders <- st_read("/nfs/cfs/home4/rejb/rejbypa/UKCP18_R/ukcp-spatial-files/spatial-files/ukcp18-uk-land-country-hires/ukcp18-uk-land-country-hires.shp")
as_Spatial(uk_borders)
plot(uk_borders)


add_event_days <- function(df)
{
	colnames(df)[1] <- "ds"
	df<- cbind(df, matrix(0, nrow=nrow(df), ncol=1))
	colnames(df)[ncol(df)]<-"lower_window"
	df<- cbind(df, matrix(0, nrow=nrow(df), ncol=1))
	colnames(df)[ncol(df)]<-"upper_window"

	for ( i in 1:nrow(holidays)){
	#i = 1
		clidx = grep(as.POSIXct(holidays$ds[i]), as.POSIXct(df$ds))
	#as.POSIXct(holidays$ds[i])
	#as.POSIXct(df$ds[clidx])

		if ( length(clidx) == 0 )
		{
			print(as.POSIXct(holidays$ds[i]))
			next
		}

		u = holidays$lower_window[i]
		df$lower_window[clidx] = 1
		if ( u < 0 )
		{
			for ( id in (clidx-u):clidx){
				if (clidx-u >= 1)df$lower_window[id] = 1
			}
		}

		u = holidays$upper_window[i]
		df$upper_window[clidx] = 1
		if ( u > 0 )
		{
			for ( id in clidx:(clidx+u)){
				if (clidx+u <=nrow(df))df$upper_window[id] = 1
			}
		}
	}
	return(df)
}


# Master Thesis Project - Extreme Value Theory
# Introductory Task
# Killian Martin--Horgassan
# 19-02-2015

# Clear the environment
rm(list=ls())

# Close all already open graphic windows
graphics.off()

# Elementary test
#x <- 5
#print(x)

# sourcing works

# Loading function 'NormMax'
source("./NormMax2.r")
source("./InputIntroductoryTask2.r")

# Input from keyboard
DIST <- InputIntroductoryTask2()
DIST_1 <- DIST[[1]]
DIST_2 <- DIST[[2]]

# Calling function NormMax
listMax <- NormMax2(length(DIST_1),DIST_1,DIST_2)


 DGERFS Example Program Results

 Solution(s)
             1          2
 1      1.0000     3.0000
 2     -1.0000     2.0000
 3      3.0000     4.0000
 4     -5.0000     1.0000

 Backward errors (machine-dependent)
       9.4E-17    3.7E-17
 Estimated forward error bounds (machine-dependent)
       2.4E-14    3.3E-14


#  James Rekow

intraCohortInteraction_optimizedBaseCase = function(chrt, M, N, intIx, lambda = 0, threshold = 10 ^ (-6),
                                                    maxSteps = 10 ^ 4, tStep = 10 ^ (-2), intTime = 1,
                                                    interSmplMult= 0.01){

  #  ARGS:  chrt - input cohort in the form list(list(abd, gr, imat)), where abundances have
  #                already been integrated
  #         lambda - rate of exponential random variable describing time between interactions
  #         intTime - time over which interactions are to be simulated
  #         interSmplMult - the fraction of a sample's abundances that get transmitted
  #                         upon contact with another sample (transmission is bi-directional
  #                         and does not deplete the abundance of the dog from which it is
  #                         transmitted)
  #         intIx - the indices of the interacting samples in the cohort. It is assumed that any of these
  #                 samples can interact with any other one (e.g. form a completely connected subgraph). The
  #                 samples that are not interacting do not interact at all.
  #
  #  RETURNS:  abdList - list of interacted and re-integrated abundances from chrt
  #            intIx - numerical vector containing the indices of all samples within the cohort
  #                    that are connected (capable of interacting) with at least one other sample.
  #                    Only returned if retIntIx == TRUE, in which case the output is of the form
  #                    list(abdList, intIx)
  #
  #  NOTE: exactly one interaction occurs during each iteration of the loop. If cumTime is less
  #        than intTime but the next wait time makes cumTime greater than intTime then the interaction
  #        corresponding to that wait time does not occur.

  source("eulerIntegrate.r")

  #  precompute coefficient for use in interaction step
  tempSmplMult = 1 - interSmplMult

  #  track cumulative time and terminate interaction step once cumulative time exceeds intTime
  cumTime = rexp(n = 1, rate = lambda)

  #  interact samples until the cumulative interaction time exceeds the amount of time for the interaction
  #  step
  while(cumTime < intTime){

    #  select indices of the two samples which will interact during this interaction step
    iPair = sample(intIx, 2)

    #  select the abundance vectors of the interacting samples
    abd1 = chrt[[iPair[1]]][[1]]
    abd2 = chrt[[iPair[2]]][[1]]

    #  compute weighted sum
    tempSum = interSmplMult * {abd1 + abd2}

    #  update sample abundances in the cohort (the net effect is that interSmplMult * abd1 is added to abd2,
    #  and similarly interSmplMult * abd2 is added to abd1)
    chrt[[iPair[1]]][[1]] = tempSmplMult * abd1 + tempSum
    chrt[[iPair[2]]][[1]] = tempSmplMult * abd2 + tempSum

    #  re-integrate samples that have interacted
    for(ii in iPair){
      chrt[[ii]][[1]] = eulerIntegrate(chrt[[ii]], threshold = threshold, maxSteps = maxSteps,
                                       tStep = tStep)
    } #  end for

    #  compute the cumulative time after waiting for another interaction
    cumTime = cumTime + rexp(n = 1, rate = lambda)

  } #  end while loop

  #  extract the list of abundance vectors from the cohort
  abdList = lapply(chrt, "[[", 1)

  return(abdList)

} #  end intraCohortInteraction_optimizedBaseCase function


predict.EFSA<-function(model,dataset){
	distance_matrix = compute_best_matching_distance(test_data,model$shapelets,model$shapelet_length)
	predictions=predict(model$model,distance_matrix)
	return(predictions)
}


#TODO BC add functionality for pdf&kml outputs

map.set.information = function(p, outdir, variables, mapyears, interpolate.method='tps', theta=p$pres*25, ptheta=theta/2.3,
                               idp=2, log.variable=TRUE, add.zeros=TRUE, minN=10, probs=c(0.025, 0.975) ) {

    set = snowcrab.db( DS="set.biologicals")
    if(missing(variables)){
      variables = bio.snowcrab::snowcrab.variablelist("all.data")
      variables = intersect( variables, names(set) )
    }

    # define compact list of variable year combinations for parallel processing
    if (missing(mapyears)) mapyears = sort( unique(set$yr) )
    if (exists( "libs", p)) RLibrary( p$libs )

    for ( v in variables ) {
      for ( y in mapyears ) {
         predlocs = bathymetry.db(p=p, DS="baseline")
          ratio=FALSE
          outfn = paste( v,y, sep=".")
          outloc = file.path( outdir,v)
          ref=y

          if (grepl('ratio', v)) ratio=TRUE

          set_xyz = set[ which(set$yr==y), c("plon","plat",v) ]
          names( set_xyz) = c("plon", "plat", "z")
          set_xyz = na.omit(subset(set_xyz,!duplicated(paste(plon,plat))))
          if(nrow(set_xyz)<minN)next() #skip to next variable if not enough data

          offset = empirical.ranges( db="snowcrab", v, remove.zeros=T , probs=0)  # offset fot log transformation
          er = empirical.ranges( db="snowcrab", v, remove.zeros=T , probs=probs)  # range of all years
          if(ratio)er=c(0,1)
          ler = er
          withdata=which(set_xyz$z > 0)
          if (length(withdata) < 3) print(paste("skipped",v, y, "<3 data points to create map", sep="."))
          if (length(withdata) < 3) next()
          S = set_xyz[ withdata, c("plon", "plat") ]

          distances =  rdist( predlocs[,c("plon", "plat")], S)
          distances[ which(distances < ptheta) ] = NA
          ips = which( !is.finite( rowSums(distances) ) )
          plocs=predlocs[ips,]
          if(log.variable){
            set_xyz$z = log(set_xyz$z+offset)
            ler=log(er+offset)
            #if(offset<1)if(shift) xyz$z = xyz$z + abs(log(offset))
          }

          datarange = seq( ler[1], ler[2], length.out=50)
  #
          #if(logit.variable){
          #  sr=set[,v]
          #  sr=sr[sr>0&sr<1&!is.na(sr)]
          #  lh=range(sr)
          #  set_xyz$z[set_xyz$z==0] = lh[1]
          #  set_xyz$z[set_xyz$z==1] = lh[2]
          #  set_xyz$z = logit(set_xyz$z)
          #  #if(offset<1)if(shift) xyz$z = xyz$z + abs(log(offset))
          #  ler=logit(quantile(sr,probs))
          #  datarange = seq( ler[1], ler[2], length.out=50)
          #}
          xyzi = na.omit(set_xyz)

          if(nrow(xyzi)<minN||is.na(er[1]))next() #skip to next variable if not enough data

          #!# because 0 in log space is actually 1 in real space, the next line adds the log of a small number (offset)
          #!# surrounding the data to mimic the effect of 0 beyond the range of the data
          if(add.zeros)  xyzi =na.omit( zeroInflate(set_xyz,corners=p$corners,type=2,type.scaler=0.5,eff=log(offset),blank.dist=20) )

          if(interpolate.method=='tps'){

            u= fastTps(x=xyzi[,c("plon","plat")] , Y=xyzi[,'z'], theta=theta )
            res = cbind( plocs[,1:2], predict(u, xnew=plocs[,1:2]))
          }
          if(interpolate.method=='idw'){
            require(gstat)
            u = gstat(id = "z", formula = z ~ 1, locations = ~ plon + plat, data = xyzi, set = list(idp = idp))
            res = predict(u, plocs[,1:2])[,1:3]
          }
          #print(summary(set_xyz))
          #print(summary(res))

          xyz = res
          names( xyz) = c("plon", "plat", "z")
          #if(shift)xyz$z = xyz$z - abs(log(offset))

          cols = colorRampPalette(c("darkblue","cyan","green", "yellow", "orange","darkred", "black"), space = "Lab")

          xyz$z[xyz$z>ler[2]] = ler[2]
          if(ratio)xyz$z[xyz$z<ler[1]] = ler[1]

          ckey=NULL
          if(log.variable){
            # create labels for legend on the real scale
            labs=as.vector(c(1,2,5)%o%10^(-4:5))
            labs=labs[which(labs>er[1]&labs<er[2])]
            ckey=list(labels=list(at=log(labs+offset),labels=labs,cex=2))
          }

          dir.create (outloc, showWarnings=FALSE, recursive =TRUE)
          annot=ref
          filename=file.path(outloc, paste(outfn, "png", sep="."))
          print(filename)
          png( filename=filename, width=3072, height=2304, pointsize=40, res=300 )
          lp = aegis_map( xyz, xyz.coords="planar", depthcontours=TRUE, pts=set_xyz[,c("plon","plat")],
            annot=annot, annot.cex=4, at=datarange , col.regions=cols(length(datarange)+1),
            colpts=F, corners=p$corners, display=F, colorkey=ckey, plotlines="cfa.regions" )
          print(lp)
          dev.off()

      }
    }

    return("Done")
  }


#!/usr/bin/Rscript

source("/itsshared/phd/common.r");

## Author: David Eccles (gringer), 2009 <programming@gringer.org>

## poscounts.r -- determine clinical parameters for structure file outputs
## TP: True positive (count of "positive" results that are clinically positive)
## FN: False negative (count of "negative" results that are clinically positive)
## TN: True negative (count of "negative" results that are clinically negative)
## FP: False positive (count of "positive" results that are clinically negative)

usage <- function(){
  cat("usage: ./poscounts.r <structure \"q\" file> -s <split point> [options]\n");
  cat("\nOther Options:\n");
  cat("  -r <value>       : cutoff resolution (default 0.1)\n");
  cat("  -min <value>     : minimum cutoff value (default 0)\n");
  cat("  -max <value>     : maximum cutoff value (default 1)\n");
  cat("  -flip            : invert positive/negative labels\n");
 ## Should probably have 'flop' to invert case/control labels as well
  cat("  -label <lA> <lO> : case/control labels\n");
  cat("\n");
  }

infile.name <- FALSE;
splitPoint <- FALSE; # location at which positives change to negatives
minCO <- 0; # minimum cutoff value
maxCO <- 1; # maximum cutoff value
COResolution <- 0.1; # cutoff resolution
flip <- FALSE; # whether to flip positive/negative labels
ccLabels <- NULL; # case/control labels

argLoc <- 1;
while(!is.na(commandArgs(TRUE)[argLoc])){
  if(file.exists(commandArgs(TRUE)[argLoc])){ # file existence check
    if(infile.name == FALSE){
      infile.name <- commandArgs(TRUE)[argLoc];
    } else{
      cat("Error: More than one input file specified\n");
      usage();
      quit(save = "no", status=1);
    }
  }
  if(commandArgs(TRUE)[argLoc] == "-flip"){
      flip <- TRUE;
  }
  if(commandArgs(TRUE)[argLoc] == "-label"){
      ccLabels <- c(commandArgs(TRUE)[argLoc+1],commandArgs(TRUE)[argLoc+2]);
      argLoc <- argLoc+2;
  }
  if(commandArgs(TRUE)[argLoc] == "-s"){
      splitPoint <- as.numeric(commandArgs(TRUE)[argLoc+1]);
      argLoc <- argLoc+1;
  }
  if(commandArgs(TRUE)[argLoc] == "-r"){
      COResolution <- as.numeric(commandArgs(TRUE)[argLoc+1]);
      argLoc <- argLoc+1;
  }
  if(commandArgs(TRUE)[argLoc] == "-min"){
      minCO <- as.numeric(commandArgs(TRUE)[argLoc+1]);
      argLoc <- argLoc+1;
  }
  if(commandArgs(TRUE)[argLoc] == "-max"){
      maxCO <- as.numeric(commandArgs(TRUE)[argLoc+1]);
      argLoc <- argLoc+1;
  }
  if(length(grep("-h",commandArgs(TRUE)[argLoc])) > 0){
    usage();
    quit(save = "no", status = 0);
  }
  argLoc <- argLoc+1;
}

if(splitPoint == FALSE){
  cat("Error: No split point defined (use -s)\n");
  usage();
  quit(save = "no", status=1);
}

a <- read.table(infile.name, row.names = 1);

getValues <- function(cutoff){
  if(length(cutoff)>1){
    return(data.frame(t(sapply(unique(cutoff),getValues))));
  }
  TP <- length(which(a$V2[1:splitPoint] >= cutoff));
  FN <- length(which(a$V2[1:splitPoint] < cutoff));
  FP <- length(which(a$V2[-(1:splitPoint)] >= cutoff));
  TN <- length(which(a$V2[-(1:splitPoint)] < cutoff));
  if(!flip){
    return (data.frame(cutoff = cutoff, TP = TP, TN = TN, FP = FP, FN = FN));
  } else {
    return (data.frame(cutoff = cutoff, TP = FN, TN = FP, FP = TN, FN = TP));
  }
}

cat("\n");

cat("TP: Cases >= cutoff value\n");
cat("FP: Controls >= cutoff value\n");
cat("TN: Cases < cutoff value\n");
cat("FN: Controls < cutoff value\n");

cat("\n");

getValues(seq(minCO,maxCO,COResolution));

pdf("output_QHist.pdf", paper = "a4r", width = 11, height = 8);

if(length(ccLabels) == 0){
  ccLabels <- c("CASE","CONTROL");
}

hist(a$V2[1:splitPoint], breaks = 20, col = "red", xlab = "Q value",
     main = paste("Histogram of Q values for ",ccLabels[1],"",sep=""));
hist(a$V2[-(1:splitPoint)], breaks = 20, col = "red", xlab = "Q value",
     main = paste("Histogram of Q values for ",ccLabels[2],"",sep=""));

dummy <- dev.off();


#' Predict probability from DMBC model
#'
#' @description
#' Based on a set of optimized features from training set, this function predicts the posterior probability for two class labels.
#'
#' @param data Validation dataset with rows are samples, columns are features. The first column should be the sample ID, second column group variable (Disease type, the label you want to classify on).
#' @param testset Lable unknown testset without sample IDs.
#' @param auc_out Output object of Cal_AUC() from a validation set.
#' @param col_start An index indicating at which column is the beginning of bacteria (features) data in the validation set. The default is the 3rd column.
#' @param type_col An index indicating at which column is group/type variable in the validation set. The default is the 2nd column.
#' @param Prior1 Prevalence of label1 according to literature or experience. Default is 0.5.
#' @param Prior2 Prevalence of label2 according to literature or experience. Default is 0.5.
#'
#' @return
#'
#' @examples
#' #load the DMBC library
#' library(DMBC)
#'
#' #load training dataset
#' data(training)
#'
#' #load test dataset
#' data(test)
#'
#'## calculate AUC based on training set using 10-fold cv ##
#' auc_out <- Cal_AUC(tfcv(training))
#'
#'## calculate AUC based on training set using leave-one-out cv ##
#' auc_out <- Cal_AUC(loocv(training))
#'
#' #predict unknown test set using training set and auc results.
#' dmbc_predict(data=training,testset=test,auc_out=auc_out)
#' @export

dmbc_predict <- function(data=data,testset = testset,auc_out=auc_out,col_start =3,type_col=2,Prior1=0.5,Prior2=1-Prior1){
  namelist <- auc_out$Features[which.max(auc_out$AUC_Area)]
  NameList <- as.vector(unlist(strsplit(as.character(namelist),";")))

  Disease <- levels(data[,type_col])

  NewDF <- as.data.frame(data[,colnames(data) %in% NameList])
  colnames(NewDF) <- colnames(data)[colnames(data) %in% NameList]

  NewDF2 <- data[,!colnames(data)%in% NameList]

  col_end2 = dim(NewDF2)[2]
  NewDF2$Others = rowSums(NewDF2[, col_start:col_end2])
  NewDFTotal = data.frame(NewDF2[, 1:(col_start-1)],NewDF, NewDF2$Others)

  rep2_Type1 = NewDFTotal[NewDFTotal[,type_col] == Disease[1],]
  rep2_Type2 = NewDFTotal[NewDFTotal[,type_col] == Disease[2],]

  for (taxa in NameList){
    if(nrow(rep2_Type1) == sum(rep2_Type1[,taxa]<1)) {
      rep2_Type1[,taxa][1] =1
    }
    if(nrow(rep2_Type2) == sum(rep2_Type2[,taxa]<1)) {
      rep2_Type2[,taxa][1] =1
    }
  }

  ####fit3 <- dirmult(rep2_Type1[,-(1:(col_start-1))],epsilon=10^(-4),trace=FALSE)
  ####fit4 <- dirmult(rep2_Type2[,-(1:(col_start-1))],epsilon=10^(-4),trace=FALSE)
  ####alpha_Type1 = fit3$gamma
  ####alpha_Type2 = fit4$gamma
  tol=0.0001
  max.iter=1000

  Xc = as.matrix(rep(1, dim(rep2_Type1)[1]))
  Xa = Xc
  Xb = Xc
  c0 = as.matrix(rep(1, dim(rep2_Type1)[2]-1))
  alpha0 = c0
  beta0 = c0
  p_Type1 <- ZIGDM_prob(rep2_Type1[,-(1:(col_start-1))], Xc, Xa, Xb, c0, alpha0, beta0, tol=0.0001, max.iter=1000)

  Xc = as.matrix(rep(1, dim(rep2_Type1)[1]))
  Xa = Xc
  Xb = Xc
  c0 = as.matrix(rep(1, dim(rep2_Type1)[2]-1))
  alpha0 = c0
  beta0 = c0
  p_Type2 <- ZIGDM_prob(rep2_Type2[,-(1:(col_start-1))], Xc, Xa, Xb, c0, alpha0, beta0, tol=0.0001, max.iter=1000)
  ###### predict test set #####

  for (t in NameList){
    if (! (t %in% colnames(testset)) ){
      testset <- data.frame(testset,rep(0,nrow(testset)))
      colnames(testset)[ncol(testset)] <- t
    }
  }

  NewTestSignature = testset[, colnames(testset)%in% NameList]
  NewTestNonSignature = testset[, !colnames(testset)%in% NameList]
  NewTestNonSignature$Others = rowSums(NewTestNonSignature)
  NewTestTotal = data.frame(NewTestSignature, NewTestNonSignature$Others)

  test_res <- list()
  for (r in 1:nrow(testset)){
    ##### Calculate log of Dirichlet multinomial probability mass function P(x|Type1)
    #pdfln_Type1 <- ddirmn(NewTestTotal[r,], t(as.matrix(alpha_Type1)))
    #lh_Type1=exp(pdfln_Type1)
    #lhP_Type1 = lh_Type1*Prior1

    probability_Type1 = apply(NewTestTotal[r,],1,dmultinom, prob = p_Type1)
    lhP_Type1 = probability_Type1*Prior1

    ##### Calculate log of Dirichlet multinomial probability mass function P(x|Type2)
    #pdfln_Type2 <- ddirmn(NewTestTotal[r,], t(as.matrix(alpha_Type2)))
    #lh_Type2=exp(pdfln_Type2)
    #lhP_Type2 = lh_Type2*Prior2
    probability_Type2 = apply(NewTestTotal[r,],1,dmultinom, prob = p_Type2)
    lhP_Type12 = probability_Type2*Prior2

    #Pos_Type1 = lh_Type1/(lh_Type1+lh_Type2)
    #Pos_Type2 = lh_Type2/(lh_Type1+lh_Type2)

    PosP_Type1 = lhP_Type1/(lhP_Type1+lhP_Type2)
    PosP_Type2 = lhP_Type2/(lhP_Type1+lhP_Type2)

    test_res[[r]] <- as.matrix(t(c(rownames(testset)[r],Disease[1], PosP_Type1, Disease[2], PosP_Type2,paste(NameList,collapse=";"))))

  }

  out <- data.frame(t(sapply(test_res,function(x) x)))
  colnames(out) <- c("test_idx","Group1","Group1_prb","Group2","Group2_prb","Features")

  return(out)
}


# Import R Packages and Modules
library("ggplot2")
library("dplyr")

# Import our datasets
arrests <- read.csv('data/arrests.csv', header = TRUE, stringsAsFactors = TRUE)

# Exploring data
head(arrests) # Displays the first 6 rows of the dataset
tail(arrests) # Display the last 6 rows of the datasets
edit(arrests) # Open data editor to edit the datasets
View(arrests) # View the datasets
summary(arrests) # Provides basic descriptive statistics and frequencies.

# Arrest by Gender
arrests$Sex <- as.character(arrests$Sex)
arrests$Sex[arrests$Sex == "M"] <- "Male"
arrests$Sex[arrests$Sex == "F"] <- "Female"
# Plot Bar Chart
ggplot(arrests, aes(Sex, fill=Sex) ) + geom_bar() + ggtitle("Graph showing arrests based on Gender.") + xlab("Gender") + ylab("Total Cases") + labs(fill = "Gender")
# Plot Pie Chart
ggplot(arrests, aes(x=factor(1), fill=factor(Sex)) ) + geom_bar(width = 1) + ggtitle("Graph showing arrests based on Gender.") + labs(fill = "Gender") + coord_polar(theta = "y") # + theme_void()
arrests$Sex <- as.factor(arrests$Sex)

# Arrest by Race
ggplot(arrests, aes(Race, fill=Race) ) + geom_bar() + ggtitle("Graph showing arrests based on Race.") + xlab("Race") + ylab("Total Cases") + labs(fill = "Race")

# Arrest by Districts
arrests$District <- as.character(arrests$District)
arrests$District[arrests$District == ""] <- NA
ggplot(arrests, aes(District, fill=District) ) + geom_bar() + ggtitle("Graph showing arrests based on District.") + xlab("District") + ylab("Total Cases") + labs(fill = "District")
arrests$District <- as.factor(arrests$District)

# Arrest by Age
arrests$Age_cat <- cut(arrests$Age, breaks = c(-Inf, 17, 24, 34, 44, 54, 64, Inf), labels = c("Below 18", "18 - 24", "25 - 34", "35 - 45", "45 - 54", "55 - 64", "65 Above"), right = FALSE)
ggplot(arrests, aes(Age_cat, fill=Age_cat) ) + geom_bar() + ggtitle("Graph showing arrests based on Age.") + xlab("Age Range") + ylab("Total Cases") + labs(fill = "Age Range:")

# Arrest by Year
# mutate(arrests, year = format(as.Date(ArrestDate, "%d/%m/%Y"), "%Y"))
ggplot(arrests, aes(factor(format(as.Date(ArrestDate, "%d/%m/%Y"), "%Y")), fill= factor(format(as.Date(ArrestDate, "%d/%m/%Y"), "%Y"))) ) + geom_bar() + ggtitle("Graph showing arrests based on year of arrest.") + xlab("Year of arrest") + ylab("Total Cases") + labs(fill = "Year")

# Determine the correlation between Age and the year of arrest
cor.test(arrests$Age, as.numeric( factor(format(as.Date(arrests$ArrestDate, "%d/%m/%Y"), "%Y"))))

# Arrest by hour of the day
arrests$ArrestTime_Rnd <- round(as.double(gsub(":",".", arrests$ArrestTime)))
ggplot(arrests, aes(ArrestTime_Rnd, fill= as.character(ArrestTime_Rnd)) ) + geom_bar() + ggtitle("Graph showing arrests based on hour of the day.") + xlab("Hour of arrest") + ylab("Total Cases") + labs(fill = "Hour")

View(arrests)


data(iris)

summary(iris)

plot(iris)


./tests.verify: test performed on 2004.08.17

#### Test: ./tests.verify running tmp.sh
Content-type: text/html

Hello, World! The sine of 3.14 equals 0.00159265291649
should be 0.00159265291649
CPU time of tmp.sh: 0.1 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running tmp.sh
Content-type: text/html

<FORM ACTION="hw2.py.cgi" METHOD="POST">
Hello, World! The sine of
<INPUT TYPE="text" NAME="r" SIZE="10" VALUE="">
<INPUT TYPE="submit" VALUE="equals" NAME="equalsbutton">
</FORM>

Content-type: text/html

<FORM ACTION="hw2.py.cgi" METHOD="POST">
Hello, World! The sine of
<INPUT TYPE="text" NAME="r" SIZE="10" VALUE="3.14">
<INPUT TYPE="submit" VALUE="equals" NAME="equalsbutton"> 0.00159265291649
</FORM>

should be 0.00159265291649
CPU time of tmp.sh: 0.2 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running tmp.sh
Content-type: text/html

<TITLE>Oscillator code interface</TITLE>

<FORM ACTION="simviz1.py.cgi" METHOD="POST">

        A
        <INPUT TYPE="text" NAME="A" SIZE=10 VALUE="5.0">

        c
        <INPUT TYPE="text" NAME="c" SIZE=10 VALUE="5.0">

        b
        <INPUT TYPE="text" NAME="b" SIZE=10 VALUE="0.7">

        func
        <INPUT TYPE="text" NAME="func" SIZE=10 VALUE="y">

        m
        <INPUT TYPE="text" NAME="m" SIZE=10 VALUE="1.0">

        w
        <INPUT TYPE="text" NAME="w" SIZE=10 VALUE="6.28318530718">

        tstop
        <INPUT TYPE="text" NAME="tstop" SIZE=10 VALUE="30.0">

        y0
        <INPUT TYPE="text" NAME="y0" SIZE=10 VALUE="0.2">

        dt
        <INPUT TYPE="text" NAME="dt" SIZE=10 VALUE="0.05">

<INPUT TYPE="submit" VALUE="simulate and visualize" NAME="sim">
</FORM>

The oscillator program was not found so it is impossible to perform simulations

Content-type: text/html

<TITLE>Oscillator code interface</TITLE>

<FORM ACTION="simviz1.py.cgi" METHOD="POST">

        A
        <INPUT TYPE="text" NAME="A" SIZE=10 VALUE="5.0">

        c
        <INPUT TYPE="text" NAME="c" SIZE=10 VALUE="5.0">

        b
        <INPUT TYPE="text" NAME="b" SIZE=10 VALUE="0.7">

        func
        <INPUT TYPE="text" NAME="func" SIZE=10 VALUE="siny">

        m
        <INPUT TYPE="text" NAME="m" SIZE=10 VALUE="10">

        w
        <INPUT TYPE="text" NAME="w" SIZE=10 VALUE="6.28318530718">

        tstop
        <INPUT TYPE="text" NAME="tstop" SIZE=10 VALUE="30.0">

        y0
        <INPUT TYPE="text" NAME="y0" SIZE=10 VALUE="0.2">

        dt
        <INPUT TYPE="text" NAME="dt" SIZE=10 VALUE="0.05">

<INPUT TYPE="submit" VALUE="simulate and visualize" NAME="sim">
</FORM>

The oscillator program was not found so it is impossible to perform simulations

CPU time of tmp.sh: 0.3 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running tmp.sh
Content-type: text/html

<TITLE>Oscillator code interface</TITLE>

<FORM ACTION="wrapper.sh.cgi?s=simviz1w.py.cgi" METHOD="POST">

        A
        <INPUT TYPE="text" NAME="A" SIZE=10 VALUE="5.0">

        c
        <INPUT TYPE="text" NAME="c" SIZE=10 VALUE="5.0">

        b
        <INPUT TYPE="text" NAME="b" SIZE=10 VALUE="0.7">

        func
        <INPUT TYPE="text" NAME="func" SIZE=10 VALUE="y">

        m
        <INPUT TYPE="text" NAME="m" SIZE=10 VALUE="1.0">

        w
        <INPUT TYPE="text" NAME="w" SIZE=10 VALUE="6.28318530718">

        tstop
        <INPUT TYPE="text" NAME="tstop" SIZE=10 VALUE="30.0">

        y0
        <INPUT TYPE="text" NAME="y0" SIZE=10 VALUE="0.2">

        dt
        <INPUT TYPE="text" NAME="dt" SIZE=10 VALUE="0.05">

<INPUT TYPE="submit" VALUE="simulate and visualize" NAME="sim">
</FORM>

Content-type: text/html

<TITLE>Oscillator code interface</TITLE>

<FORM ACTION="wrapper.sh.cgi?s=simviz1w.py.cgi" METHOD="POST">

        A
        <INPUT TYPE="text" NAME="A" SIZE=10 VALUE="5.0">

        c
        <INPUT TYPE="text" NAME="c" SIZE=10 VALUE="5.0">

        b
        <INPUT TYPE="text" NAME="b" SIZE=10 VALUE="0.7">

        func
        <INPUT TYPE="text" NAME="func" SIZE=10 VALUE="siny">

        m
        <INPUT TYPE="text" NAME="m" SIZE=10 VALUE="10">

        w
        <INPUT TYPE="text" NAME="w" SIZE=10 VALUE="6.28318530718">

        tstop
        <INPUT TYPE="text" NAME="tstop" SIZE=10 VALUE="30.0">

        y0
        <INPUT TYPE="text" NAME="y0" SIZE=10 VALUE="0.2">

        dt
        <INPUT TYPE="text" NAME="dt" SIZE=10 VALUE="0.05">

<INPUT TYPE="submit" VALUE="simulate and visualize" NAME="sim">
</FORM>

CPU time of tmp.sh: 0.6 seconds on hplx30 i686, Linux


library(data.table)
library(rstan)
rstan_options(auto_write = TRUE)
options(mc.cores = parallel::detectCores())

type <- Sys.getenv('RUNLENGTH')
if (type == '') type <- 'quick'

nchains <- 3

## * Data
model_data <- new.env()
load('../data.rdata', envir = model_data)

## Different BETA0 between JAGS and Stan
assign('BETA0', get('BETA0', model_data)^-0.5, envir = model_data)

## * Run model
fit <- stan(file       = 'model.stan',
           model_name = "SRAmodel",
           pars       = c('apf_t', 'q_t', 'q_o', 'q0', 'q_f0', 'q_g0', 'q_gf0',
                          'p_identified', 'p_live_cap', 'p_observable', 'p_survive_cap',
                          'live_captures_o', 'dead_captures_o', 'live_unident_o', 'dead_unident_o',
                          'incidents_t', 'ntot'),
           include    = TRUE, ## TRUE to only store parameters in `pars`
           data       = model_data,
           iter       = 500,
           control    = list(max_treedepth = 10),
           chains     = nchains,
           diagnostic_file='diag.txt',
           verbose    = F,
           seed       = 3859285)

codasamples <- As.mcmc.list(fit)
mcmc <- data.table(do.call('rbind', codasamples))

## * Summarise samples
mcsumm <- rbindlist(lapply(names(mcmc), function(x) data.table(var = x,
                                                       mean = mean(mcmc[[x]]),
                                                       lcl  = quantile(mcmc[[x]], 0.025, names=F),
                                                       ucl  = quantile(mcmc[[x]], 0.975, names=F),
                                                       n    = length(mcmc[[x]]))))
mcsumm[, vartype := sub('\\[.*\\]', '', var)]
mcsumm[grep('.*\\[([0-9]+)\\].*', var), ind := as.numeric(sub('.*\\[([0-9]+)\\].*', '\\1', var))]

save(codasamples, mcsumm, fit,
     file = 'model-results.rdata')