############################################################################################
#
# DESCRIPTION
#    Functions for determination of R-indicators and coefficients of variation.
#    A manual of the functions is found in
#
#    de Heij, V., Schouten, B., and Shlomo, N. (2015), RISQ manual 2.1, Tools in
#        SAS and R for the computation of R-indicators, partial R-indicators
#        and partial coefficients of variation, available at www.risq-project.eu
#
# HISTORY
#    2010/05/10    1.0    V. de Heij      ---
#    2011/02/16    1.1    V. de Heij      Option withBiasAndVar added.
#    2013/07/25    2.0    V. de Heij      Standard error approximations for partial R-indicators,
# 										  coefficient of variation and increased flexibility in models
#    2014/12/15    2.1    B. Schouten     Inclusion of partial coefficients of variation
#
#
############################################################################################

getRIndicator <-
    function(formula,
             sampleData,
             sampleWeights  = rep(1, nrow(sampleData)),
             sampleStrata   = NULL,
             family         = c('binomial', 'gaussian'),
             withPartials   = TRUE,
			 withPartialCV  = TRUE,
             otherVariables = character())
{ #++
    # Determines the R-indicators and the partial R-indicators for a sample.
    #
    # ARGUMENTS
    #   formula        : the respons model which will be used to determine the
    #                    R-indicators; the left hand side of the formula states
    #                    the respons variabele, the right hand side states the
    #                    lineair model of auxiliary variabeles which will be
    #                    used to describe the respons;
    #
    #   sampleData     : a data frame containing the sample data;
    #
    #   sampleWeights  : (optional) a vector with the inclusion weights of the
    #                    sampling units;
    #
    #   sampleStrata   : (optional) a vector with the strata membership of the
    #                    sampling units;
    #
    #   family         : (optional) a string either 'binomial' for logistic
    #                    regression or 'gaussian' for lineair regression;
    #
    #   withPartials   : (optional) a boolean value, indicating if partial
    #                    R-indicators have to be determined (TRUE) or
    #                    not (FALSE);
    #   withPartialCV  : (optional) a boolean value, indicating if partial
    #                    coefficients of variation have to be determined (TRUE) or
    #                    not (FALSE);
	#
    #   otherVariables : (optional).
    #
    # VALUE
    #   getRIndicator returns a list of which the most important components
    #   are described in the manual.

    nSample = nrow(sampleData)
    stopifnot(length(sampleWeights) == nSample)
    stopifnot(is.numeric(sampleWeights))

    # If sampleStrata is not defined, use sampleWeights to guess the values of
    # sampleStrata.
    if (is.null(sampleStrata))
        sampleStrata <- getSampleStrata(sampleWeights)

    stopifnot(is.factor(sampleStrata))
    stopifnot(length(sampleStrata) == nSample)

    sampleDesign <- getSampleDesign(sampleWeights, sampleStrata)

    family <- match.arg(family)
    model <- switch(family,
            'binomial' = list(
                    formula = formula,
                    grad    = function(mu)  exp(mu) / (1 + exp(mu))^2,
                    family  = binomial(link = 'logit')),
            'gaussian' = list(
                    formula = formula,
                    grad    = function(mu) 1,
                    family  = gaussian(link = 'identity')))

    indicator <- getRSampleBased(model, sampleData, sampleDesign)

    if ((withPartials) | (withPartialCV))
        estpartials <- getPartialRs(
                indicator, sampleData, sampleDesign, otherVariables)
	if (withPartials)
        indicator$partialR <- estpartials$partialR
    if (withPartialCV)
        indicator$partialCV <- estpartials$partialCV

    return (indicator)
} #--

#############################################################################
#
#  Private functions for the estimation of the sample-based indicators.
#
#############################################################################

getRSampleBased <-
        function(model,
                 sampleData,
                 sampleDesign)
{ #++
    # Determines the sample-based R-indicator.

    #  See 9.9 from Regression Modelling Strategies (Harrell, 2001) for a
    #  motivation for the factor
    #
    #    mean(sampleWeights) = sum(sampleWeights) / length(sampleWeights).

    sampleData <- within(sampleData, {
            sampleWeights <- sampleDesign$weights
            sampleWeights <- sampleWeights / mean(sampleWeights) })

    modelfit <- glm(model$formula, model$family, sampleData, sampleWeights)
    prop     <- predict(modelfit, type = 'response')
    propMean <- weighted.mean(prop, sampleDesign$weights)
    propVar  <- weightedVar(prop, sampleDesign$weights)

    # Because estimaters of bias and variance both use the following vectors
    # and matrix, they are calculated only once and passed to the functions.
    sigma <- vcov(modelfit)
    x <- model.matrix(model$formula, sampleData)[, colnames(sigma)]
    z <- model$grad(predict(modelfit, type = 'link')) * x

    withBiasAndVar <- !is.null(sigma) && all(!is.na(sigma))
    if (withBiasAndVar) {
        RBias <- getBiasRSampleBased(prop, z, sigma, sampleDesign)
        RVar  <- getVarianceRSampleBased(prop, z, sigma, sampleDesign)

        # To simplify formulas the bias correction of the variance will be
        # written as a factor, 1 - bias / (variance of propensities).
        if (RBias > propVar)
            RBiasFactor <- 0
        else
            RBiasFactor <- 1 - RBias / propVar
    } else {
        RBias <- NA
        RBiasFactor <- NA
        RVar <- NA
    }

    CVUnadj <- sqrt(propVar) / propMean
	CV <- sqrt(propVar * RBiasFactor)/propMean
    CVVar <- 0.25 * RVar / propMean^2 + CV^4 / nrow(sampleData)

    indicator <- list(
            type          = 'R-indicator, sample based',
            sampleDesign  = sampleDesign,
            prop          = prop,
            propMean      = propMean,
            model         = model,
            modelfit      = modelfit,
            sigma         = sigma,
            z             = z,
            R             = 1 - 2 * sqrt(propVar * RBiasFactor),
            RUnadj        = 1 - 2 * sqrt(propVar),
            RSE           = sqrt(RVar),
            RBiasFactor   = RBiasFactor,
            CVUnadj       = CVUnadj,
			CV			  = CV,
            CVSE          = sqrt(CVVar))

    return (indicator)
} #--

getBiasRSampleBased <-
        function(prop,
                 z,
                 sigma,
                 sampleDesign)
{ #++
    # Estimates the bias of the estimator for the variance of the
    # propensities.

    nPopulation <- sum(sampleDesign$weights)
    propVar <- sampleDesign$getVarTotal(sampleDesign, prop)
    z <- z * sqrt(sampleDesign$weights)

    lambda1 <- sum(apply(z, 1, function(zi) return(t(zi) %*% sigma %*% zi)))
    lambda2 <- propVar / nPopulation
    bias <- (lambda1 - lambda2) / nPopulation

    return (bias)
} #--

getVarianceRSampleBased <-
        function(prop,
                 z,
                 sigma,
                 sampleDesign)
{ #++
    # Estimates the variance of the estimator for the R-indicator.

    weights <- sampleDesign$weights
    nSample <- length(weights)
    nPopulation <- sum(weights)

    propMean <- weighted.mean(prop, weights)
    propVar <- weightedVar(prop, weights, method = 'ML')
    propZ <- cbind(prop, z)

    A <- cov.wt(propZ, wt = weights, method = 'ML')$cov[-1, 1]
    B <- cov.wt(z, wt = weights, method = 'ML')$cov
    C <- sampleDesign$getVarTotal(sampleDesign, (prop - propMean)^2)

    variance <- numeric()
    variance[1] <- 4 * t(A) %*% sigma %*% A
    variance[2] <- 2 * getTrace(B %*% sigma %*% B %*% sigma)
    variance[3] <- C / nPopulation^2
    variance <- sum(variance) / propVar

    return (variance)
} #--

#############################################################################
#
#  Private functions for the estimation of the sample-based, partial
#  indicators.
#
#############################################################################

getPartialRs <-
        function(indicator,
                 sampleData,
                 sampleDesign,
                 otherVariables = character())
{ #++
    # Estimates both unconditional and conditional partial R-indicators.

    RR <- indicator$propMean
    modelVariables <- getVariables(indicator$model$formula, FALSE)
    variables <- unique(c(modelVariables, otherVariables))

    byVariablesR  <- NULL
	byVariablesCV  <- NULL
    byCategoriesR <- list()
    byCategoriesCV <- list()

    for (variable in variables) {
       pConditional <-
                getPartialRConditional(
                        indicator, variable, sampleData, sampleDesign)

       pUnconditional <-
                getPartialRUnconditional(
                        indicator, variable, sampleData, sampleDesign)

       byVariableR <- data.frame(
                variable   = variable,
                Pu         = pUnconditional$Pu,
                PuUnadj    = pUnconditional$PuUnadj,
                PuSE       = pUnconditional$PuSE,
                Pc         = pConditional$Pc,
                PcUnadj    = pConditional$PcUnadj,
                PcSEApprox = pUnconditional$PuSE)

       byVariableCV <- data.frame(
                variable   = variable,
                CVu         = pUnconditional$Pu/RR,
                CVuUnadj    = pUnconditional$PuUnadj/RR,
                CVuSE       = pUnconditional$PuSE/RR,
                CVc         = pConditional$Pc/RR,
                CVcUnadj    = pConditional$PcUnadj/RR,
                CVcSEApprox = pUnconditional$PuSE/RR)

        byVariablesR <- rbind(byVariablesR, byVariableR)
        byVariablesCV <- rbind(byVariablesCV, byVariableCV)

        byCategoryR <- merge(
                pUnconditional$byCategory,
                pConditional$byCategory)

        byCategoryCV <- byCategoryR
		names(byCategoryCV) <- c("category","CVuUnadj","CVuUnadjSE","CVcUnadj","CVcUnadjSE")
		byCategoryCV$CVuUnadj <- byCategoryCV$CVuUnadj/RR
		byCategoryCV$CVuUnadjSE <- byCategoryCV$CVuUnadjSE/RR
		byCategoryCV$CVcUnadj <- byCategoryCV$CVcUnadj/RR
		byCategoryCV$CVcUnadjSE <- byCategoryCV$CVcUnadjSE/RR

        byCategoriesR <- c(byCategoriesR, list(byCategoryR))
		byCategoriesCV <- c(byCategoriesCV, list(byCategoryCV))
    }

    names(byCategoriesR) <- byVariablesR$variable
    names(byCategoriesCV) <- byVariablesCV$variable

    partialR <- list(
            byVariables  = byVariablesR,
            byCategories = byCategoriesR)

	partialCV <- list(
            byVariables  = byVariablesCV,
            byCategories = byCategoriesCV)

	partials <- list(
            partialR  = partialR,
            partialCV = partialCV)

    return (partials)
} #--

getPartialRUnconditional <-
        function(indicator,
                 variable,
                 sampleData,
                 sampleDesign)
{ #++
    # Estimates unconditional partial R-indicators.

    stopifnot(variable %in% names(sampleData))

    categories  <- sampleData[[variable]]
    RBiasFactor <- indicator$RBiasFactor
    nPopulation <- sum(indicator$sampleDesign$weights)
    propMean    <- indicator$propMean

    arg <- with(indicator,
            data.frame(
                    n    = sampleDesign$weights,
                    prop = sampleDesign$weights * prop))

    byCategory <- within(
            aggregate(arg, list(category = categories), sum), {
                    prop     <- prop / n
                    propSign <- sign(n * (prop - propMean))
                    propVar  <- n * (prop - propMean)^2 / nPopulation
                    PuUnadj  <- propSign * sqrt(propVar) })

    model <- within(indicator$model,
            formula <- replaceRHSByVariable(formula, variable))

    propVar <- sum(byCategory$propVar)
    Pu      <- sqrt(propVar * RBiasFactor)
    PuUnadj <- sqrt(propVar)
    PuSE    <- 0.5 * getRSampleBased(model, sampleData, sampleDesign)$RSE

    partialIndicator <- list(
            type       = 'Unconditional partial R-indicator, sample based',
            variable   = variable,
            Pu         = Pu,
            PuUnadj    = PuUnadj,
            PuSE       = PuSE,
            byCategory = byCategory)

    partialIndicator <- getVariancePartialRUnconditional(
            partialIndicator, indicator, sampleData, sampleDesign)

    partialIndicator$byCategory <-
            partialIndicator$byCategory[c('category', 'PuUnadj', 'PuUnadjSE')]

    return (partialIndicator)
} #--

getVariancePartialRUnconditional <-
        function(partialIndicator,
                 indicator,
                 sampleData,
                 sampleDesign)
{ #++
    # Calculate the variance of the partial-R indicators.

    nPopulation <- sum(sampleDesign$weights)
    variable    <- partialIndicator$variable
    byCategory  <- partialIndicator$byCategory
    prop        <- indicator$prop

    V1 <- numeric()
    V2 <- numeric()

    nSample <- nrow(sampleData)

    for (index in seq(nrow(byCategory))) {
        label  <- byCategory[index, 'category']
	    delta  <- ifelse(sampleData[[variable]] == label, 1, 0)
        deltaC <- 1 - delta

        V1[index] <- sampleDesign$getVarTotal(sampleDesign, delta * prop)
        V2[index] <- sampleDesign$getVarTotal(sampleDesign, deltaC * prop)
    }

    partialIndicator$byCategory <- within(byCategory, {
            PuUnadjSE <- sqrt(n / nPopulation * (
                    V1 * (1 / n - 1 / nPopulation)^2 +
                    V2 * (1 / nPopulation)^2)) })

    return (partialIndicator)
} #--

getPartialRConditional <-
        function(indicator,
                 variable,
                 sampleData,
                 sampleDesign)
{ #++
    # Estimates conditional partial R-indicators.

    stopifnot(variable %in% names(sampleData))

    sampleWeights <- indicator$sampleDesign$weights
    modelVariables  <- getVariables(indicator$model$formula, FALSE)
    otherVariables  <- modelVariables %sub% variable
    otherCategories <- as.list(sampleData[otherVariables])

    propMeanByOthers <- with(indicator,
            ave(sampleWeights * prop, otherCategories, FUN = sum) /
            ave(sampleWeights, otherCategories, FUN = sum))

    zMeanByOthers <- apply(
            indicator$z, 2,
            FUN = function(x) return (
                    ave(sampleWeights * x, otherCategories, FUN = sum) /
                    ave(sampleWeights, otherCategories, FUN = sum)))

    categories  <- sampleData[[variable]]
    RBiasFactor <- indicator$RBiasFactor
    weights     <- sampleWeights / sum(sampleWeights)

    arg <- with(indicator,
            data.frame(
                    n       = sampleWeights,
                    propVar = weights * (prop - propMeanByOthers)^2))

    byCategory <- within(
            aggregate(arg, list(category = categories), sum), {
                    PcUnadj <- sqrt(propVar) } )

    propVar <- sum(byCategory$propVar)
    Pc      <- sqrt(propVar * RBiasFactor)
    PcUnadj <- sqrt(propVar)

    partialIndicator <- list(
            type             = 'Conditional partial R-indicator, sample based',
            variable         = variable,
            Pc               = Pc,
            PcUnadj          = PcUnadj,
            byCategory       = byCategory,
            propMeanByOthers = propMeanByOthers,
            zMeanByOthers    = zMeanByOthers)

    partialIndicator <- getVariancePartialRConditional(
            partialIndicator, indicator, sampleData, sampleDesign)

    partialIndicator$byCategory <-
            partialIndicator$byCategory[c('category', 'PcUnadj', 'PcUnadjSE')]

    return (partialIndicator)
} #--

getVariancePartialRConditional <-
        function(partialIndicator,
                 indicator,
                 sampleData,
                 sampleDesign)
{ #++
    byCategory  <- partialIndicator$byCategory
    variable    <- partialIndicator$variable
    sigma       <- indicator$sigma
    weights     <- sampleDesign$weights
    nPopulation <- sum(weights)

    propDelta <- indicator$prop - partialIndicator$propMeanByOthers
    zDelta <- indicator$z - partialIndicator$zMeanByOthers

    variance <- numeric()
    for (index in seq(nrow(byCategory))) {
        label <- byCategory[index, 'category']
        delta <- ifelse(sampleData[[variable]] == label, 1, 0)
        zDeltaWeight <- zDelta * delta * weights
        propDelta2 <- propDelta * propDelta * delta

        A <- matrix(propDelta, nrow = 1) %*% zDeltaWeight
        B <- t(zDelta) %*% zDeltaWeight

        V1 <- 4 * A %*% sigma %*% t(A)
        V2 <- 2 * getTrace(B %*% sigma %*% B %*% sigma)
        V3 <- sampleDesign$getVarTotal(sampleDesign, propDelta2)

        variance[index] <-
                0.25 * (V1 + V2 + V3) /
                (nPopulation * sum(propDelta2 * weights))
    }

    partialIndicator$byCategory <- within(byCategory,
            PcUnadjSE <- sqrt(variance))

    return (partialIndicator)
} #--

#############################################################################
#
#  Other private functions, ... .
#
#############################################################################

getSampleStrata <-
        function(sampleWeights,
                 nMaxStrata = 20)
{ #++
    # Guesses a definition of the sample strata, using the values of the sample
    # weights.

    weights <- sort(unique(sampleWeights))
    indices <- seq(along = sampleWeights)
    strata <- factor(seq(along = weights))

    if (length(weights) <= nMaxStrata) {
        values <- merge(
                data.frame(weight = sampleWeights, index = indices),
                data.frame(weight = weights, stratum  = strata),
                all.x = TRUE)

        sampleStrata <- values[order(values$index), 'stratum']
    } else
        sampleStrata <- factor(rep(1, length(sampleWeights)))

    return (sampleStrata)
} #--

getSampleDesign <-
        function(sampleWeights,
                 sampleStrata)
{ #++
    # Guesses which type of sample desing is used, using the following rules.
    # (1) A single stratum and constant weights implies SI sampling.
    # (2) More than one stratum and constant weights per stratum implies STSI
    #     sampling.
    minmax <- sapply(split(sampleWeights, sampleStrata), range)
    constantWeights <- all(minmax[1,] == minmax[2,])

    nStrata <- length(levels(sampleStrata[, drop = TRUE]))

    if (constantWeights) {
        type <- ifelse(nStrata == 1, 'SI', 'STSI')
        getVarTotal <- getSampleVarTotalSTSI

    } else {
        type <- ''
        getVarTotal <- getSampleVarTotalPPS
    }

    sampleDesign <- list(
            type        = type,
            weights     = sampleWeights,
            strata      = sampleStrata,
            getVarTotal = getVarTotal)

    return (sampleDesign)
} #--

getSampleVarTotalSTSI <-
        function(sampleDesign,
                 y)
{ #++
    # return (getSampleCovTotalSTSI(sampleDesign, y, y))

    getStratumVarTotal <-
            function(sample)
    { #++
        N <- sum(sample$weights)
        n <- nrow(sample)

        return (N^2 * (1 - n / N) * var(sample$y) / n)
    } #--

    sample <- data.frame(y = y, weights = sampleDesign$weights)
    strataVar <- sapply(split(sample, sampleDesign$strata), getStratumVarTotal)
    sampleVar <- sum(strataVar)

    return (sampleVar)
} #--

getSampleVarTotalPPS <-
        function(sampleDesign,
                 y)
{ #++
    # If the sample design is neither SI nor STSI, use the formulae of the SE
    # of a PPS design.

    # return (getSampleCovTotalPPS(sampleDesign, y, y))

    n <- length(sampleDesign$weights)
    y <- y * sampleDesign$weights
    sampleVar <- sum((n * y - sum(y))^2) / n / (n - 1)

    return (sampleVar)
} #--

getVariables <-
        function(formula,
                 leftHandSide = FALSE)
{ #++
    # Returns the names of the variables used either in the left hand side of
    # the formula or in the right hand side of the formula.

    if (leftHandSide)
        formula <- update.formula(formula, . ~ 1)
    else
        formula <- update.formula(formula, 1 ~ .)

    variables <- all.vars(formula)

    if (length(variables) == 1 && variables == '.')
        variables <- NA

    return (variables)
} #--

replaceRHSByVariable <-
        function(formula,
                 variable)
{ #++
    replacement <- as.formula(paste('. ~ ', variable, sep = ''))
    formula <- update.formula(formula, replacement)

    return (formula)
} #--

getTrace <-
        function(m)
{ #++
    # Returns the trace of the matrix m.

    return (sum(m[col(m) == row(m)]))
} #--

weightedVar <-
        function(x,
                 weights = rep(1, length(x)),
                 method = c('unbiased', 'ML'))
{ #++
    # Returns the weighted variance of the vector x.

    xMean <- weighted.mean(x, weights)
    xVar <- sum(weights * (x - xMean)^2)
    xVar <- switch(match.arg(method),
                'unbiased' = xVar / (sum(weights) - 1),
                'ML'       = xVar / sum(weights))

    return (xVar)
} #--

'%sub%' <-
        function(x,
                 y)
{ #++
    # Returns all elements of the set operation x - y.
    #     > c(1, 2, 3, 4, 5) %sub% c(2, 4)
    #     [1] 1 3 5

    return (x[! x %in% y])
} #--


for each element in the set:
	for each subset constructed so far:
		new subset = (subset + element)


#' create array of positions
#' @param boxDim - the dimension of the box (row, column)
#' @param by - the direction of filling the box
#' @return a data.frame with row and column positions
#'
#' @examples
#' g <- getPlatePos(by = "col")
#' @export
getPlatePos <- function(boxDim = c(8, 12), by = "row"){
  rowMax = boxDim[1]
  colMax = boxDim[2]
  if (by == "row") {
    col <- rep(seq(1:colMax), rowMax)
    row <- rep(c(1:rowMax), each = colMax)
  } else if (by == "col") {
    row <- rep(seq(1:rowMax), colMax)
    col <- rep(c(1:colMax), each = rowMax)
  }
  pos <- RCToPos(row, col)
  return(pos)
}

#' convert A1 position to row and column
#' @param pos - an array of positions
#' @param collapse - if TRUE, will collapse the output into a single string
#' @return a data.frame with row and column positions
#' @export
posToRC <- function(pos, collapse = FALSE) {
  # rowIdx <- LETTERS[1:boxDim[1]]
  row <- col <- c()
  for (i in pos) {
      if(is.na(i)) {
        row <- c(row, NA)
        col <- c(col, NA)
        cat(crayon::yellow("request >> posToRC: NA founds in positions"))
      } else {
        row <- c(row, as.numeric(which(LETTERS == substr(i, 1, 1))))
        col <- c(col, as.numeric(substr(i, 2, nchar(i))))
      }
  }
  if (collapse) {
    return(paste0("R", row, "C", col))
  } else {
    return(data.frame(row=row, col=col))
  }
}

#' convert position to numeric position
#' @param pos - the position or an array of positions
#' @param boxDim - the dimension of the box (row, column)
#' @return an array of numeric positions
#' @examples
#' posToNum(c("B2", "C3"), boxDim = c(10,10))
#' @export
posToNum <- function(pos, boxDim = c(8, 12)) {
  rc <- posToRC(pos)
  num <- (rc$row - 1) * boxDim[2] + rc$col
  return(num)
}

#' convert row and column to a position
#' @param row - the row or an array of rows
#' @param col - the column or an array of columns
#' @return the position or an array of positions
#' @export
RCToPos <- function(row, col){
  pos <- paste0(LETTERS[row],col)
  return(pos)
}

#' convert row and column to a numeric position
#' @param row - the row or an array of rows
#' @param col - the column or an array of columns
#' @param boxDim - the dimension of the box (row, column)
#' @return the numeric position or an array of them
#' @export
RCToNum <- function(row, col, boxDim = c(8, 12)){
  pos <- RCToPos(row, col)
  num <- posToNum(pos, boxDim)
  return(num)
}

#' convert a numeric position to a letter position
#' @param num - the position or an array of positions
#' @param boxDim - the dimension of the box (row, column)
#' @return the letter position or an array of them
#' @export
numToPos <- function(num, boxDim = c(8, 12)){
  row <- ((num - 1) %/% boxDim[2]) + 1
  col <- ((num - 1) %% boxDim[2]) + 1
  pos <- RCToPos(row, col)
  return(pos)
}

#' find empty positions
#' @param positions - the position or an array of positions
#' @param boxDim - the dimension of the box (row, column)
#' @param by - the margin
#' @return empty positions
#' @export
findEmptyPositions <- function(positions, boxDim = c(8, 10), by = "col") {
  g <- getPlatePos(boxDim, by = by)
  diff <- setdiff(g, positions)
  return(diff)
}

findEmptyPositionsOn <- function(selectedSamples, plate, boxDim = c(8, 10), by = "col") {
  F <- selectedSamples$plateID == plate
  positions <- paste0(LETTERS[selectedSamples$newRow[F]], selectedSamples$newCol[F])
  return(findEmptyPositions(positions, boxDim = boxDim, by = by))
}

findAllEmptyPositions <- function(selectedSamples, boxDim = c(8, 10), by = "col") {
  emptyPositions <- data.frame()
  for (plate in levels(factor(selectedSamples$plateID))) {
    F <- selectedSamples$plateID == plate
    positions <- selectedSamples$wellPos[F]
    empty <- findEmptyPositions(positions, boxDim = boxDim, by = by)
    empty <- data.frame(position = empty, plateID = rep(plate, length(empty)))
    emptyPositions <- rbind(emptyPositions, empty)
  }
  return(emptyPositions)
}


source('common/src/utils/apply_transformations.r')

sepals = read.csv("common/data/raw/iris_sepals.csv")

feats = names(sepals)
ignore_cols = c("Flower.Id")
feats = feats[-which(feats %in% ignore_cols)]

transformations = list(
  log = log,
  sqrt = sqrt,
  sqrd = function(x) x^2
)

addl_features = apply_transformations(sepals, feats, transformations)

sepal_features = cbind(sepals, addl_features)
save(sepal_features, file='common/data/processed/sepal_features.rdata')


context("translate")

test_that("mean of same names", {
    G = matrix(c(1,2,0,3,4,5), nrow=3,
               dimnames=list(c('A','B','C'), c('D','E')))

    W = translate(G, along=1, from=rownames(G), to=c('a','b','b'), FUN=mean)
    #   D   E
    # a 1 3.0
    # b 1 4.5

    Wref = structure(c(1, 1, 3, 4.5), .Dim = c(2L, 2L),
                     .Dimnames = list(c("a", "b"), c("D", "E")))
    expect_equal(W, Wref)
})


#
# Install Packages
pacotes <- c("plotly", "tidyverse", "readxl", "factoextra", "pca3d",
             "FactoMineR")

if (sum(as.numeric(!pacotes %in% installed.packages())) != 0) {
  instalador <- pacotes[!pacotes %in% installed.packages()]
  for (i in 1:length(instalador)) {
    install.packages(instalador, dependencies = T)
    break
  }
  sapply(pacotes, require, character = T)
} else {
  sapply(pacotes, require, character = T)
}

# Workspace Configs #
options(ggrepel.max.overlaps = 2000)
# import dataset #
df_genes <- read.csv("genetic_dataset.csv", header = T, sep = ",")
 view(df_genes)

# sacale #
df_scaled <- scale(df_genes[, -1:-2], center = T)
df_scaled

# spectral decomposition #
pca1 <- princomp(df_scaled)

# visualization #
pca1
summary(pca1)
biplot(pca1)
pca1$scores

# singular decomposition #
pca2 <- prcomp(df_scaled)

# visualization #
pca2
pca2$x
summary(pca2)
biplot(pca2)

# main data #
pca1$scores == pca2$x

# main visualization #
fviz_pca(pca2)
fviz_screeplot(pca2)

# 3d visualization #
pca3d(pca2)
pca3d(pca2, show.labels = TRUE, fancy = TRUE)

# pca svd #
fpca <- PCA(df_scaled, ncp=18)
fpca
fpca$eig
fpca$ind$coord
fpca$ind$cos2
fpca$var$contrib

# plot #
fviz_pca(fpca)
fviz_pca_biplot(fpca, repel=TRUE)
fviz_pca_biplot(fpca, repel=TRUE, col.ind="cos2", cos.var="red")


#' Extract worldclim2 temperature, precipitation and uncertainties at 30s resolution for a given latitude/longtiude.
#' The precipitation uncertainty scales with elevation. If the user does not supply elevation then we default to 500m (mean in worldclim2 calibration data).
#' Would be nice to add a topography product to this when elevation is not supplied.
#' Only precipitation uncertainty scales with elevation.
#' Depends on output from JAGS models Colin fit. Not totally sure where to store these.
#'
#'
#' @param latitude         vector of latitude in decimal degrees.
#' @param longitude        vector of longitude in decimal degrees.
#' @param elev             vector of elevations. If none supplied defaults to 500m.
#' @param n.sim            number of simulations to base uncertainty estimate on. Default to 1000.
#' @param worldclim2_foder path to directory of worldclim2 rasters.
#'
#' @return           returns a datafrme with mat, map, mat_sd and map_sd
#' @export
#'
#' @examples
#' points <- structure(c(-148.274862, -148.274862, -148.2747566, -148.2747566,
#'                      -148.2746513, -148.2746513, -148.2744406, -148.2744406, -148.2740191,
#'                      -148.2740191, 64.766184, 64.766184, 64.766184, 64.766184, 64.766184,
#'                      64.766184, 64.766184, 64.766184, 64.766184, 64.766184), .Dim = c(10L,
#'                                                                                2L))
#' test.out <- worldclim2_grab(points[,2], points[,1])
source('paths.r') #need these for JAGS uncertainty models.
worldclim2_grab <- function(latitude,longitude,elev = 500, n.sim = 1000,
                            worldclim2_folder = '/fs/data3/caverill/WorldClim2/'){

  #make points an object
  points <- cbind(longitude, latitude)

  #load mean annual temperature and precipitation rasters from worldclim2
  prec    <- raster::raster(paste0(worldclim2_folder,'wc2.0_bio_30s_12.tif'))
  temp    <- raster::raster(paste0(worldclim2_folder,'wc2.0_bio_30s_01.tif'))
  temp_CV <- raster::raster(paste0(worldclim2_folder,'wc2.0_bio_30s_04.tif'))
  prec_CV <- raster::raster(paste0(worldclim2_folder,'wc2.0_bio_30s_15.tif'))
  mdr     <- raster::raster(paste0(worldclim2_folder,'wc2.0_bio_30s_02.tif'))

  #load runjags summaries of precipitation and temperature fitted vs. observed.
  prec.jags <- readRDS(wc_prec_JAGS.path)
  temp.jags <- readRDS(wc_temp_JAGS.path)

  #extract worldclim2 predicted climate data.
     prec.obs <- raster::extract(prec, points)
     temp.obs <- raster::extract(temp, points)
  prec_CV.obs <- raster::extract(prec_CV, points)
  temp_CV.obs <- raster::extract(temp_CV, points)
      mdr.obs <- raster::extract(    mdr, points)

  #temperature uncertainty workup. Draw from paramters n.sim times, calcualte predicted sd.
  temp.list <- list()
  for(i in 1:n.sim){
      intercept <- rnorm(1,temp.jags[1,4], temp.jags[1,5])
          slope <- rnorm(1,temp.jags[2,4], temp.jags[2,5])
             sd <- rnorm(1,temp.jags[3,4], temp.jags[3,5])
       pred.obs <- intercept + slope*temp.obs
       pred.out <- rnorm(length(pred.obs),pred.obs,sd)
       temp.list[[i]] <- pred.out
  }
  temp.list <- do.call('cbind',temp.list)
    temp.sd <- apply(temp.list,1, sd, na.rm = TRUE)

  #precipitation uncertainty workup. Draw from parameters n.sim times, calcualte predicted sd.
    prec.list <- list()
    for(i in 1:n.sim){
          intercept <- rnorm(1,prec.jags[1,4], prec.jags[1,5])
              slope <- rnorm(1,prec.jags[2,4], prec.jags[2,5])
             sd.int <- rnorm(1,prec.jags[3,4], prec.jags[3,5])
      sd.elev.slope <- rnorm(1,prec.jags[4,4], prec.jags[4,5])
           pred.obs <- intercept + prec.obs*slope
            pred.sd <- sd.int + elev*sd.elev.slope
           pred.out <- rnorm(length(pred.obs),pred.obs,pred.sd)
     prec.list[[i]] <- pred.out
    }
    prec.list <- do.call('cbind',prec.list)
      prec.sd <- apply(prec.list, 1, sd, na.rm = T)

  #wrap up output and return.
  to_return <- data.frame(cbind(prec.obs,prec.sd,temp.obs,temp.sd,prec_CV.obs,temp_CV.obs,mdr.obs))
  colnames(to_return) <- c('map','map_sd','mat','mat_sd','map_CV','mat_CV','mdr')
  return(to_return)

} #end function.


score <- function(input) {
    return((((((((((((((37.13534685269026) + ((input[1]) * (-0.10859102499053891))) + ((input[2]) * (0.04419889872599562))) + ((input[3]) * (0.017466905407308372))) + ((input[4]) * (2.832321087004625))) + ((input[5]) * (-18.48374869795793))) + ((input[6]) * (3.835495548436564))) + ((input[7]) * (0.00014091650900214126))) + ((input[8]) * (-1.5040340046693192))) + ((input[9]) * (0.31061748524339455))) + ((input[10]) * (-0.012306650033752073))) + ((input[11]) * (-0.9736183984588207))) + ((input[12]) * (0.009403964809694718))) + ((input[13]) * (-0.5203427347180726)))
}


library(lmerTest)
library(ggplot2)

rm(list=ls())

#la2<-read.csv("..\\..\\..\\empowermentexploration\\data\\regression\\20210909-1416-alchemy2-valuedifferences-human-1.csv")
#la2<-read.csv("..\\..\\..\\empowermentexploration\\data\\regression\\20211124-1433-alchemy2-valuedifferences-base-1.csv")
#la2<-read.csv("..\\..\\..\\empowermentexploration\\data\\regression\\20211124-1504-alchemy2-valuedifferences-cbu-1.csv")
#la2<-read.csv("..\\..\\..\\empowermentexploration\\data\\regression\\20211124-1527-alchemy2-valuedifferences-emp-1.csv")
la2<-read.csv("..\\..\\..\\empowermentexploration\\data\\regression\\20211202-1155-alchemy2-valuedifferences-bin-1.csv")

la2small<-subset(la2, trial<200)

# la2df<-data.frame(trial=scale(la2$trial),
#                   id=paste(la2$id),
#                   cbu=scale(la2$delta_cbu),
#                   emp=scale(la2$delta_emp),
#                   bin=scale(la2$delta_bin),
#                   cbv=scale(la2$delta_cbv),
#                   decision=la2$decision)

la2dfsmall<-data.frame(trial=scale(la2small$trial),
                  id=paste(la2small$id),
                  cbu=scale(la2small$delta_cbu),
                  emp=scale(la2small$delta_emp),
                  bin=scale(la2small$delta_bin),
                  cbv=scale(la2small$delta_cbv),
                  decision=la2small$decision)

#la2df_fullregression<-glmer(decision~-1+cbu+emp+trial+trial*cbu+trial*emp+(1|id), family='binomial', data=la2df, nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
#la2df_fullregression_summary<-summary(la2df_fullregression)
#la2df_fullregression_summary

#important for cbu dataset, also change cbu to cbu2 in regression when using the cbu dataset
la2dfsmall$cbu2 <- la2dfsmall$cbu + rnorm(nrow(la2dfsmall),0,0.05)

la2dfsmall_fullregression<-glmer(decision~-1+emp+bin+cbu+trial+trial*cbu+trial*emp+trial*bin+(1|id), family='binomial', data=la2dfsmall, nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
la2dfsmall_fullregression_summary<-summary(la2dfsmall_fullregression)
la2dfsmall_fullregression_summary

#la2dfsmall_partregression<-glmer(decision~-1+emp+cbu+trial+trial*cbu+trial*emp+(1|id), family='binomial', data=la2dfsmall, nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
#la2dfsmall_partregression_summary<-summary(la2dfsmall_partregression)
#la2dfsmall_partregression_summary

la2dfsmall_fullregression_m<-la2dfsmall_fullregression_summary$coefficients[1:3,1]
la2dfsmall_fullregression_se<-la2dfsmall_fullregression_summary$coefficients[1:3,2]

dataforplot_la2dfsmall_fullregression<-data.frame(mu=la2dfsmall_fullregression_m, ci=1.96*la2dfsmall_fullregression_se,
               model=rep(c('Empowerment', 'Binary', 'Uncertainty')))

#limits with 95% CIs
limits <- aes(ymax = mu + ci, ymin= mu - ci)

#plot
plot_la2dfsmall_fullregression <- ggplot(dataforplot_la2dfsmall_fullregression, aes(x=model, y=mu)) +
  #bars
  geom_bar(position="dodge", stat="identity", width=0.6)+
  #error bars
  geom_errorbar(limits, position="dodge", width=0.25)+
  #points
  geom_point(size=3)+
  #color
  #scale_fill_manual(values = c(cbPalette))+
  #theme
  theme_minimal() +
  #limits
  #scale_y_continuous(limits = c(0,100), expand = c(0, 0)) +
  #labs
  xlab("Model")+
  ylab(expression(beta))+
  #title
  ggtitle("")+
  #adjust text size
  theme(text = element_text(size=21,  family="sans"))+
  #no legend
  theme(legend.position = "none")

plot_la2dfsmall_fullregression

## BOTTOM UP ANALYSIS
# get model with single models as fixed effect
me <- glmer(decision ~ -1 + emp + trial + trial*emp + (1 | id), data=la2df, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
summary(me)

mv <- glmer(decision ~ -1 + cbv + trial + trial*cbv + (1 | id), data=la2df, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
summary(mv)

mb <- glmer(decision ~ -1 + bin + trial + trial*bin + (1 | id), data=la2df, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
summary(mb)

mu <- glmer(decision ~ -1 + cbu + trial + trial*cbu + (1 | id), data=la2df, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
summary(mu)

# get model with empowerment and binary as fixed effect
meb <- glmer(decision ~ -1 + emp + bin + trial + trial*emp + trial*bin + (1 | id), data=la2df, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
summary(meb)

# get model with empowerment and CBU as fixed effect
meu <- glmer(decision ~ -1 + emp + cbu + trial + trial*emp + trial*cbu + (1 | id), data=la2df, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
summary(meu)

# get model with binary and CBU as fixed effect
mub <- glmer(decision ~ -1 + bin + cbu + trial + trial*bin + trial*cbu + (1 | id), data=la2df, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
summary(mub)

# get model with empowerment and binary and CBU as fixed effect
meub <- glmer(decision ~ -1 + emp + bin + cbu + trial + trial*emp + trial*bin + trial*cbu + (1 | id), data=la2df, family="binomial", nAGQ=0, control=glmerControl(optimizer = "nloptwrap"))
summary(meub)

# compare models
anova(me, meb)
anova(mb, meb)
anova(me, meu)
anova(mu, meu)
anova(mb, mub)
anova(mu, mub)
anova(mub, meub)
anova(meu, meub)
anova(meb, meub)

emponbin <- lmer(emp ~ -1 + bin + (1|id), data = la2df)
summary(emponbin)


library(ggplot2)
library(reshape2)

setwd("SET_ROOT_DIRECTORY_HERE")

scenarioList <-c("SampleModel")

plotTornado<-function(data,prefix,scenario_id){
  data$range<-abs(data$high-data$low)
  data$sorter<-1/data$range
  data$parname = factor(as.character(data$parname),
                        levels=levels(data$parname)[order(data$sorter, decreasing=TRUE)])
  tp <- ggplot(data, aes(parname, mode, ymin = low, ymax=high))+ geom_linerange(size=15) +
				coord_flip()+ylab(levels(data$outcome))+xlab("Parameter")
  win.metafile(file=paste('output/',scenario_id,'/tornado_',prefix,levels(data$outcome),scenario_id,'.wmf',sep=''))
  print(tp)
  dev.off()
}

predictAtQuantiles<-function(data){
  x <- data$parvalue
  y <- data$value
  o <- data$outcome
  n <- data$parname
  mdl<-lm(y ~ x)
  q0<-predict(mdl, data.frame(x = quantile(x,0)))
  q0025<-predict(mdl, data.frame(x = quantile(x,0.025)))
  q05<-predict(mdl, data.frame(x = quantile(x,0.5)))
  q0975<-predict(mdl, data.frame(x = quantile(x,0.975)))
  q1<-predict(mdl, data.frame(x = quantile(x,1)))
  c(parname=levels(droplevels(data$parname)),outcome=levels(droplevels(data$outcome)),high=q0975,low=q0025,mode=q05,qzero=q0,qone=q1)
}

doPSA<-function(data,scenario_id){
  PSAByParam<-split(data,data$parname)
  df<-NULL
  for (p in PSAByParam){
    df<-rbind(df,(predictAtQuantiles(p)))
  }
  df<-data.frame(df, scenario_id)
  df$low<-as.numeric(as.character(df$low.2.5.))
  df$high<-as.numeric(as.character(df$high.97.5.))
  df$mode<-as.numeric(as.character(df$mode.50.))
  write.table(df,paste('output/',scenario_id,"/",levels(df$outcome),scenario_id,".txt", sep=""), sep = "\t", row.names = FALSE)
  plotTornado(df,'psa',scenario_id)
}

for (scenario_id in scenarioList){
  dir.create(file.path(paste('output/',scenario_id, sep='')), showWarnings = FALSE)
  PSA <- read.table(paste('output/PSA_',scenario_id,'_long.txt',sep=''), header=TRUE, sep="\t", na.strings="NA", dec=".", strip.white=TRUE)
  oneway <- read.table(paste('output/univariate_',scenario_id,'_long.txt',sep=''), header=TRUE, sep="\t", na.strings="NA", dec=".", strip.white=TRUE)
  oneway_wide<-dcast(oneway,parname+ outcome ~ assumption, value="value")
  byOutcome<-split(PSA,PSA$outcome)
  sapply(byOutcome,doPSA,scenario_id)
}


if (exists("destroy_environment")) destroy_environment()

source(file.path("utils.r"))

packages.get(c(
  "tidyverse",
  "janitor",
  "docstring",
  "ggcorrplot",
  "Hmisc",
  "here",
  "GGally"
))

get_OWID_df <- function(url = "https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/owid-covid-data.csv", ...){
  #' get_OWID_df
  #'
  #' returns a dataframe of the Our world in data data on covid-19 https://raw.githubusercontent.com/owid/covid-19-data/master/public/data/owid-covid-data.csv
  #' May used a chache if avaliable
  #'
  #' @param url is a location of the data default is
  #' @param ... is passed on to get_df_from_url
  #'
  #' @details  for more information see https://github.com/owid/covid-19-data as well as https://ourworldindata.org/coronavirus
  #'

  df <- get_df_from_url(url) %>%
    mutate_if(is.character, function(x){gsub(pattern = " ", replacement = "-", tolower(x))}) %>%
    rename(genc3c := iso_code) %>%
    rename(location_name := location) %>%
    mutate(
      fraction_positive_log = log_epsilon(total_cases/ total_tests),
      fraction_tested_log = log_epsilon(total_tests / population),
      fraction_cases_log = log_epsilon(total_cases/ population),
      fraction_dead_log = log_epsilon(total_deaths/ population),
      total_tests_log = log_epsilon(total_tests),
      total_cases_log = log_epsilon(total_cases),
      total_deaths_log = log_epsilon(total_deaths),
      gdp_per_capita_log = log_epsilon(gdp_per_capita),
      population_log = log_epsilon(population)
    )

  return(df)
}

#owid_Df <- get_OWID_df()

plot_pairs_OWID <-function(owid_Df = get_OWID_df()){
  #' pairs plot of some of the OWID data
  ggp <-
  owid_Df %>%
    select(
      continent, location_name, date, population_log,
      fraction_positive_log, fraction_tested_log, fraction_cases_log,  fraction_dead_log,
      gdp_per_capita_log#,
      #total_tests, total_cases, total_deaths
    )  %>%
    filter(continent != "") %>%
    drop_na() %>% #count(location_name)
    group_by(location_name) %>%
    slice(which.max(date))  %>%
    ungroup() %>%
    GGally::ggpairs(., columns =  4:ncol(.), ggplot2::aes(colour=continent, label = location_name, size = population_log))

  return(ggp)
}

plot_pairs_OWID()

##########
# Cases #

#in isolation GDP predicts covid cases
get_OWID_df() %>%
  filter(continent != "") %>%
  glm(
    formula = fraction_cases_log ~ gdp_per_capita_log,
    data = . ) %>% summary()

#Also true for latest date data
get_OWID_df() %>%
  filter(continent != "") %>%
  group_by(location_name) %>% slice(which.max(date))  %>% ungroup() %>%
  glm(
    formula = fraction_cases_log ~ gdp_per_capita_log,
    data = . ) %>% summary()

#Also true when including Date in regression
get_OWID_df() %>%
  filter(continent != "") %>%
  glm(
    formula = fraction_cases_log ~ date + gdp_per_capita_log,
    data = . ) %>% summary()

#It seems fraction positive does not get rid of the need for GDP
get_OWID_df() %>%
  filter(continent != "") %>%
  group_by(location_name) %>% slice(which.max(date))  %>% ungroup() %>%
  glm(
    formula = fraction_cases_log ~ gdp_per_capita_log + fraction_positive_log,
    data = . ) %>% summary()

#If we account for the fraction of the population tested this is taken care of it seems
get_OWID_df() %>%
  filter(continent != "") %>%
  group_by(location_name) %>% slice(which.max(date))  %>% ungroup() %>%
  glm(
    formula = fraction_cases_log ~ gdp_per_capita_log + fraction_tested_log,
    data = . ) %>% summary()

#It seems fraction tested and fraction positive are still good to have, even if GDP is taken care of now
get_OWID_df() %>%
  filter(continent != "") %>%
  group_by(location_name) %>% slice(which.max(date))  %>% ungroup() %>%
  glm(
    formula = fraction_cases_log ~ gdp_per_capita_log + fraction_tested_log + fraction_positive_log,
    data = . ) %>% summary()

########
#DEATHS#

#in isolation GDP predicts covid Deaths
a <- get_OWID_df() %>%
  filter(continent != "") %>%
  glm(
    formula = fraction_dead_log ~ gdp_per_capita_log,
    data = . ) %>% summary()

#Also true for latest date data
get_OWID_df() %>%
  filter(continent != "") %>%
  group_by(location_name) %>% slice(which.max(date))  %>% ungroup() %>%
  glm(
    formula = fraction_dead_log ~ gdp_per_capita_log,
    data = . ) %>% summary()

#Also true when including Date in regression
get_OWID_df() %>%
  filter(continent != "") %>%
  glm(
    formula = fraction_dead_log ~ date + gdp_per_capita_log,
    data = . ) %>% summary()

#It seems fraction positive does not get rid of the need for GDP
get_OWID_df() %>%
  filter(continent != "") %>%
  group_by(location_name) %>% slice(which.max(date))  %>% ungroup() %>%
  glm(
    formula = fraction_dead_log ~ gdp_per_capita_log + fraction_positive_log,
    data = . ) %>% summary()

#If we account for the fraction of the population tested this is taken care of it seems
get_OWID_df() %>%
  filter(continent != "") %>%
  group_by(location_name) %>% slice(which.max(date))  %>% ungroup() %>%
  glm(
    formula = fraction_dead_log ~ gdp_per_capita_log + fraction_tested_log,
    data = . ) %>% summary()

#It seems fraction tested and fraction positive are still good to have, even if GDP is taken care of now
get_OWID_df() %>%
  filter(continent != "") %>%
  group_by(location_name) %>% slice(which.max(date))  %>% ungroup() %>%
  glm(
    formula = fraction_dead_log ~ gdp_per_capita_log + fraction_tested_log + fraction_positive_log,
    data = . ) %>% summary()


############## Make nice heatmaps ##############

## The script is derived from   http://www.molecularecologist.com/2013/08/making-heatmaps-with-r-for-microbiome-analysis/
## There are a lot of explanations at the site.

# library
library(gplots)  # for heatmap.2

## to install packages from Bioconductor:
# source("http://bioconductor.org/biocLite.R")
# biocLite("Heatplus")  # annHeatmap or annHeatmap2

library(Heatplus)

# vegan package for hierachical clustering if you want to use distance functions not specified in dist.
library(vegan)

#  RColorBrewer package for better colour options
library(RColorBrewer)

setwd("C:/Users/kent.tleavell_nt/Downloads") # I downloaded the data from the link in the website. Need some trimming in order to work.

## load in the data
all.data.1 <- read.delim("TableS7-genus.txt")
#check for dimmension
dim(all.data.1)
#move the first row into row.name
row.names(all.data.1)=all.data.1[,1]
all.data = t(all.data.1[-1])
dim(all.data)
  #12 238
# check again
all.data[1:3, 1:4]

## transform the raw counts of reads to proportions within each sample
data.prop <- all.data/rowSums(all.data)
#check
data.prop[1:3, 1:3]

############## make heatmaps

#### 1) the basic heatmaps

# colorRampPalette  creates a colour palette that shades from light yellow to red in RGB space with 100 unique colours
scaleyellowred <- colorRampPalette(c("lightyellow", "red"), space = "rgb")(100)

# simple heatmap
#heatmap(as.matrix(data.prop), Rowv = NA, Colv = NA, col = scaleyellowred) # ugly

## remove genera that are exceedingly rare (less than 1%) from this figure.
maxab <- apply(data.prop, 2, max)

idx <- which(maxab < 0.01)
data.prop.1 <- data.prop[, -idx]

## redraw heatmap
heatmap(as.matrix(data.prop.1), Rowv = NA, Colv = NA, col = scaleyellowred, margins = c(10, 3))

## draw dendrogram on rows and columns
heatmap(as.matrix(data.prop.1), Rowv = T, Colv = T, col = scaleyellowred, margins = c(10, 3))

##### 2) label the condidtions for the samples.

# make a vector of variable represented by colors
var1 <- round(runif(n = 12, min = 1, max = 2))? # this randomly samples from a uniform distribution and rounds the result to an integer value
var1 <- replace(var1, which(var1 == 1), "deepskyblue")
var1 <- replace(var1, which(var1 == 2), "magenta")

# bind the color vector with the sample names for checking
cbind(row.names(data.prop), var1)

# remake the heatmap
heatmap.2(as.matrix(data.prop.1),Rowv = T, Colv = T, col = scaleyellowred, RowSideColors = var1,  margins = c(10, 5))# this puts in the annotation for the samples

# beautfy further
heatmap.2(as.matrix(data.prop.1),Rowv = T, Colv = T, col = scaleyellowred, RowSideColors = var1,  margins = c(10, 5),trace = "none", density.info = "none", xlab = "genera", ylab = "Samples", main = "Heatmap example", lhei = c(2, 8))

#### 3) annotation with multiple variables at once

# create a two-variable annotation data frame
ann.dat <- data.frame(var1 = c(rep("cat1", 4), rep("cat2", 8)), var2 = rnorm(12, mean = 50, sd = 20))

ann.dat

# Bray-curtis dissimilarity matrix for clustering rows and columns
data.dist <- vegdist(data.prop, method = "bray")
row.clus <- hclust(data.dist, "aver")

data.dist.g <- vegdist(t(data.prop.1), method = "bray") # transpose the data for column cluster
col.clus <- hclust(data.dist.g, "aver")

plot(
  annHeatmap2(
    as.matrix(data.prop.1)
    , col = colorRampPalette(
      c("lightyellow", "red")
      , space = "rgb"
    )(51)
    , breaks = 50
    , dendrogram = list(
      Row = list(dendro = as.dendrogram(row.clus))
      , Col = list(dendro = as.dendrogram(col.clus))
    )
    , legend = 3
    , labels = list(Col = list(nrow = 12))
    , ann = list(Row = list(data = ann.dat))
  )
)

## highlight the clusters in the dedrogram(s)  using different colours with the cluster sublist:
plot(
  annHeatmap2(
    as.matrix(data.prop.1)
    ,col = colorRampPalette(c("lightyellow", "red"), space = "rgb")(51)
    ,breaks = 50
    ,dendrogram = list(
      Row = list(dendro = as.dendrogram(row.clus))
      , Col = list(dendro = as.dendrogram(col.clus))
    )
    ,legend = 3
    ,labels = list(Col = list(nrow = 12))
    ,ann = list(Row = list(data = ann.dat))
    # cuth gives the height at which the dedrogram
    # should be cut to form clusters,
    # and col specifies the colours for the clusters
    ,cluster = list(
      Row = list(
        cuth = 0.25
        , col = brewer.pal(3, "Set2")
      ))
  )
)

# let's use what we have from above but with lattice instead
#  thanks to
#  http://stackoverflow.com/questions/6673162/reproducing-lattice-dendrogram-graph-with-ggplot2
library(latticeExtra)
library(magrittr)

data.prop.1 %>%
  as.matrix %>%
  t %>%
  .[order.dendrogram(as.dendrogram(col.clus)), ] %>%
  levelplot(
    xlab = NULL  #remove x axis label
    ,ylab = NULL #remove y axis label
    ,scales=list(x=list(rot=90))  #rotate text on x axis labels
    ,par.settings = list(
      regions = list(
        # set our colors to the same palette used in the base example
        col = colorRampPalette(c("lightyellow", "red"), space = "rgb")(51))
      )
    # provide a color scale legend to the left
    ,colorkey = list(space = "left")
    # add our dendrograms
    ,legend = list(
      # column dendrogram to right
      right = list(
        fun = dendrogramGrob
        ,args = list(
          x = as.dendrogram(row.clus)
          , side = "right"
          , size = 3 #size of dendrogram
        )
      )
      # row dendrogram above
      ,top = list(
        fun = dendrogramGrob
        ,args = list(
          x = as.dendrogram(col.clus)
          , side = "top"
          , size = 3  #size of dendrogram
        )
      )
    )
  )

# use simple svgPanZoom htmlwidget
library(SVGAnnotation)
library(svgPanZoom)
## highlight the clusters in the dedrogram(s)  using different colours with the cluster sublist:
svgPanZoom(
  svgPlot({
    plot(
      annHeatmap2(
        as.matrix(data.prop.1)
        ,col = colorRampPalette(c("lightyellow", "red"), space = "rgb")(51)
        ,breaks = 50
        ,dendrogram = list(
          Row = list(dendro = as.dendrogram(row.clus))
          , Col = list(dendro = as.dendrogram(col.clus))
        )
        ,legend = 3
        ,labels = list(Col = list(nrow = 12))
        ,ann = list(Row = list(data = ann.dat))
        # cuth gives the height at which the dedrogram
        # should be cut to form clusters,
        # and col specifies the colours for the clusters
        ,cluster = list(
          Row = list(
            cuth = 0.25
            , col = brewer.pal(3, "Set2")
          ))
      )
    )
  })
)

#  now let's try it with rCharts
library(rCharts)
library(tidyr)
library(dplyr)

data.prop.1 %>%
  data.frame(
    genera = rownames(.)
    , .
  ) %>%
  # change genera so it will sort properly
  mutate( genera = gsub(
    x = genera
    , pattern = 'S([0-9]{1}$)'
    , replacement = "S0\\1"
    )
  ) %>%
  gather( annotation, proportion , -genera ) %>%
  dPlot(
    data = .
    , genera ~ annotation
    , yAxis = list( type = "addCategoryAxis", orderRule = "genera" )
    , colorAxis = list(
      type = "addColorAxis"
      , colorSeries = "proportion"
      , palette = colorRampPalette(c("lightyellow", "red"), space = "rgb")(51)
      , outputFormat = ".1%"
    )
    , type = "bar"
    , bounds = list( x=50, y=150, width = 500, height = 300)
    , height = 600
    , width = 600
  )

#visualize the dendrograms in d3
library(networkD3)
library(htmltools)

tagList(
  lapply(
    c("tree.cartesian"
      ,"tree.radial"
      ,"cluster.cartesian"
      ,"cluster.radial"
    )
    ,function(chartType){
      hierNetwork(
        as.treeNetwork(col.clus, root = "Annotation")
        , type = chartType
        , zoomable = T
        , collapsible = T
      )
    }
  )
) %>% html_print


# source("cnn.common.r");

library(tensorflow)
use_condaenv('tensorflow-1.3')

combine_xy_dat <- function(xtrain, ytrain, classes) {
	dat1 <- xtrain;
	## convert from class label to a number from 1:n
	for (i in classes) {
		dat1 <- cbind(dat1, ytrain==i);
	}

	## MUST BE matrix
	as.matrix(dat1)
}

#************************************************************************************************************************
## doing batch normalization (BN)
## ndim is a 3 dimensional array in convolution layer
##         a 1 dimensional array in fully connected layer
## refer to https://r2rt.com/implementing-batch-normalization-in-tensorflow.html
batch_norm_wrapper <- function(inputs, is_training=TRUE, ndim=shape(100), decay = 0.999) {
	# cat("\t\t now in the batch normalization... \n")

	# Small epsilon value for the BN transform
	epsilon = 1e-3;

	# DO NOT invoke another tf$InteractiveSession() during session to derive ndim
	scale <- tf$Variable(tf$ones (ndim));
	beta  <- tf$Variable(tf$zeros(ndim));
	pop_mean <- tf$Variable(tf$zeros(ndim), trainable=FALSE);
	pop_var  <- tf$Variable(tf$ones (ndim), trainable=FALSE);

	if (is_training==1) {
		mean_var <- tf$nn$moments(inputs, as.integer(0) );
		batch_mean <- mean_var[[1]];
		batch_var <- mean_var[[2]];
		train_mean <- tf$assign(pop_mean, pop_mean * decay + batch_mean * (1 - decay));
		train_var <- tf$assign(pop_var, pop_var * decay + batch_var * (1 - decay));

		## this command is only used in Python
		# with tf.control_dependencies([train_mean, train_var]):

		## not work
		# if (class( tf$control_dependencies(list(train_mean, train_var)) )[[1]]=="tensorflow.python.framework.ops._ControlDependenciesController") {
			# result <- tf$nn$batch_normalization(inputs, batch_mean, batch_var, beta, scale, epsilon);
		# }

		## work for only one dim
		# result <- tf$cond( tf$logical_and(tf$equal(train_mean[1], 0), tf$equal(train_var[1], 0)),
			# lambda<-function(inputs1=inputs, pop_mean1=batch_mean, pop_var1=batch_var, beta1=beta, scale1=scale, epsilon1=epsilon) {tf$nn$batch_normalization(inputs1, pop_mean1, pop_var1, beta1, scale1, epsilon1) },
			# lambda<-function(inputs1=inputs, pop_mean1=batch_mean, pop_var1=batch_var, beta1=beta, scale1=scale, epsilon1=epsilon) {tf$nn$batch_normalization(inputs1, pop_mean1, pop_var1, beta1, scale1, epsilon1) })

		## work for any dims
		## Note that this is tricky to invoke the above 2 lines in the NN graphs using a condition: tf$logical_and(tf$equal(train_mean_1, 0), tf$equal(train_var_1, 0))
		train_mean_1 <- tf$reshape(train_mean, shape(-1L) )[1];
		train_var_1  <- tf$reshape(train_var , shape(-1L) )[1];

		result <- tf$cond( tf$logical_and(tf$equal(train_mean_1, 0), tf$equal(train_var_1, 0)),
			lambda<-function(inputs1=inputs, pop_mean1=batch_mean, pop_var1=batch_var, beta1=beta, scale1=scale, epsilon1=epsilon) {tf$nn$batch_normalization(inputs1, pop_mean1, pop_var1, beta1, scale1, epsilon1) },
			lambda<-function(inputs1=inputs, pop_mean1=batch_mean, pop_var1=batch_var, beta1=beta, scale1=scale, epsilon1=epsilon) {tf$nn$batch_normalization(inputs1, pop_mean1, pop_var1, beta1, scale1, epsilon1) })

	} else {
		result <- tf$nn$batch_normalization(inputs, pop_mean, pop_var, beta, scale, epsilon);
	}

	## return result
	result
}

get_dim <- function(xxxx) {
	dimsn <- tf$shape(xxxx)$shape$dims[[1]]
	dims <- tf$Session()$run(tf$shape(xxxx)); ## convert from tensor to array

	cat(paste("\tdimsn = ", dimsn, "\tdims =", sep=""));
	cat(paste("\t", dims));
	cat("\n");
}
# get_dim(ten);

weight_variable <- function(shape, stddev=0.01) {
	initial <- tf$truncated_normal(shape, stddev=stddev)
	# initial <- tf$random_normal(shape, stddev=stddev)
	tf$Variable(initial)
}

bias_variable <- function(shape, constant=0) {
	initial <- tf$constant(constant, shape=shape)
	tf$Variable(initial)
}

conv2d <- function(x, W) {
	tf$nn$conv2d(x, W, strides=c(1L, 1L, 1L, 1L), padding='SAME')
}

get_mean_coe <- function(sess, W_conv2) {
	mat <- sess$run(W_conv2);
	cat("\tmean=", mean(mat), "std=", sd(mat), "min=", min(mat), "max=", max(mat), "\n");
}
# max_pool_2x2 <- function(x) {
	# tf$nn$max_pool(
		# x,
		# ksize=c(1L, 2L, 2L, 1L),
		# strides=c(1L, 2L, 2L, 1L),
		# padding='SAME')
# }

max_pool_2x2 <- function(x) {
	tf$nn$max_pool(
		x,
		ksize=c(1L, 2L, 2L, 1L),
		strides=c(1L, 2L, 2L, 1L),
		padding='SAME')
}

avg_pool_2x2 <- function(x) {
	tf$nn$avg_pool(
		x,
		ksize=c(1L, 2L, 2L, 1L),
		strides=c(1L, 2L, 2L, 1L),
		padding='SAME')
}

max_pool_1x2 <- function(x) {
	tf$nn$max_pool(
		x,
		ksize=c(1L, 1L, 2L, 1L),
		strides=c(1L, 1L, 2L, 1L),
		padding='SAME') ## SAME can fix when odd happens
}

conv2d_no_pad <- function(x, W, is_pad=FALSE) {
	if (is_pad) {
		result <- tf$nn$conv2d(x, W, strides=c(1L, 1L, 1L, 1L), padding='SAME');
	} else result <- tf$nn$conv2d(x, W, strides=c(1L, 1L, 1L, 1L), padding='VALID');

	result
}

conv3d_no_pad <- function(x, W) {
	tf$nn$conv3d(x, W, strides=c(1L, 1L, 1L, 1L, 1L), padding='VALID')
}

conv1d_no_pad <- function(x, W) {
	tf$nn$conv1d(x, W, stride=1L, padding='VALID')
}

next_batch <- function(dat, totaln, dimx=125, n=100, classn) {
	# index <- floor(runif(n, min=1, max=totaln));
	index <- sample.int(totaln, n); ## RANDOM
	listout <- list("x_batch"=dat[index, 1:dimx], "y_batch"=dat[index, (dimx+1):(dimx+classn)]);
	listout
}

next_batch_with_shuffle <- function(shuffle_index, dat, totaln, startx=1, dimx=125, n=100, classn) {
	# index <- floor(runif(n, min=1, max=totaln));
	# index <- sample.int(totaln, n); ## RANDOM
	index_shuf <- startx:(startx+n);
	extra <- startx+n - totaln;
	if (extra>0) index_shuf <- c(startx:totaln, 1:(startx+n-totaln) );

	index <- shuffle_index[index_shuf];
	listout <- list("x_batch"=dat[index, 1:dimx], "y_batch"=dat[index, (dimx+1):(dimx+classn)]);
	listout
}

next_batch_perclass <- function(dat, totaln, dimx=layersn*lengthn, n=100, classn, class_ns_train, list_train_index_per_class) {
	# index <- floor(runif(n, min=1, max=totaln));
	index <- vector(mode="integer");
	for (i in 1:classn) {
		indexi <- sample.int(class_ns_train[i], max(as.integer(n/totaln*class_ns_train[i]), 1) ); ## RANDOM
		index <- c(index, list_train_index_per_class[[i]][indexi])
	}
	listout <- list("x_batch"=dat[index, 1:dimx], "y_batch"=dat[index, (dimx+1):(dimx+classn)]);
	listout
}

print_sta <- function(ptm_sub, conf, itern, accuracies, kapps, classn) {
	time.my <- proc.time() - ptm_sub;
	# cat(paste("\n", sprintf("%.4f",time.my[3]/60),"hours\n"));
	print(Sys.time() );
	# cat(paste("\n", sprintf("%.3f",time.my[1]/3600),"\t", sprintf("%.3f",time.my[2]/3600),"\t", sprintf("%.3f",time.my[3]/3600),"hours\n"));
	conf <- conf/itern;
	# cat("\t Producer accuracy:", sprintf("%.4f", conf[1:classn, classn+2]), "\n");
	cat("Prod_accuracy:", sprintf("%20.4f", conf[1:classn, classn+2]), "\n");
	cat("User_accuracy:", sprintf("%20.4f", conf[classn+2, 1:classn]), "\n");

	# cat("\tMean Kappa =    ", sprintf("%20.4f", mean(kapps)     *100), "\n");
	# cat("\tMean Accuracy = ", sprintf("%20.4f", mean(accuracies)*100), "\n");
	print (accuracies)
	print (kapps)
	cat( sprintf("mean kapps      %6.4f", mean(kapps)         ), "\n");
	cat( sprintf("mean accuracies %6.2f", mean(accuracies)*100), "\n");
}

print_classes <-function(class_indexs, class_names, class_ns) {
	for (i in c(1:length(class_indexs)) ) {
		cat(sprintf("%20d", class_indexs[i]));
	}
	cat("\n");
	# for (i in c(1:length(class_indexs)) ) {
		# cat(sprintf("%20s", class_names[i]));
	# }
	# cat("\n");
	for (i in c(1:length(class_indexs)) ) {
		cat(sprintf("%20d", class_ns[i]));
	}
	cat("\n");
}

# next_batch_all_class <- function(dat, totaln, dimx=125, n=100, classn) {
	# index <- sample.int(totaln, n); ## RANDOM
	# listout <- list("x_batch"=dat[index, 1:dimx], "y_batch"=dat[index, (dimx+1):(dimx+classn)]);
	# listout
# }


a <- -3.36
b <- 3.62
q <- 0.24
d <- -1.56

print((a+b)/2)
print(sqrt((b-a)^2/12))
print(qunif(q, a, b))
bprimo <- (b-((a+b)/2))/(sqrt((b-a)^2/12))
aprimo <- (a-((a+b)/2))/(sqrt((b-a)^2/12))
print(ifelse(d>=aprimo && d<=bprimo, (1/(bprimo-aprimo)),0))


# Reading in Data
ds = read.csv('Social_Network_Ads.csv')
ds = ds[, 3:5]

# Scaling and splitting
library(caTools)
ds[,1:2] = scale(ds[,1:2])
split = sample.split(ds$Purchased, SplitRatio = 0.75)
train = subset(ds, split == TRUE)
test = subset(ds, split == FALSE)

# KNN
library(class)
y_pred = knn(train[, -3],
             test[, -3],
             cl = train[, 3],
             k = 5)

# Logistic regression
clf = glm(formula = Purchased ~ .,
          data = train,
          family = binomial)
prob_pred = predict(clf, type = 'response', newdata = test[-3])
y_pred = ifelse(prob_pred >= 0.5, 1, 0)

# SVM
library(e1071)
clf = svm(formula = Purchased ~ .,
          data = train,
          kernel = 'radial',
          type = 'C-classification')
y_pred = predict(clf, type = 'response', newdata = test[-3])

# Naive Bayes - requires encoding
library(e1071)
clf = naiveBayes(x = train[-3], y = train$Purchased)
y_pred = predict(clf, newdata = test[-3])

# Decision tree
library(rpart)
clf = rpart(formula = Purchased ~.,
            data = train)
prob_pred = predict(clf, newdata = test[-3])
y_pred = ifelse(prob_pred>0.5, 1, 0)

# Randomforest
library(randomForest)
clf = randomForest(x = train[-3], y = train$Purchased, ntree = 10)
y_pred = predict(clf, newdata=test[-3])

# Confusion matrix
cm = table(test[, 3], y_pred)

# Plot
library('ElemStatLearn')
set = train
X1 = seq(min(set[, 1]) - 1, max(set[, 1]) + 1, by = 0.01)
X2 = seq(min(set[, 2]) - 1, max(set[, 2]) + 1, by = 0.01)
grid_set = expand.grid(X1, X2)
colnames(grid_set) = c('Age', 'EstimatedSalary')
# May need to change below if classifier outputs categories.
prob_set = predict(clf, type = 'response', newdata = grid_set)
y_grid = ifelse(prob_set > 0.5, 1, 0)
# y_grid = predict(clf, newdata=grid_set)

plot(set[, -3],
     main = 'Title',
     xlab = 'Age', ylab = 'Estimated Salary',
     xlim = range(X1), ylim = range(X2))
contour(X1, X2, matrix(as.numeric(y_grid), length(X1), length(X2)), add = TRUE)
points(grid_set, pch = '.', col = ifelse(y_grid == 1, 'springgreen3', 'tomato'))
points(set, pch = 21, bg = ifelse(set[, 3] == 1, 'green4', 'red3'))


#' Calculator for dz (within subjects effect size)
#'
#' Calculator for dz (within subjects effect size)
#' @param x,y vectors of the DV for each level of the IV
#' @export
#' @examples dz_calculator()

dz_calculator <- function(x,y) {

  out <- tibble::tibble(contrast = x - y) %>%
    dplyr::summarise(mean_contrast = mean(contrast), sd_contrast = sd(contrast), d_z = mean_contrast/sd_contrast) %>% dplyr::pull(d_z)
  return(abs(out))

}


# R Code
# Classifiers
# L. Garcia, A. Lorena, M. de Solto 2017
# Supervised Learning - Classifiers

ANN <- function(tran, test) {

  model = MLP(class ~ ., tran, control=Weka_control(L=0.3, M=0.5))
  pred = predict(model, test[,-ncol(test)], type="class")
  names(pred) = row.names(test)
  return(pred)
}

C4.5 <- function(tran, test) {

  model = RWeka::J48(class ~., tran)
  pred = predict(model, test[,-ncol(test)], type="class")
  names(pred) = rownames(test)
  return(pred)
}

kNN <- function(tran, test) {

  pred = kknn(class ~., tran, test[,-ncol(test)], k=3)$fitted.values
  names(pred) = rownames(test)
  return(pred)
}

SVM <- function(tran, test) {

  model = svm(class ~., tran, kernel="radial")
  pred = predict(model, test[,-ncol(test)])
  return(pred)
}

accuracy <- function(pred, test) {
  sum(diag(table(test$class, pred)))/sum(table(test$class, pred))
}

classifiers <- function(tran, test) {
  sapply(CLASSIFIERS, function(c) {
    accuracy(do.call(c, list(tran, test)), test)
  })
}


# load expression data
load('datExpr.RData')

if(dim(datExpr)[2]^2 > 2^31){
    print('Now, Data is too huge to handle for WGCNA!\n
    You could trim you data or follow the block-wise-
    network-construction script in WGCNA.')
    quit(save='no')
}

# environment
library(WGCNA)
options(stringsAsFactors=FALSE)
enableWGCNAThreads(6)

# softpower
softPower = 7

# unsigned type
adjacency = adjacency(datExpr, power = softPower)
save(file='adjMat.RData', adjacency)
TOM = TOMsimilarity(adjacency)
dissTOM = 1 - TOM
save(file='dissTOM.RData', dissTOM)
#load('dissTOM.RData')
geneTree = hclust(as.dist(dissTOM), method='average')
minModuleSize = 30

dynamicMods = cutreeDynamic(dendro = geneTree, distM = dissTOM, deepSplit = 4,
pamRespectsDendro = FALSE, minClusterSize = minModuleSize)

dynamicColors = labels2colors(dynamicMods)

MEList = moduleEigengenes(datExpr, colors = dynamicColors)
MEs = MEList$eigengenes
MEDiss = 1 - cor(MEs)
METree = hclust(as.dist(MEDiss), method = 'average')

# plot genetree cluster
#pdf(file = 'GeneTreeCluster.pdf', wi=12, he=9)
#plot(METree, main= 'Clustering of module eigengenes', xlab = '', sub = '', cex.lab = 0.6, cex.axis = 0.8)
#dev.off()

# plot module eigengenes cluster
MEDissThres = 0.25
#pdf(file = 'ClusterModuleEigengenes.pdf', wi=12, he=9)
#plot(METree, main='Clustering of module eigengenes', xlab = '', sub = '')
#abline(h=MEDissThres, col = 'red')
#dev.off()

# module merge
merge = mergeCloseModules(datExpr, dynamicColors, cutHeight = MEDissThres , verbose = 3)
mergedColors = merge$colors
mergedMEs = merge$newMEs
pdf(file = 'BeforeAndAfterMerge.pdf', wi=12, he=9)
plotDendroAndColors(geneTree, cbind(dynamicColors, mergedColors), dendroLabels
= FALSE, hang = 0.03, addGuide = TRUE, guideHang = 0.05)
dev.off()
png(file = 'BeforeAndAfterMerge.png', wi=2000, he=1600)
plotDendroAndColors(geneTree, cbind(dynamicColors, mergedColors), dendroLabels
= FALSE, hang = 0.03, addGuide = TRUE, guideHang = 0.05)
dev.off()

moduleColors = mergedColors
colorOrder = c('grey', standardColors(100))
moduleLabels = match(moduleColors, colorOrder) - 1
MEs = mergedMEs
save(file='dynamic_merged_networkdata.RData', MEs, moduleLabels, moduleColors,
geneTree, dynamicMods)

intramoduleConectivity = intramodularConnectivity(adjacency, moduleColors)
intramoduleConectivity = cbind(intramoduleConectivity, moduleColors)
write.table(intramoduleConectivity, file='intramoduleConectivity_all.xls', sep='\t', quote=F, col.names=NA)


#### Load Libraries ####
print("Loading Libraries....")
library(maptools)
library(sm)

#### Check Version for Required "lrm" Package ####
checkRVersion = function(checkMajor, checkMinor){
    majorBool = as.numeric(R.version$major) >= checkMajor
    minorBool = as.numeric(R.version$minor) >= checkMinor
    majorBool & minorBool
    }

versionBool = checkRVersion(2, 14)
if (versionBool){
    library(rms)
}else{
    require(Design)
}

#### Get Arguments ####
Args = commandArgs()
inputFC = sub(".shp", "", Args[5], ignore.case = TRUE)
outputFC = sub(".shp", "", Args[6], ignore.case = TRUE)
dependentVar = Args[7]
independentVarString = Args[8]
usePenalty = as.integer(Args[9])
usePenalty = usePenalty == 1
coefTable = sub(".dbf", "", Args[10], ignore.case = TRUE)
diagTable = sub(".dbf", "", Args[11], ignore.case = TRUE)
print(paste(commandArgs(), collapse=" "))

#### Get Ind Var Names ####
independentVars = strsplit(independentVarString, ";")
independentVars = c(unlist(independentVars))

### Make Formula ####
form = as.formula(paste(dependentVar, paste(independentVars, collapse='+'), sep='~'))

print("Begin Calculations....")
### Using Maptools ####
shp = readShapeSpatial(inputFC)

### Do Logit ####
print("Logit....")
#fit = lrm(form, shp)
fit = lrm(form, shp, x = TRUE, y = TRUE)

print("Adjustment....")
### AIC Alternative Measure of Model Performance ####
bf = pentrace(fit, seq(.2,1,by=.05))
if (usePenalty) {
    pen = bf$penalty
} else {
    pen = 0.0
}

allPens = bf$results.all[,1]
allAICs = bf$results.all[,3]
for (i in 1:length(allPens)){
    penValue = allPens[i]
    if (penValue == pen){
        aic = allAICs[i]
        }
    }

if (usePenalty){
    fit = update(fit, penalty = bf$penalty)
    }

### Residuals ####
res = residuals.lrm(fit)
resOut = c(res)
resSTD = (resOut - mean(resOut)) / sqrt(var(resOut))

### Create Output Shape File ####
print("Writing Output....")
shp$Residual = resOut
shp$StdResid = resSTD
writeSpatialShape(shp, outputFC)

### Write Coefficient DBF Table ####
allIndVars = c("Intercept")
allIndVars = append(allIndVars, independentVars)
k = length(allIndVars)
d = matrix(0, k, 4)
d[,1] = fit$coefficients
d[,2] = sqrt(diag(fit$var))
d[,3] = d[,1] / d[,2]
d[,4] = pnorm(abs(d[,3]), lower.tail = FALSE) * 2.0
coefList = list("Variable" = allIndVars, "Coef" = d[,1],
               "StdError" = d[,2], "Wald" = d[,3],
               "Prob" = d[,4])
coefFrame = data.frame(coefList)
write.dbf(coefFrame, coefTable)

### Write Diagnostic DBF Table ####
diagNames = names(fit$stats)
allStats = c(as.vector(fit$stats), pen, aic)
diagValues = matrix(allStats, length(diagNames), 1)
diagList = list("Diag_Name" = diagNames, "Diag_Value" = diagValues)
diagFrame = data.frame(diagList)
write.dbf(diagFrame, diagTable)

print("Calculations Complete...")


# Read previous scripts
# source("R/dm02_pkg.r")
# If simulated data
# NOTE: not resembling real data although same variable names
# source("R/dm03_sim_data.R")

# Multivariate model with the average school grade and all covariates
# Multivariate model with all school subject grades and all covariates
#	One model for each outcome. Include all school grades (splines) and covariates in the model
#	Define smoothing parameter lambda for each thin plate smoothing spline using generalized cross validation
#	Fit models and save model summaries for later visualization

# Read data ---------------------------------------------------------------

# fbc <- df_all # If with other colnames
fbc <- df_tot

# Mutate data -------------------------------------------------------------

# If scaling
fbc_scaled <- fbc %>%
  mutate_at(vars(starts_with("time")), ~ {
    ("2003-05-31" %--% .) / years(1)
  }) %>%
  mutate_at(vars(!!vars_avera, !!vars_grade), scale)

# If no scaling
# fbc <-
#   fbc %>%
#   mutate_at(vars(starts_with("time")), ~ {
#     ("2003-05-31" %--% .) / years(1)
#   })

# describe the models that need to be fit
model_descriptions <- crossing(
  outcome  = c("dg1", "dg2", "dg3"), # for simulation data
  # outcome  = c("psy", "bipo", "dep"), # for real data
  grades   = c(vars_grade, vars_avera, "All"),
  adjusted = c(FALSE, TRUE)
)

# needed for splines in model formulae
max_knots <- n_distinct(fbc$subject_1) - 1 # for simulation data
# max_knots <- n_distinct(fbc$Literature) - 1 # for read data

build_formula <- function(outcome, grades, adjusted, max_knots = 7) {
  f <- str_glue("event_{outcome} ~ offset(log(time_{outcome}))")

  if (adjusted) {
    f <- paste(f, "+", str_flatten(vars_covar, " + "))
  }

  if (grades == "All") {
    grades <- vars_grade
  }

  grades <- str_glue("s({grades}, k = {max_knots})")
  f <- paste(f, "+", str_flatten(grades, " + "))

  as.formula(f)
}

# takes about 3 minutes
# Scaled
model_fits_scaled <- model_descriptions %>%
  mutate(formula = pmap(., build_formula)) %>%
  mutate(fit = map(formula, poisson_gam, data = fbc_scaled))

# write_rds(model_fits, data_path("fits.rds"), compress = "gz")

# non-scaled
# model_fits_nonscaled <- model_descriptions %>%
#   mutate(formula = pmap(., build_formula)) %>%
#   mutate(fit = map(formula, poisson_gam, data = fbc))

# write_rds(model_fits, data_path("fits_non_scaled.rds"), compress = "gz")


### calculate the power for testing H0 when under H_beta in three ways: TSLS, AR, ARsens
### some parameter values are inferred from the ivmodel

IVpower=function(ivmodel, n=NULL, alpha=0.05, beta=NULL, type="TSLS", deltarange=NULL, delta=NULL){
  esti = para(ivmodel)
  if(is.null(n))
    n = ivmodel$n
  if(is.null(beta))
    beta = esti$beta
  if(is.null(deltarange))
    deltarange = ivmodel$deltarange

  if(type=="TSLS"){
     return(TSLS.power(n, beta, cor(ivmodel$Zadj, ivmodel$Dadj), esti$sigmau, var(ivmodel$Dadj), alpha))
  }
  if(type=="AR"){
    return(AR.power(n, ivmodel$p, ivmodel$L, beta, esti$gamma, var(ivmodel$Zadj), esti$sigmau, esti$sigmav, esti$rho, alpha))
  }

  if(type=="ARsens"){
    return(ARsens.power(n, ivmodel$p, beta, esti$gamma, var(ivmodel$Zadj), esti$sigmau, esti$sigmav, esti$rho, alpha, deltarange, delta))
  }
  print("Input error.")
  return(NULL)
}


library(tidyverse)
source("./lib/parse_input.r")
source("./lib/results_output.r")
source("./lib/perceptron.r")

inputData <- read_csv("./data/iris.csv")

# Save scatterplot matrix of descriptive features
pdf("iris_scatterplot_matrix_rplot.pdf")
dev.cur()
pairs(inputData[,1:4], pch=12)
dev.off()

# Split input sample into train and test data
ss <- split_sample(inputData)

node_num <- 50
epoch <- 300
threshold_limit <- 0.5

# Initialize inputs for perceptron class
nn_train <- perceptron(ss@xtrain, ss@ytrain, node_num)

# Iterate through neural network using feedforward and backpropagation methods
for( i in 1:epoch){
  nn_train <- feedforward(nn_train)
  nn_train <- backprop(nn_train)
}

# results_table will reveal is neural net has successfully been trained
yhat_train_result <- threshold(nn_train@yhat_train, 0.5)
results_df_train <- results_table(nn_train@yhat_train, yhat_train_result, ss@ytrain)

# neural net can now be run on test data
results_test <- result(ss@xtest, nn_train@w1, nn_train@w2)
yhat_test_result <- threshold(results_test, 0.5)
results_df_train <- results_table(results_test, yhat_test_result, ss@ytest)


#' Create polygon from point
#'
#' Covert latitude and longitude plus a radius into a WKT string.
#'
#' @param latitude numeric
#' @param longitude numeric
#' @param radius numeric, distance in meters
#' @return Polygon as a WKT string
#' @import sp
#' @import rgeos
#' @import rgdal
#' @export
#' @examples
#'
#' rnbn::createWKT(51.6011023, -1.1278673, 1000)

createWKT <- function(latitude, longitude, radius = 5000){

    if(!is.numeric(radius)) stop('radius must be numeric (meters)')
    if(!is.numeric(latitude) | !is.numeric(longitude)) stop('latitude and longitude must be numeric')

    p <- SpatialPointsDataFrame(coords = data.frame(lon = longitude, lat = latitude),
                                data.frame(ID = 1),
                                proj4string = CRS("+proj=longlat +ellps=WGS84 +datum=WGS84"))
    stopifnot(length(p) == 1)
    cust <- sprintf("+proj=tmerc +lat_0=%s +lon_0=%s +k=1 +x_0=0 +y_0=0 +ellps=WGS84 +towgs84=0,0,0,0,0,0,0 +units=m +no_defs",
                    p@coords[[2]], p@coords[[1]])
    projected <- spTransform(p, CRS(cust))
    buffered <- gBuffer(projected, width = radius, byid = TRUE)
    bufferedOrg <- spTransform(buffered, p@proj4string)
    writeWKT(bufferedOrg)

}


# load sparse matrix package
suppressPackageStartupMessages(library('Matrix'))

# access a numeric column
get_numeric <- function(table, column_key) {
    column <- as.numeric(column_key)
    column_data <- suppressWarnings(as.numeric(as.character(table[column][[1]])))
    return (c(column_data))
}

# access a label column
get_label <- function(table, column_key) {
    column <- as.numeric(column_key)
    column_data <- as.character(table[column][[1]])
    return (c(column_data))
}

# inflate three columns into matrix
matrify <- function (data) {
    if (ncol(data) != 3)
        stop('Data frame must have three column format')
    plt <- data[, 1]
    spc <- data[, 2]
    abu <- data[, 3]
    plt.codes <- levels(factor(plt))
    spc.codes <- levels(factor(spc))
    taxa <- Matrix(0, nrow=length(plt.codes), ncol=length(spc.codes), sparse=TRUE)
    row <- match(plt, plt.codes)
    col <- match(spc, spc.codes)
    for (i in 1:length(abu)) {
        taxa[row[i], col[i]] <- abu[i]
    }
    colnames(taxa) <- spc.codes
    rownames(taxa) <- plt.codes
    taxa
}

# flatten data.frame into three column format
flatten <- function(my_matrix) {
    summ <-summary(my_matrix)
    summ <- data.frame(i=rownames(my_matrix)[summ$i], j=colnames(my_matrix)[summ$j], x=summ$x)
    summ
}

# wrapper
wrapper <- function(table, columns, options) {

    # initialize output list
    l <- list()

    # get number of columns
    n = length(columns)

    # consistency check
    if (n %% 3 != 0) {
        print ('heatmap::wrapper() - Data not consistent (n mod 3 != 0)')
        return (l)
    }

    # create index sequence
    index = seq(1, n, by=3)

    # get keys
    keys = names(columns)

    # loop through blocks
    for (i in index) {
        # create columns
        ci <- get_label(table, columns[keys[i]])
        cj <- get_label(table, columns[keys[i+1]])
        cx <- get_numeric(table, columns[keys[i+2]])

        # create a frame from columns
        my_frame <- data.frame(ci=ci, cj=cj, cx=cx)

        # create matrix out of the frame
        my_matrix <- matrify(my_frame)

        # create/cluster matrix
        row_order <- hclust(dist(my_matrix))$order
        col_order <- hclust(dist(t(my_matrix)))$order

        # reorder matrix
        my_matrix <- my_matrix[row_order, col_order]

        # transform back to three columns
        my_flatmatrix = flatten(my_matrix)

        # append to result list
        l <- append(l, list(my_flatmatrix$i))
        l <- append(l, list(my_flatmatrix$j))
        l <- append(l, list(my_flatmatrix$x))
    }

    # return
    return (l)
}


pdf('SRR4238379_subsamp.sorted.rseqc.junctionSaturation_plot.pdf')
x=c(5,10,15,20,25,30,35,40,45,50,55,60,65,70,75,80,85,90,95,100)
y=c(10,21,26,31,32,32,36,37,37,38,40,41,44,45,47,47,52,55,56,57)
z=c(13,24,29,35,36,36,41,43,45,46,48,49,52,54,56,56,62,65,66,67)
w=c(3,3,3,4,4,4,5,6,8,8,8,8,8,9,9,9,10,10,10,10)
m=max(0,0,0)
n=min(0,0,0)
plot(x,z/1000,xlab='percent of total reads',ylab='Number of splicing junctions (x1000)',type='o',col='blue',ylim=c(n,m))
points(x,y/1000,type='o',col='red')
points(x,w/1000,type='o',col='green')
legend(5,0, legend=c("All junctions","known junctions", "novel junctions"),col=c("blue","red","green"),lwd=1,pch=1)
dev.off()


library(RJSONIO)
source("model_fitting.r")
source("visualization.r")

timestamp = "202005161202"
bootstrap_params = list(
  "number_samples" = 1000,
  "window_size" = 10,
  "confidence" = 0.95
)

# obtain bootsrap samples for I
model = fromJSON(paste("tuned", timestamp, "model.json", sep="/"))
load("CasosAjustados_Diagnostico.Rda")
observed_I = data$`Estimados Totales`
observed_I = c(observed_I[1], 0, tail(observed_I, -1))
expected_I = get_expected_I(model$beta, model$N0, model$lambda)
b_samples = bootstrap_samples(expected_I, observed_I,
                              bootstrap_params$number_samples,
                              bootstrap_params$window_size)

# estimate beta at each
params = fromJSON(paste("tuned", timestamp, "params.json", sep="/"))
beta0 = read.table("BetaInitials.txt", quote="\"", comment.char="")$V1
params$beta0 = beta0
out_file = paste("tuned", timestamp, "bootstrapped_R.csv", sep="/")
for (i in 1:nrow(b_samples)) {
  bootstrapped_I = as.numeric(b_samples[i,])
  boot_model = fit(bootstrapped_I, beta0=beta0, beta_min=params$beta_min,
                   beta_max=params$beta_max, lambda0=params$lambda0,
                   lambda_min=params$lambda_min, lambda_max=params$lambda_max,
                   alpha=params$alpha)
  row = data.frame(t(boot_model$beta / boot_model$lambda))
  row["lambda"] = boot_model$lambda
  write.table(row, file=out_file, append = TRUE, row.names = FALSE)
}

# plot the R series with confidence intervals
b_samples = read.table(out_file, header=TRUE)
b_samples$lambda = NULL
# plot_I_intervals(model$beta, model$beta, b_samples, confidence=bootstrap_params$confidence)
plot_I_intervals(model$beta / model$lambda, model$beta / model$lambda, b_samples, confidence=bootstrap_params$confidence)


## From Nicholas Stroustrup nicholas_stroustrup@hms.harvard.edu
require(rms)
deaths = Surv(c(1,2,3,4,5,6),c(1,0,1,1,0,1))
cg = as.factor(as.character(c(1,1,1,0,0,0)))
bj(deaths ~ cg)


 ZGGES Example Program Results

 Generalized Eigenvalues
  1   (  3.00, -9.00)
  2   (  4.00, -5.00)
  3   (  2.00, -5.00)
  4   (  3.00, -1.00)