######### internal functions #########

##' @title tss
##'
##' @param x count matrix (each OTU in one row)
##' @description Calculate the relative abundances by dividing the total abundance (Total Sum Sacling)
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
tss <- function(x){ apply(x, 2, function(x) x/sum(x)) }

##' @title css
##'
##' @param m matrix of data (variables in columns, measurements in rows)
##' @param p quantile used for normalization (default: 0.5)
##' @description Function to perform cumulative sum scaling (CSS)
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
css <- function(m, p=0.5){
  m[m==0] <- NA
  ## find the quantile in each sample
  quant <- apply(m,1,function(x) quantile(x, p=p, na.rm = TRUE))
  ## calculate normalization factor
  f <- rowSums(m*sweep(m, 1, quant, '<='),na.rm = TRUE)
  nf <- f/exp(mean(log(f)))
  dat.css <- sweep(m,1,nf, '/')
  return(list("normCounts" = dat.css, "normFactors"=nf))
}

##' @title infer
##'
##' @param Y response
##' @param X predictors
##' @param method blasso or lm
##' @param intercept whether to include the intercept
##' @param seed seed
##' @param alpha the alpha parameter for elastic net (1:lasso [default], 0:ridge)
##' @param lambda.init user provides initial lambda values
##' @param lambda.choice 1: use lambda.1se for LASSO, 2: use lambda.min for LASSO, a number between (0, 1): this will select a lambda according to (1-lambda.choice)*lambda.min + lambda.choice*lambda.1se
##' @param nfolds number of folds for glmnet cross-validation
##' @import glmnet
##' @description Infer parameters with blasso
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
infer <- function(Y, X, method='glmnet', intercept=FALSE, seed=0, alpha=1, nfolds=5,
                  lambda.init=NULL, lambda.choice=1){
  lambda.lower <- 1e-9
  lambda.upper <- 1
  set.seed(seed)
  if(method=='lm'){
    return(as.numeric(coef(lm(Y~X+0))))
  }
  if(method=='glmnet'){
    penalty <- c(0,rep(1, ncol(X)-1))
    maxmin <- median(Y) + 5 * IQR(Y) %*% c(1,-1)
    idx <- Y <= maxmin[1] & Y >= maxmin[2]
    if(is.null(lambda.init)){
      ## select a lambda range first
      lambda.init <- rev(exp(seq(log(lambda.lower), log(lambda.upper), length.out = 50)))
      fit <- cv.glmnet(X[idx,], Y[idx], intercept=intercept, lambda=lambda.init, nfolds=nfolds,
                       penalty.factor=penalty, alpha=alpha)
      lambda <- rev(exp(seq(
        max(log(fit$lambda.min/10), log(lambda.lower)),
        min(log(fit$lambda.min*10), log(lambda.upper)),
        length.out = 50)))
    }else{
      ## adjust lambda by up to 50%
      lambda <- rev(exp(seq(
        max(log(lambda.init/2), log(lambda.lower)), ## bounded by the min lambda
        min(log(lambda.init*1.5), log(lambda.upper)), ## bounded by the max lambda
        length.out = 20)))
    }

    fit <- cv.glmnet(X[idx,], Y[idx], intercept=intercept, lambda=lambda,  nfolds=nfolds,
                     penalty.factor=penalty, alpha=alpha)
    if(lambda.choice == 1){
      s = fit$lambda.1se
    }else if(lambda.choice == 2){
      s = fit$lambda.min
    }else{
      s = (1-lambda.choice)*fit$lambda.min + lambda.choice*fit$lambda.1se
    }
    coefs <- coef(fit, s=s)[-1]
    e <- as.numeric((Y-(X %*% coefs)[,1]))
    rm(.Random.seed, envir=.GlobalEnv)
    return(c(coefs, e, s))
  }
}

# ##' @title boot_stat
# ##'
# ##' @param data data in the format of cbind(Y, X)
# ##' @param indices indices for bootstrapping
# ##' @description bootstrapping the inference process
# ##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
# bs <- function(data, indices) {
#     X_s <- data[indices, -1] # allows boot to select sample
#     Y_s <- data[indices, 1]
#     fit <- infer(Y_s, X_s)
#     return(fit[1:ncol(X_s)])
# }

# ##' @title func.E.boot
# ##'
# ##' @param dat.tss relative abundances matrix (each OTU in one row)
# ##' @param sample.filter filter out samples contain outliers in Y
# ##' @param m estimated biomass values
# ##' @param ncpu number of CPUs (default: 4)
# ##' @importFrom boot boot
# ##' @importFrom doParallel registerDoParallel
# ##' @import foreach
# ##' @description bootstrapped E-step
# ##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
# func.E.boot <- function(dat.tss, m, sample.filter, ncpu=4, ...){
#     registerDoParallel(ncpu)
#     p <- nrow(dat.tss)
#     res <- foreach(i=1:p, .combine=rbind) %do% {
#         message(paste0("Bootstrapping for species ", i))
#         fil <- dat.tss[i,]!=0 & !sample.filter[i,]
#         X <- t(rbind(1/m, dat.tss[-i,])[,fil])
#         Y <- dat.tss[i, fil]
#         theta <- rep(0, p+1)
#         stab <- rep(1, p)
#         theta[i+1] <- -1 ## -beta_{ii}/beta_{ii}
#         tmp <- boot(data=cbind(Y,X), statistic=bs, R=100)
#         theta[-(i+1)] <- apply(tmp$t, 2, median)
#         stab[-(i)] <- (colSums(tmp$t!=0)/tmp$R)[-1]
#         c(theta, stab)
#     }
#     list(a=res[,1], b=postProcess(res[,1:p+1]), stab=res[,(p+2):ncol(res)])
# }

# ##' @title func.E.stab
# ##'
# ##' @param dat.tss relative abundances matrix (each OTU in one row)
# ##' @param sample.filter filter out samples contain outliers in Y
# ##' @param m estimated biomass values
# ##' @param ncpu number of CPUs (default: 4)
# ##' @param perc percentage of samples to take for each iteration
# ##' @param niter number of iterations to run
# ##' @param ... additional parameters for beemStatic:::infer
# ##' @importFrom doParallel registerDoParallel
# ##' @import foreach
# ##' @description E-step with subsampling to estimate stability
# ##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
# func.E.stab <- function(dat.tss, m, sample.filter, ncpu=4, perc=0.6, niter=100, ...){
#   registerDoParallel(ncpu)
#   p <- nrow(dat.tss)
#   res <- foreach(i=1:p, .combine=rbind) %do% {
#     message(paste0("Resampling for species ", i))
#     fil <- dat.tss[i,]!=0 & !sample.filter[i,]
#     X <- t(rbind(1/m, dat.tss[-i,])[,fil])
#     Y <- dat.tss[i, fil]
#     theta <- rep(0, p+1)
#     stab <- rep(1, p)
#     theta[i+1] <- -1 ## -beta_{ii}/beta_{ii}
#     tmp <- (sapply(1:niter, function(x) sub_stat(data=cbind(Y,X), perc) ))
#     theta[-(i+1)] <- apply(tmp, 1, median)
#     stab[-(i)] <- (rowSums(tmp!=0)/niter)[-1]
#     c(theta, stab)
#   }
#   list(a=res[,1], b=postProcess(res[,1:p+1]), stab=res[,(p+2):ncol(res)])
# }

# ##' @title sub_stat
# ##'
# ##' @param data data in the format of cbind(Y, X)
# ##' @param perc percentage of samples to take for each iteration
# ##' @param ... additional parameters for beemStatic:::infer
# ##' @description Resampling for the inference process
# ##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
# sub_stat <- function(data, perc, ...) {
#   n <- nrow(data)
#   indices <- sample(1:n, n*perc)
#   X_s <- data[indices, -1]
#   Y_s <- data[indices, 1]
#   fit <- infer(Y_s, X_s)
#   return(fit[1:ncol(X_s)])
# }

##' @title norm
##'
##' @param a estimated growth rate values (scaled by self-interaction)
##' @param b estimated interaction matrix (scaled by self-interaction)
##' @param c estimated external perturbation effect matrix (scaled by self-interaction) (default: NULL)
##' @param s external perturbation presence vector in one sample
##' @param x relative abundances in one sample
##' @description estimate biomass with linear regression
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
norm <- function(a, b, c = NULL, s = NULL, x){
  if (!is.null(c) || !is.null(s)) {
    perturbation.eff <- c %*% s
    res <- -(a + perturbation.eff) / (b %*% x)
  } else {
    res <- -a / (b %*% x)
  }
  res <- res[x!=0]
  if(all(res < 0)){
    m <- abs(max(res))
  } else{
    m <- median(res[res>0])
  }
  if (!is.null(c) || !is.null(s)) {
    err <- (m * (b %*% x) + a + perturbation.eff)[,1]/a
  } else {
    err <- (m * (b %*% x) + a)[,1]/a
  }
  err[x==0] <- 0
  c(m, err)

}

##' @title entropy
##'
##' @param v a vector input (treated as binary, i.e. zero/non-zero)
##' @description Compute the entropy of a binary vector
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
entropy <- function(v){
  p <- sum(v == 0)/length(v)
  ifelse(p==0 || p==1, 0, -(p*log2(p) + (1-p)*log2(1-p)) )
}

##' @title func.E
##'
##'
##' @param dat.tss relative abundances matrix (each OTU in one row)
##' @param external.perturbation external perturbation presence matrix *1/m (each perturbation in one row, each sample in one column) (Default: NULL)
##' @param sample.filter filter out samples contain outliers in Y
##' @param lambda.inits initial lambda values
##' @param m estimated biomass values (1 X no. of samples) matrix
##' @param ncpu number of CPUs (default: 4)
##' @param center center data or not
##' @param ... additional parameters for `beemStatic::infer`
##' @importFrom doParallel registerDoParallel
##' @import foreach
##' @description E-part of BEEM, estimate model parameters with inferred m
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
func.E <- function(dat.tss, external.perturbation = NULL, m, sample.filter, lambda.inits=NULL, ncpu=4, center=FALSE, ...){
  ## infer parameter for each OTU
  registerDoParallel(ncpu)
  p <- nrow(dat.tss)
  if (!is.null(external.perturbation)) {
    k <- nrow(external.perturbation) #Number of external perturbations
  }
  res <- foreach(i=1:p, .combine=rbind) %dopar% {
    fil <- dat.tss[i,]!=0 & !sample.filter[i,]
    X <- t(rbind(1/m, dat.tss[-i,])[,fil])
    Y <- dat.tss[i, fil]
    if(center){
      Y <- Y-mean(Y)
      X <- X-rowMeans(X)
    }
    theta <- rep(0, p+1)
    theta[i+1] <- -1 ## -beta_{ii}/beta_{ii}
    if (!is.null(external.perturbation)) {
      perturbation.coefficients <- rep(0, k) #Creating a vector to store perturbation coefficients
      external.perturbation.filtered <- external.perturbation[,fil] #Filtering out the external perturbations corresponding to samples which were filtered out
      X <- cbind(X, t(external.perturbation.filtered))
    }

    tmp <- infer(Y,X, lambda.init=lambda.inits[i], ...)

    if (!is.null(external.perturbation)) {
      theta[-(i+1)] <- tmp[1:p]
      perturbation.coefficient <- tmp[seq(p+1,p+k)]
      e <- rep(NA, ncol(dat.tss))
      e[fil] <- tmp[(p+k+1):(length(tmp)-1)]
      lambda <- tmp[length(tmp)]
      c(theta, perturbation.coefficient, e, lambda)
    } else {
      theta[-(i+1)] <- tmp[1:p]
      e <- rep(NA, ncol(dat.tss))
      e[fil] <- tmp[(p+1):(length(tmp)-1)]
      lambda <- tmp[length(tmp)]
      c(theta, e, lambda)
    }
  }

  ## check if there is not enough information
  uncertain <- foreach(i=1:p, .combine=rbind) %dopar% {
    fil <- dat.tss[i,]!=0
    X <- dat.tss[, fil]
    apply(X, 1, entropy)
    ## abs(rowSums(X!=0)/ncol(X) - 0.5) ## non-zero entries
  }
  if (!is.null(external.perturbation)) {
    list(a=res[,1], b=postProcess_species(res[,1:p+1]),
         perturbation.coefficients = postProcess_perturbation(matrix(res[,seq(p+2,p+k+1)], ncol = k), res[,1]),
         e=res[,(p+k+2):(ncol(res)-1)],
         uncertain=uncertain, lambdas=res[,ncol(res)])
  } else {
    list(a=res[,1], b=postProcess_species(res[,1:p+1]), e=res[,(p+2):(ncol(res)-1)],
         uncertain=uncertain, lambdas=res[,ncol(res)])
  }
}

##' @title func.M
##'
##' @param dat.tss relative abundance matrix (each OTU in one row)
##' @param a estimated growth rate values (scaled by self-interaction)
##' @param b estimated interaction matrix (scaled by self-interaction)
##' @param c estimated external perturbation effect matrix (scaled by self-interaction)
##' @param perturbation.presence estimated external perturbation presence (not to be multiplied by 1/m) (each perturbation in one row, each sample in one column)
##' @param ncpu number of CPUs (default: 4)
##' @importFrom doParallel registerDoParallel
##' @import foreach
##' @description M-part of BEEM, estimate biomass with inferred model parameters
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
func.M <- function(dat.tss, a, b, c = NULL, perturbation.presence=NULL, ncpu=4){
  registerDoParallel(ncpu)
  foreach(i=1:ncol(dat.tss), .combine=rbind) %dopar%{
    x <- dat.tss[,i]
    if (!is.null(c) || !is.null(perturbation.presence)) {
      s <- perturbation.presence[,i]
      norm(a, b, c = c, s = s, x)
    } else {
      norm(a, b, c = NULL, s = NULL, x)
    }
  }
}

##' @title preProcess
##'
##' @param dat OTU count/relative abundance matrix (each OTU in one row)
##' @param dev dev * IQR from median will be filtered out (default: 0, nothing to remove)
##' @description pre-process data
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
preProcess <- function(dat, dev=0){
  ## filter out species abundances that are too low
  detection_limit <- 1e-4
  dat <- tss(dat)
  dat[dat<detection_limit] <- 0
  ##rowMed <- apply(dat, 1, function(x) median(x[x!=0]))
  ##rowIQR <- apply(dat, 1, function(x) IQR(x[x!=0]))
  rowMAD <- apply(dat, 1, function(x) mad(x[x!=0]))
  ## too close to zero
  sample.filter <- dat/rowMAD < dev
  return(list(tss=dat, sample.filter=sample.filter))
}

##' @title postProcess_species
##'
##' @param b scaled interaction matrix (diagonal/self-interaction is -1)
##' @param dev scale of the interaction < dev * 1, the value will be set to 0
##' @description post-process parameters to remove small entries
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
postProcess_species <- function(b, dev=1e-5){
  b[abs(b)<dev] <- 0
  b
}

##' @title postProcess_perturbation
##'
##' @param b scaled perturbation matrix (comparing to growthrate)
##' @param dev scale of the interaction < dev * 1, the value will be set to 0
##' @description post-process parameters to remove small entries
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
postProcess_perturbation <- function(c, growth.rate, dev=1e-5){
  c[abs(c/growth.rate)<dev] <- 0
  c
}

##' @title formatOutput
##' @importFrom reshape2 melt
##' @param a scaled growth rates
##' @param b scaled interaction matrix
##' @param c scaled external perturbation matrix (default: NULL)
##' @param vnames species names
##' @param pnames external perturbation names (default: NULL)
##' @description Function to convert parameter vector a and matrix b to MDSINE's output format
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
formatOutput <- function(a, b, c = NULL, vnames, pnames = NULL){
  p <- length(a)
  param <- data.frame(parameter_type=c(rep("growth_rate",p), rep("interaction",p*p)))
  param$source_taxon <- c(rep(NA,p),rep(vnames, each = p))
  param$target_taxon <- vnames
  param$value <- 0
  param$significance <- NA
  tmp.b <- melt(t(b))
  tmp.b <- tmp.b[order(tmp.b$Var1),]
  param$value <- c(a, tmp.b$value)
  if (!is.null(c) || !is.null(pnames)) {
    q <- ncol(c) #Finding the number of external perturbationss
    ext.perturb <- data.frame(parameter_type=c(rep("external perturbations", p*q)))
    ext.perturb$source_taxon <- c(rep(NA, p*q))
    ext.perturb$target_taxon <- vnames
    ext.perturb$value <- 0
    ext.perturb$significance <- NA
    tmp.c <- melt(c)
    ext.perturb$value <- c(tmp.c$value)
    param <- rbind(param, ext.perturb)
  }
  param$external_perturbation <- c(rep(NA,p), rep(NA,p*p), rep(pnames, each = p)) #Creating the vector for external perturbations
  param

}

##' @title detectBadSamples
##'
##' @param err the errors estimated from regression
##' @param threshold threshold to filter out samples
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
detectBadSamples <- function(err, threshold){
  score <- (err - median(err, na.rm = TRUE))/IQR(err, na.rm = TRUE)
  score[is.na(score)] <- Inf
  return(score > threshold)
}

######### Exported functions #########

##' @title beem2param
##'
##' @param beem a BEEM object
##' @description extract parameter estimates from a BEEM object
##' @export
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
beem2param <- function(beem){
  p <- ncol(beem$err.m) #Number of species
  num.perturb <- (nrow(beem$trace.p) - p - p*p)/p
  tmp <- beem$trace.p[, ncol(beem$trace.p)]
  a.est <- tmp[1:p]
  b.est <- matrix(tmp[-c(1:p)], p, p)
  if (num.perturb == 0) {
    return (list(a.est=a.est, b.est=b.est))
  } else {
    c.est <- matrix(tmp[(nrow(beem$trace.p) - (num.perturb*p - 1)):nrow(beem$trace.p)],
                    ncol = num.perturb)
    return (list(a.est=a.est, b.est=b.est, c.est=c.est))
  }
}

##' @title beem2biomass
##'
##' @param beem a BEEM object
##' @description extract biomass estimates from a BEEM object
##' @export
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
beem2biomass <- function(beem){
  niter <- ncol(beem$trace.m)
  return (beem$trace.m[,niter])
}

##' @title func.EM
##'
##' @param dat OTU count/relative abundance matrix (each OTU in one row)
##' @param external.perturbation external perturbation presence matrix (each perturbation in one row, each sample in one column) (Default: NULL)
##' @param ncpu number of CPUs (default: 4)
##' @param scaling a scaling factor to keep the median of all biomass constant (default: 1000)
##' @param dev deviation of the error (for one sample) from the model to be excluded (default: Inf - all the samples will be considered)
##' @param m.init initial biomass values (default: use CSS normalization)
##' @param max.iter maximal number of iterations (default 30)
##' @param warm.iter number of iterations to run before removing any samples and stop adjusting lambda (default: run until convergence and start to remove samples)
##' @param lambda.choice 1: use lambda.1se for LASSO, 2: use lambda.min for LASSO, a number between (0, 1): this will select a lambda according to (1-lambda.choice)*lambda.min + lambda.choice*lambda.1se
##' @param resample number of iterations to resample the data to compute stability of the interaction parameters (default: 0 - no resampling)
##' @param alpha the alpha parameter for the Elastic Net model (1-LASSO [default], 0-RIDGE)
##' @param refresh.iter refresh the removed samples every X iterations (default: 1)
##' @param epsilon convergence threshold (in relative difference): uqn of the relative error in biomass changes (default 1e-3)
##' @param verbose print out messages
##' @param debug output debugging information (default FALSE)
##' @description Iteratively estimating scaled parameters and biomass
##' @export
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
func.EM <- function(dat, external.perturbation = NULL, ncpu=4, scaling=1000, dev=Inf, m.init=NULL,
                    max.iter=30, warm.iter=NULL, lambda.choice=1, resample=0,
                    alpha=1, refresh.iter=1, epsilon=1e-3,
                    debug=FALSE, verbose=TRUE){

  ## pre-processing
  dat.init <- preProcess(dat, dev=0)
  dat.tss <- dat.init$tss
  spNames <- rownames(dat)

  ## ensure valid samples
  temp <- colSums(dat.tss, na.rm = TRUE) == 0
  if(any(temp)){
    stop(paste0('Sample ', which(temp), ' has zero total abudance...'))
  }

  ## initialization
  sample.filter.iter <- dat.init$sample.filter
  tmp <- css(t(dat.tss))$normFactors
  if(is.null(m.init)) {
    m.iter <- scaling * tmp/median(tmp)
  }else{
    m.iter <- scaling * m.init/median(m.init)
  }
  trace.m <- matrix(m.iter)
  trace.p <- apply(expand.grid(spNames, spNames), 1, function(x) paste0(x[2], '->', x[1]))
  trace.p <- c(paste0(NA, '->',spNames), trace.p)
  if (!is.null(external.perturbation)) {
    external.perturbation.Names <- rownames(external.perturbation)
    trace.p.external.perturbation <- apply(expand.grid(spNames, external.perturbation.Names), 1, function(x) paste0(x[2], '->', x[1]))
    trace.p <- append(trace.p, trace.p.external.perturbation)
  }
  trace.p <- data.frame(name=trace.p)
  trace.lambda <- data.frame(spNames)
  lambda.inits <- NULL
  ## flags
  remove_non_eq <- FALSE
  removeIter <- 0

  ## constants
  m1 <- matrix(rep(1,nrow(sample.filter.iter)))
  ## EM
  for(iter in 1:max.iter){
    if(verbose) message(paste0("############# Run for iteration ", iter,": #############"))
    if(verbose) message("E-step: estimating scaled parameters...")
    if(iter>=2) lambda.inits <- lambdas
    if(is.null(external.perturbation)){
      ext.pert <- NULL
    }else{
      ext.pert <- 1/m.iter * external.perturbation
    }
    tmp.p <- func.E(dat.tss, external.perturbation = ext.pert,
                    m.iter, sample.filter.iter, ncpu=ncpu, method='glmnet',
                    lambda.inits=lambda.inits, alpha=alpha)
    err.p <- tmp.p$e
    lambdas <- tmp.p$lambdas
    uncertain <- tmp.p$uncertain
    if(debug){
      print(rowSums(tmp.p$b!=0))
      plot(1-rowMeans(err.p^2, na.rm = TRUE)/apply(dat.tss[,], 1, function(x) var(x[x!=0], na.rm=TRUE) ))
      ##abline(h=0.5)
    }

    if(verbose) message("M-step: estimating biomass...")
    if (!is.null(external.perturbation)) {
      tmp.m <- func.M(dat.tss, tmp.p$a, tmp.p$b, c = tmp.p$perturbation.coefficients, perturbation.presence = external.perturbation, ncpu)
    } else {
      tmp.m <- func.M(dat.tss, tmp.p$a, tmp.p$b, c = NULL, perturbation.presence = NULL, ncpu)
    }
    m.iter <- tmp.m[,1]
    err.m <- tmp.m[,-1]

    if(remove_non_eq){
      ## clear up removed samples every X iterations
      if (iter %% refresh.iter == 0 ) {
        sample.filter.iter <- dat.init$sample.filter
      }
      bad.samples <- detectBadSamples(apply(err.p^2, 2, median, na.rm = TRUE), dev)
      sample.filter.iter <- (m1 %*% bad.samples)>0  | sample.filter.iter
      if(verbose) message(paste0("Number of samples removed (detected to be non-static): ",
                                 sum(colSums(sample.filter.iter)>0)))
      removeIter <- removeIter + 1
    }
    m.fil <- colSums(sample.filter.iter)==0
    m.iter <- m.iter*scaling/median(m.iter[m.fil], na.rm=TRUE)
    trace.m <- cbind(trace.m, m.iter)
    if (!is.null(external.perturbation)) {
      trace.p <- cbind(trace.p, formatOutput(tmp.p$a, tmp.p$b, c = tmp.p$perturbation.coefficients,
                                             spNames, pnames = external.perturbation.Names)$value)
    } else {
      trace.p <- cbind(trace.p, formatOutput(tmp.p$a, tmp.p$b, c = NULL, spNames, pnames = NULL)$value)
    }

    trace.lambda <- cbind(trace.lambda, lambdas)
    summary.m <- apply(trace.m[m.fil, ], 1, function(x) median(rev(x)[1:min(5,length(x))]))
    #criterion <- quantile(abs((trace.m[m.fil, iter+1] - summary.m)/summary.m), 1)<epsilon
    criterion <- median(abs((trace.m[m.fil, iter+1] - trace.m[m.fil, iter])/trace.m[m.fil, iter]))<epsilon #0.0025

    if (!is.null(warm.iter) && iter > warm.iter && !remove_non_eq){
      if(verbose) message("Start to detect and remove bad samples...")
      remove_non_eq <- TRUE
    }
    if (iter > 5 && !remove_non_eq && criterion && is.finite(dev)) {
      if(verbose) message("Converged and start to detect and remove bad samples...")
      remove_non_eq <- TRUE
    }
    if (((removeIter > 5 && remove_non_eq) || is.infinite(dev)) && criterion) {
      if(verbose) message("Converged!")
      break
    }
  }
  res.resample <- NULL

  if(resample!=0){
    if(verbose) message("Estimating stability...")
    ##res.resample <- func.E.stab(dat.tss, m.iter, sample.filter.iter, ncpu=ncpu, alpha=alpha)
    if (!is.null(external.perturbation)) {
      res.resample <- resample.EM(dat[, m.fil], external.perturbation = external.perturbation[, m.fil], m=m.iter[m.fil],
                                  perc=0.6, res.iter=resample,
                                  ncpu=ncpu, scaling=scaling, dev=dev, refresh.iter=refresh.iter, alpha=alpha,
                                  max.iter=20, warm.iter=0, resample=0, debug=FALSE, verbose=FALSE)
    } else {
      res.resample <- resample.EM(dat[, m.fil], external.perturbation = NULL, m=m.iter[m.fil],
                                  perc=0.6, res.iter=resample,
                                  ncpu=ncpu, scaling=scaling, dev=dev, refresh.iter=refresh.iter, alpha=alpha,
                                  max.iter=20, warm.iter=0, resample=0, debug=FALSE, verbose=FALSE)
    }
    res.resample$a.summary <- apply(res.resample$res.a, 1, median)
    res.resample$b.summary <- matrix(apply(res.resample$res.b, 1, function(x) median(x)), nrow(dat))
    res.resample$b.stab <- matrix(rowSums(res.resample$res.b != 0)/ncol(res.resample$res.a), nrow(dat))
    if (!is.null(external.perturbation)) {
      res.resample$c.summary <- apply(res.resample$res.c, 1, function(x) median(x))
      res.resample$c.stab <- matrix(rowSums(res.resample$res.c != 0)/ncol(res.resample$res.a), nrow(dat))
    }
  }
  list(trace.m=trace.m, trace.p=trace.p, err.m=err.m, err.p=err.p,
       b.uncertain = uncertain, trace.lambda=trace.lambda,
       resample=res.resample,
       dev=dev,
       sample2rm = which(!m.fil))
}

##' @title resample.EM
##'
##' @param data data in the format of cbind(Y, X)
##' @param external.perturbation external perturbation presence matrix (each perturbation in one row, each sample in one column) (Default: NULL)
##' @param m biomass initialization
##' @param perc percentage of samples to take for each iteration
##' @param res.iter number of resample iteration
##' @param ... additional parameters for beemStatic::func.EM
##' @description Resampling for the inference process
##' @export
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
resample.EM <- function(data, external.perturbation = NULL, m, perc, res.iter, ...) {
  n <- ncol(data)
  p <- nrow(data)
  res_p <- data.frame(matrix(NA, p*(p+1), res.iter))
  res_m <- data.frame(matrix(NA, n, res.iter))

  for(i in 1:res.iter){
    message(paste0("#### Resample iteration: ", i, " #####"))
    indices <- sort(sample(1:n, n*perc))
    if (!is.null(external.perturbation)) {
      num.perturb <- nrow(external.perturbation)
      tmp <- func.EM(data[, indices], external.perturbation = external.perturbation[, indices], m.init=m[indices], ...)
    } else {
      tmp <- func.EM(data[, indices], external.perturbation = NULL, m.init=m[indices], ...)
    }
    res_p[,i] <- tmp$trace.p[, ncol(tmp$trace.p)]
    res_m[indices,i] <- tmp$trace.m[, ncol(tmp$trace.m)]
  }
  if (!is.null(external.perturbation)) {
    list(res.a = res_p[1:p,], res.b = res_p[(p+1):(nrow(res_p)-num.perturb*p),], res.c = res_p[(nrow(res_p)-num.perturb*p + 1):nrow(res_p),], res.m = res_m)
  } else {
    list(res.a = res_p[1:p,], res.b = res_p[-c(1:p),], res.m = res_m)
  }

  list(res.a = res_p[1:p,], res.b = res_p[-c(1:p),])
}

##' @title predict_beem
##'
##' @param dat.new OTU count/relative abundance matrix (each OTU in one row)
##' @param beem output of the EM algorithm
##' @param dev deviation of the error (for one sample) from the model to be excluded
##' @param ncpu number of CPUs (default: 4)
##' @param pert.new external perturbation presence matrix (each perturbation in one row, each sample in one column) (Default: NULL)
##' @importFrom doParallel registerDoParallel
##' @description Use a trained BEEM-static model to predict biomass, deviation from steady states and violation of model assumption
##' @export
##' @author Chenhao Li, Gerald Tan, Niranjan Nagarajan
predict_beem <- function(dat.new, beem, dev, ncpu=4, pert.new = NULL){
  ### currently not ready for an S3method yet
  param <- beem2param(beem)
  dat.new.tss <- tss(dat.new)
  if (!is.null(pert.new)){
    tmp.m <- func.M(dat.new.tss, param$a.est, param$b.est, c = param$c.est, perturbation.presence = pert.new, ncpu = 1)
  } else {
    tmp.m <- func.M(dat.new.tss, param$a.est, param$b.est, ncpu=ncpu)
  }
  m.pred <- tmp.m[,1]
  err.m.pred <- tmp.m[,-1]

  registerDoParallel(ncpu)
  p <- nrow(dat.new.tss)
  e <- foreach(i=1:p, .combine=rbind) %dopar% {
    X <- t(rbind(1/m.pred, dat.new.tss[-i,]))
    Y <- dat.new.tss[i, ]
    coefs <- c(param$a.est[i], param$b.est[i,-i])
    if(!is.null(param$c.est)){
        pert <- t(pert.new)
        coefs_pert <- param$c.est[i,]
        as.numeric(Y - (X %*% coefs)[,1] - (1/m.pred) * ((pert %*% coefs_pert)[,1]) )
    }else{
        as.numeric((Y - (X %*% coefs)[,1] ) )
    }
  }
  isBad <- detectBadSamples(apply(e^2, 2, median, na.rm = TRUE), dev)
  return(list(biomass.pred=m.pred, dev.from.eq=t(err.m.pred), isBad=isBad))
}


testConstantSynthesis <- function(init, synthesis, decay, minNoise = 0.5, relativeNoise = 0.2, time = seq(0,1,by = 0.1))
{
  cat(paste0("Target init: ", init, " synth: ", synthesis, " decay: ", decay , "\n"));
  testConstant = longToVal(generateConstantSynthesis(1, time, 3, init, synthesis,decay, minNoise = minNoise, relativeNoise = relativeNoise));
  testConstantSynthesisModel(testConstant, 1, 'constant-synthesis.stan');
  testConstantSynthesisModel(testConstant, 1, 'constant-synthesis-euler.stan');
  testConstantSynthesisModel(testConstant, 1, 'constant-synthesis-derivative.stan', FALSE);
}

testConstantSynthesisModel <- function(testData, sco, model, plot = TRUE)
{
  cat(paste0("Model: ", model), "\n");
  fit = fitBySco(testData, sco, model, control=list(adapt_delta = 0.98), iter = 3000);
  if(plot)
  {
    plotProfileFit(fit, testData, sco);
  }

  smmry = summary(fit)$summary;
  init_mean = smmry["init","mean"];
  init_25 = smmry["init","25%"];
  init_75 = smmry["init","75%"];
  synthesis_mean = smmry["synthesis","mean"];
  synthesis_25 = smmry["synthesis","25%"];
  synthesis_75 = smmry["synthesis","75%"];
  decay_mean = smmry["decay","mean"];
  decay_25 = smmry["decay","25%"];
  decay_75 = smmry["decay","75%"];

  cat(paste0("Init: ", init_25, " -> ", init_mean, " <- ", init_75, "\n"));
  cat(paste0("Synthesis: ", synthesis_25, " -> ", synthesis_mean, " <- ", synthesis_75, "\n"));
  cat(paste0("Decay: ", decay_25, " -> ", decay_mean, " <- ", decay_75, "\n"));
  cat("\n");
}

testConstantSynthesisModelComparison <- function(init, synthesis, decay, minNoise = 0.5, relativeNoise = 0.2, time = seq(0,1,by = 0.1))
{
  sco = 1;
  testData = longToVal(generateConstantSynthesis(sco, time, 3, init, synthesis,decay, minNoise = minNoise, relativeNoise = relativeNoise));
  compareFits(testData, sco);
}


#!/usr/bin/env Rscript

#Andrew Burt - a.burt@ucl.ac.uk

suppressMessages(library(boot))

boot_OLS_func <- function(data,indices,func)
{
	dat <- data[indices,]
	model <- fitOLS(dat,func)
	return(coefficients(model))
}

bootOLS <- function(caldata,func,runs,ncpus,pred=NULL)
{
	results <- boot(data=caldata,statistic=boot_OLS_func,R=runs,parallel="multicore",ncpus=ncpus,func=func)
	return(results)
}


# Read HadEX2 TXx temperature data (max daily max by month)
require(raster)
require(abind)
require(reshape2)
require(ncdf4)

# Read in sst climatology (guide for interpolate)
#load('temp/lstclimatology.rdata') # lstclim

# Read in HadEX2 TXx
f <- 'data_dl/hadex2/H2_TXx_1901-2010_RegularGrid_global_3.75x2.5deg_LSmask.nc'

n = nc_open(f) # Open the netCDF file
# print(n) # get information about the file format

# get data
tempsarray = ncvar_get(n, 'Jan') # January. dim order: 96 lon x 73 lat x 110 time (years). 0 lon is at Greenwich Meridian.
	# dim(tempsarray)

for(mo in 2:12){
	thismo <- ncvar_get(n, month.abb[mo])
	tempsarray <- abind(tempsarray, thismo, along=4)
}
	dim(tempsarray)
dimnames(tempsarray) <- list(lon=ncvar_get(n, 'lon'), lat=ncvar_get(n, 'lat'), time=ncvar_get(n, 'time'), mo=month.abb)

nc_close(n)

# Trim to 1986-2005
tempsarray <- tempsarray[,,86:105,]

# Reshape so lat x lon x time since start
#da2 <- aperm(tempsarray, c(2,1,3,4))
tempsmelt <- melt(tempsarray, na.rm=FALSE, value.name='txx')
tempsmelt$yrmo <- paste(substr(tempsmelt$time, 1,4), formatC(match(tempsmelt$mo, month.abb), width=2, flag='0'), sep='')
da2 <- acast(tempsmelt, lat ~ lon ~ yrmo, value.var='txx')
	dim(da2)
	dimnames(da2)

	image(da2[,,240])

# Flip so lat is 90 to -90
da2 <- da2[dim(da2)[1]:1,,]

# function to find the max in a time-series, removing NA. Returns NA if no non-missing values
maxna <- function(x) {
	if(any(!is.na(x))) return(max(x, na.rm=TRUE))
	else return(NA)
}

# find the max per grid cell
hadex2txx <- apply(da2, MARGIN=c(1,2), FUN=maxna)
	dim(hadex2txx)
	dimnames(hadex2txx)

# adjust lon grid to grid centers
dimnames(hadex2txx)[[2]] <- as.character(seq(3.75/2, 360-3.75/2, by=3.75))
	dimnames(hadex2txx)

save(hadex2txx, file='temp/hadex2_txx.rdata')

# Create raster brick
#txxb <- brick(da2)
#extent(txxb) <- c(0, 360, -90, 90)
#proj4string(txxb) <- '+proj=longlat +datum=WGS84'
#
## examine
#txxb
#plot(txxb[[240]])

# interpolate to 0.5x0.5 °
	# create new grid
#	ngrd <- expand.grid(lat=as.numeric(rownames(lstclim)), lon=as.numeric(colnames(lstclim)))
#	ngrd.sp <- ngrd[,c('lon', 'lat')]
#	coordinates(ngrd.sp) <- ~lon + lat
#	proj4string(ngrd.sp) <- '+proj=longlat +datum=WGS84'
#
#	# interpolate: raster query approach with points
#	newvalss <- extract(txxb, ngrd.sp, method='bilinear')
#	txxb05rast <- rasterFromXYZ(cbind(ngrd[,c('lon', 'lat')], newvalss))
#	proj4string(txxb05rast) <- '+proj=longlat +datum=WGS84'

# examine
#txxb05rast
#plot(txxb05rast[[240]])
#
## make array at 0.5x0.5
#txx <- as.array(txxb05rast)
#dimnames(txx) <- list(lat=as.numeric(rownames(lstclim)), lon=as.numeric(colnames(lstclim)), yrmo=dimnames(da2)[[3]])

# write out array
#save(txx, file='temp/hadex2_txx.rdata')

#############
## examine
#############
load('temp/hadex2_txx.rdata')

for(i in 1:240){
	image(t(txx[nrow(txx):1,,i]), main=dimnames(txx)[[3]][i])
	readline(prompt="Press [enter] to continue")
}


context("intersect")

A = matrix(1:4, nrow=2, ncol=2, dimnames=list(c('a','b'),c('x','y')))
C = structure(c(1L, 2L, 3L, 4L, 6L, 5L), .Dim = 2:3,
    .Dimnames = list(c("a", "b"), c("x", "y", "z")))
E = C[,c(2,3,1)]
DF = structure(list(y=3:4, z=c(6,5), x=1:2, A=c("b", "a")),
               .Names=c("y","z","x","A"), row.names=1:2, class="data.frame")
DF2 = as.data.frame(E[1,,drop=FALSE])

test_that("intersect_list vs intersect with env list", {
    AElist = intersect_list(list(A=A, E=E), along=2)

    ll = list(A=A, E=E, DF=DF)
    AEenv = intersect(A, E, along=2, envir=ll)
    expect_equal(ll$A, A)
    expect_equal(ll$E, AElist$E)
    expect_equal(ll$DF, DF)

    intersect(A, E, along=2)
    # > A         > E
    #   x y         x y   # along dimension 2, all arrays have same extent
    # a 1 3       a 1 3   # and same order of names; this function modifies
    # b 2 4       b 2 4   # values in-place

    AEref = structure(1:4, .Dim = c(2L, 2L),
        .Dimnames = list(c("a", "b"), c("x", "y")))
    expect_equal(A, AEref)
    expect_equal(E, AEref)
    expect_equal(AElist$A, AEref)
    expect_equal(AElist$E, AEref)
})

test_that("matrix, df on columns", {
    AEref = structure(1:4, .Dim = c(2L, 2L),
        .Dimnames = list(c("a", "b"), c("x", "y")))
    ADFlist = intersect_list(list(A=A, DF=DF2))

    expect_equal(ADFlist$A, AEref[1,,drop=FALSE])
    expect_equal(ADFlist$DF, DF2)

    ADFlist = intersect_list(list(A=A, DF=DF2), along=2, drop=TRUE)
    intersect(A, DF2, along=2, drop=TRUE)
    expect_equal(A, AEref)
    expect_equal(DF2, list(x=1, y=3))
    expect_equal(ADFlist$A, AEref)
    expect_equal(ADFlist$DF, DF2)
})

test_that("data.frame fields", {
    At = t(A)
    DF3 = DF
    DFref = DF[c(2,1),]

    intersect(A, DF$A, along=1)
    intersect(At, DF3$A, along=2)

    expect_is(A, "matrix")
    expect_is(DF, "data.frame")
    expect_equal(DF, DF3, DFref, tolerance=1e-5, scale=1)
    expect_true(all(DF == DFref, DF3 == DFref))

})


define_slope_weight_for_factor = function (factor_name, slope_weight) {
  paste0(slope_weight, "*", factor_name)
}

define_slope_factor <- function (factor_sets, variable_of_interest_name, slope_weights) {
  factor_names = colnames(factor_sets)
  factor_names_with_weights = mapply(define_slope_weight_for_factor, factor_names, slope_weights)
  added_factors = paste(factor_names_with_weights, collapse = " + ")
  paste0(variable_of_interest_name,"_slope =~ ",added_factors)
}


softmax <- function (x) {
    m <- max(x)
    exps <- exp(x - m)
    s <- sum(exps)
    return(exps / s)
}
score <- function(input) {
    if ((input[3]) > (3.1500000000000004)) {
        var0 <- -1.1986122886681099
    } else {
        if ((input[2]) > (3.35)) {
            var0 <- -0.8986122886681098
        } else {
            var0 <- -0.9136122886681098
        }
    }
    if ((input[3]) > (3.1500000000000004)) {
        if ((input[3]) > (4.450000000000001)) {
            var1 <- -0.09503010837903424
        } else {
            var1 <- -0.09563272415214283
        }
    } else {
        if ((input[2]) > (3.35)) {
            var1 <- 0.16640323607832397
        } else {
            var1 <- 0.15374604217339707
        }
    }
    if ((input[3]) > (1.8)) {
        if ((input[4]) > (1.6500000000000001)) {
            var2 <- -1.2055899476674514
        } else {
            var2 <- -0.9500445227622534
        }
    } else {
        var2 <- -1.2182214705715104
    }
    if ((input[4]) > (0.45000000000000007)) {
        if ((input[4]) > (1.6500000000000001)) {
            var3 <- -0.08146437273923739
        } else {
            var3 <- 0.14244886188108738
        }
    } else {
        if ((input[3]) > (1.4500000000000002)) {
            var3 <- -0.0950888159264695
        } else {
            var3 <- -0.09438233722389686
        }
    }
    if ((input[4]) > (1.6500000000000001)) {
        if ((input[3]) > (5.3500000000000005)) {
            var4 <- -0.8824095771015287
        } else {
            var4 <- -0.9121126703829481
        }
    } else {
        if ((input[3]) > (4.450000000000001)) {
            var4 <- -1.1277829563828181
        } else {
            var4 <- -1.1794405099157212
        }
    }
    if ((input[3]) > (4.750000000000001)) {
        if ((input[3]) > (5.150000000000001)) {
            var5 <- 0.16625543464258166
        } else {
            var5 <- 0.09608601737074281
        }
    } else {
        if ((input[1]) > (4.950000000000001)) {
            var5 <- -0.09644547407948921
        } else {
            var5 <- -0.08181864271444342
        }
    }
    return(softmax(c((var0) + (var1), (var2) + (var3), (var4) + (var5))))
}


library("ggpubr")
library(ggplot2)
library(reshape2)
library(cowplot)
#library(ggpmisc)

figWidth<-15
figHeight<-5
textFont<-4

#Metrics<-c("Top1","Top3","Top5","MFR","MAR")
Metrics<-c("Top1","MFR")
#Patches<-c("Total","Plausible","CleanFix","NoisyFix","NoneFix","NegFix")
Patches<-c("TotalPatch","MethodByTotal", "PlausiblePatch","MethodsByPlausible")

plot_list = list()
count=1
pdf(paste(c("../../Results/FinalResults/RQ1_2.pdf"),collapse=""), width=figWidth, height=figHeight)

for(Me in Metrics){
	for(pa in Patches){

		file_name = paste(c('./Rdata/', pa,Me,'.txt'),collapse="")

		df <- read.csv(file_name,header=FALSE,sep = " ")
		df<-t(df)
		#df<-na.omit(df)
		df<-as.data.frame(df)
		colnames(df) <- c("Metric","Patch")

		#pdf(paste(c("C:\\Users\\xia\\Desktop\\r\\",pa,Me,".pdf"),collapse=""), width=figWidth, height=figHeight)

		#p <- ggplot(df, aes(x = Plausible, y = Metric)) + geom_point()+ geom_smooth(method='lm',colour="blue",formula = y ~ x) + ggtitle("Correlation") +
		#theme(plot.title = element_text(size = 6, face = "bold"),text = element_text(size=9),axis.text=element_text(size=6)) +
		#stat_poly_eq(aes(label = paste(..eq.label..)), label.x.npc = "left", label.y.npc = "top" , formula = y ~ x, parse = TRUE, size = 1.5)

		p<-ggscatter(data=df, x = "Patch", y = "Metric", size = 1.5,
		          add = "reg.line", conf.int = TRUE,
		          cor.coef = TRUE, cor.coeff.args = list(method = "pearson",label.sep = "\n"),add.params = list(color = "black", fill = "lightgray"),
		          xlab = pa, ylab = Me,font.label = c(20, "plain")) + xscale("log10", .format = TRUE)
		plot_list[[count]] = p
		count=count+1
	}
}
# prow<-plot_grid(plot_list[[1]]+theme(legend.position="none"),
# 						plot_list[[2]]+theme(legend.position="none"),
# 						plot_list[[3]]+theme(legend.position="none"),
# 						plot_list[[4]]+theme(legend.position="none"),
# 						plot_list[[5]]+theme(legend.position="none"),
# 						plot_list[[6]]+theme(legend.position="none"),
# 						plot_list[[7]]+theme(legend.position="none"),
# 						plot_list[[8]]+theme(legend.position="none"),
# 						plot_list[[9]]+theme(legend.position="none"),
# 						#ncol = 3)
# 						#nrow = 1, align = 'h')
# 						nrow = 2, align = 'h')
prow<-plot_grid(plotlist=plot_list, nrow = 2, align = 'h')
		#legend_b <- get_legend(plot_list[[1]] + theme(legend.position=c(0.933,4.94)))
		#p <- plot_grid( prow, legend_b, ncol = 1, rel_heights = c(1, .2))
		print(prow)
		dev.off()


#################################################################################################
# Variable description
#################################################################################################
tableDescription <- function(dataVector) {
  result <- table(dataVector, useNA="always")

  resultPercentage <- (table(dataVector, useNA = "always")/sum(table(dataVector, useNA = "always")))*100

  rbind(result, resultPercentage)
}

loadTypeDependentResults <- function(dataVector) {
  if(sum(class(dataVector) %in% c("factor", "logical", "character"))>0) {
    return(tableDescription(dataVector))
  }

  if(class(dataVector) %in% c("numeric", "integer")) {
    return(data.frame(mean=mean(dataVector, na.rm=TRUE),
                      sd=sd(dataVector, na.rm=TRUE),
                      min=min(dataVector, na.rm=TRUE),
                      median=median(dataVector, na.rm=TRUE),
                      max=max(dataVector, na.rm=TRUE),
                      amountNA=sum(is.na(dataVector))))
  }
}

castVars <- function(dataFrame, castTypes) {
  columnsToCast <- which(!is.na(castTypes))
  for (i in columnsToCast) {
    if(castTypes[i]=="factor")
      dataFrame[,i] <- as.factor(dataFrame[,i])
    if(castTypes[i]=="logical")
      dataFrame[,i] <- dataFrame[,i]==1
  }

  dataFrame
}

analyzeDataFrame <- function(dataFrame, castTypes=c(NA)) {

  dataFrame <- castVars(dataFrame, castTypes)

  lapply(dataFrame, loadTypeDependentResults)
}

describeVars <- function(dataSet) {
    varNames <- colnames(dataSet)
    varNames <- varNames[!(varNames %in% "patient")]
    patients <- dataSet$patient
    setSize <- nrow(dataSet)

    #only use unique patients, if there are multiple rows for one patient, only use the 1st row.
    indices <- sapply(unique(patients), function(x) { which(patients==x)[1] })

    dataSet <- dataSet[indices,varNames]

    variableDescription <- analyzeDataFrame(dataSet)

    #made subset of varnames for categorical and numerical vars
    numericVars <- names(which(sapply(dataSet, class)=="numeric"))
    categoricalVars <- names(which(sapply(dataSet, class)!="numeric"))

    #bind all list items in one table for numerical variables
    varDescription.numerical <- do.call(rbind, variableDescription[numericVars])
    #calculate percentage NA from absolute NA numbers
    varDescription.numerical$percentageNA <- (varDescription.numerical$amountNA/nrow(dataSet))*100

    #function to enrich variable description for categorical/binary values, and to translate/rotate data.frame, creating one large data.frame
    # containing all variables and distributions
    convertVarDescription <- function(x) {
        varDesc <- variableDescription[[x]]
        colnames(varDesc)[is.na(colnames(varDesc))] <- "MISSING"
        thisTable <- as.data.frame(t(varDesc))

        thisTable$categories <- rownames(thisTable)
        thisTable$variable <- x

        thisTable
    }

    #run function described above
    variableDescription <- sapply(colnames(dataSet), convertVarDescription)
    #make one large data.frame for categorical variables
    varDescription.categories <- do.call(rbind, variableDescription[categoricalVars])
    #remove row names
    rownames(varDescription.categories) <- NULL

    list(patients=length(unique(patients)), rows=setSize, numeric=varDescription.numerical, categories=varDescription.categories)
}


# Filename: 	code.r
# Project: 	/Users/shume/Developer/stat/IntroductoryStatistics/01
# Author: 	shumez <https://github.com/shumez>
# Created: 	2019-05-25 14:06:7
# Modified: 	2019-05-25 14:21:43
# -----
# Copyright (c) 2019 shumez

# 01

require(ggplot2)
install.packages("dplyr")
require(dplyr)
library(dplyr)
install.packages("tidyr")
library(tidyr)

dir = '~/Developer/stat/IntroductoryStatistics/01'
setwd(dir)
dir_fig = file.path(dir, 'fig')

# Collaborative Exercise

dat = c(5, 5.5, 6, 6, 6, 6.5, 6.5, 6.5, 6.5, 7, 7, 8, 8, 9)
df = data.frame(SleepingTime=dat)
View(df)

p <- ggplot(df, aes(SleepingTime))
p <- p + geom_dotplot(binwidth = .5, dotsize=1)#, method = "histodot")
p %+% geom_histogram(binwidth = .5)
p <- p + labs(x='Sleeping Time')
ggsave(file.path(dir_fig,'0102.png'), width = 3, height = 3)

# 01.01.

# 01.02.
College = c('De Anza College', 'Foothill College')
FullTime = c(9200, 4059)
PartTime = c(13296, 10124)
df = data.frame(College=College, 'FullTime'=FullTime, 'PartTime'=PartTime)
View(df)

dat <- gather(df, 'category', 'number', -College)
dat$category[which(dat$category=='FullTime')] <- 'Full-time'
dat$category[which(dat$category=='PartTime')] <- 'Part-time'
dat$College <- as.character(dat$College)
dat$College[which(dat$College=='De Anza College')] <- 'De Anza'
dat$College[which(dat$College=='Foothill College')] <- 'Foothill'
View(dat)
ggplot(dat, aes(College, number, fill=category)) + geom_col()
ggsave(file.path(dir_fig, '0106.png'), width = 3, height = 3)

# 01.02.03. Variation in Data
cans = c(15.8, 16.1, 15.2, 14.8, 15.8, 15.9, 16.0, 15.5)
sd(cans)

# 01.03. Frequency, Frequency Tables, and Levels of Measurement

# 01.03.03. Frequency

StudentWorkHours = data.frame(DataValue=c(2, 3, 4, 5, 6, 7), Frequency=c(3, 5, 3, 6, 2, 1))
StudentWorkHours$RelativeFrequency = StudentWorkHours$Frequency/sum(StudentWorkHours$Frequency)
StudentWorkHours$CumulativeRelativeFrequency = rep(0, length(StudentWorkHours$RelativeFrequency))
for (i in 1:length(StudentWorkHours$RelativeFrequency)) {
  if(i == 1){
    StudentWorkHours$CumulativeRelativeFrequency[1] = StudentWorkHours$RelativeFrequency[1]
  }else{
    StudentWorkHours$CumulativeRelativeFrequency[i] = StudentWorkHours$RelativeFrequency[i] + StudentWorkHours$CumulativeRelativeFrequency[i-1]
  }
}
View(StudentWorkHours)

SoccerPlayerHeight = data.frame(height=c('59.95–61.95', '61.95–63.95', '63.95–65.95', '65.95–67.95', '67.95–69.95', '69.95–71.95', '71.95–73.95', '73.95–75.95'),
                                height_from = c(59.95, 61.95, 63.95, 65.95, 67.95, 69.95, 71.95, 73.95),
                                height_to = c(61.95, 63.95, 65.95, 67.95, 69.95, 71.95, 73.95, 75.95),
                                frequency=c(5, 3, 15, 40, 17, 12, 7, 1))
SoccerPlayerHeight$RelativeFrequency = SoccerPlayerHeight$frequency / sum(SoccerPlayerHeight$frequency)
View(SoccerPlayerHeight)


# Carregando librarys
library(ggplot2)
library(zoo)
library(lubridate)
library(stringr)
library(dplyr)

# Carregando dataset
dengue_dataset <- read.csv("~/Pessoal/tcc/casos-dengue2016.csv",
                           sep = ";")

# Fatorando o dataset em 10 linhas
three_thousand <- dengue_dataset

# Filtrando linhas que possuem data real
data_clean <- three_thousand %>%
  filter(str_detect(dt_nascimento, "-"))

# Calculando a idade dos pacientes
# data_clean$idade <- as.integer((as.yearmon(today()) - as.yearmon(data_clean$dt_nascimento)))

# ggplot(data = data_clean) + geom_histogram(data = data_clean, aes(x = data_clean$idade), bins = 30)
# km <- kmeans(ten$idade, 2)
# km

com_febre <- dengue_dataset %>%
  filter(str_detect(febre, "1"))

sem_febre <- dengue_dataset %>%
  filter(str_detect(febre, "2"))

# qplot(no_bairro_residencia, data = three_thousand)
# data_clean$no_bairro_residencia

# Filtrando as tuplas que possuem o bairro preenchico
com_bairros <- data_clean %>%
  filter(!grepl("^$", no_bairro_residencia))

# Ordenando os bairros pelo número de agrupamento
bairros <- count(com_bairros, no_bairro_residencia, sort = TRUE)

# Filtrando os dez primeiros colocados
bairros <- bairros[1:10,]

# Exibindo com o ggplot
ggplot(data = bairros) + geom_point(data = bairros, aes(x = 1:10, y = n, col=bairros$no_bairro_residencia))

# Exibindo com o qplot
qplot(data = bairros, x = no_bairro_residencia, weight = n, geom = "bar", fill = no_bairro_residencia)

ggplot(data = bairros) +
  geom_bar(data = bairros,
           aes(x = reorder(no_bairro_residencia, -n),
               weight = n, fill=bairros$no_bairro_residencia))


library(tm)
library(SnowballC)

doc1 <- "Mia Thermopolis has just found out that she is the heir apparent to the throne of Genovia. With her friends Lilly and Michael Moscovitz in tow, she tries to navigate through the rest of her sixteenth year."
doc2 <- "Danny Ocean and his eleven accomplices plan to rob three Las Vegas casinos simultaneously."
doc3 <- "A Lion cub crown prince is tricked by a treacherous uncle into thinking he caused his fathers death and flees into exile in despair, only to learn in adulthood his identity and his responsibilities."
doc4 <- "When his secret bride is executed for assaulting an English soldier who tried to rape her, Sir William Wallace begins a revolt against King Edward I of England."
doc5 <- "The aliens are coming and their goal is to invade and destroy Earth. Fighting superior technology, mankinds best weapon is the will to survive."
doc6 <- "The cross-country adventures of two good-hearted but incredibly stupid friends."

query <- "my alien stupid friends"

docList <- list(doc1, doc2, doc3, doc4, doc5, doc6)
nDocs <- length(docList)
names(docList) <- paste0("doc", c(1:nDocs))

# A vector source interprets each element of the vector x as a document.
docs <- VectorSource(c(docList, query))
docs$Names <- c(names(docList), "query")

# Corpora are collections of documents containing (natural language) text.
corpus <- Corpus(docs)
corpus <- tm_map(corpus, content_transformer(tolower))
corpus <- tm_map(corpus, removePunctuation,preserve_intra_word_dashes = TRUE)
corpus <- tm_map(corpus, removeNumbers)
corpus <- tm_map(corpus, removeWords, stopwords("english"))
corpus <- tm_map(corpus, stripWhitespace)

tdm <- TermDocumentMatrix(corpus)
inspect(tdm)
m <- as.matrix(tdm)

computeTFIDF <- function(row) {
        df = sum(row[1:nDocs] > 0)
        w = rep(0, length(row))
        w[row > 0] = (1 + log2(row[row > 0])) * log2(nDocs/df)
    return(w)
}

n <- t(apply(m, 1, FUN=computeTFIDF))
colnames(n) <- colnames(m)

# # Vetor de normas
escala <- sqrt(colSums(n^2))

# Função scale aplicada na matriz
n <- scale(n, center=FALSE, scale=escala)

# Ranqueamento via produto escalar (assumindo vetores já normalizados)
query <- n[, nDocs+1]
n <- n[, 1:nDocs]

scores <- t(query) %*% n

results <- data.frame(doc = names(docList), score = t(scores))
results <- results[order(results$score, decreasing = TRUE),]

print(results)


path="/Users/david/Desktop/2019/"
setwd(path)

Alldata = read.csv(file = "data.csv")

getStateData = function(data_matrix, state)
{
  rawdata=subset(read.xlsx("MCM_NFLIS_Data.xlsx", sheet="Data"), State == state)[,c("State", "FIPS_Combined")]
  countyID = unique(rawdata["FIPS_Combined"])
  t1 = apply(as.matrix(Alldata[,"GEO.id2"]), 1, as.numeric)
  t2 = apply(as.matrix(countyID), 1, as.numeric)
  data = Alldata[which(t1 %in% t2),]
  return(data)
}

data = getStateData(Alldata, "KY")

#processing metadada
metadata = read.csv(file = "metadata.csv")
metadata = metadata[!grepl('Estimate',metadata$Id),]
metadata = metadata[!grepl('Margin',metadata$Id),]
metadata = metadata[!grepl('Geography',metadata$Id),]

countyID = as.numeric(as.vector(unique(data[,"GEO.id2"])))

factors = c("HOUSEHOLDS BY TYPE", "RELATIONSHIP", "MARITAL STATUS", "FERTILITY", "GRANDPARENTS",
            "SCHOOL ENROLLMENT", "EDUCATIONAL ATTAINMENT", "VETERAN STATUS", "DISABILITY STATUS", "RESIDENCE",
            "PLACE OF BIRTH", "U.S. CITIZENSHIP STATUS", "YEAR OF ENTRY", "WORLD REGION OF BIRTH OF FOREIGN BORN",
            "LANGUAGE SPOKEN AT HOME", "ANCESTRY", "COMPUTERS")

#Step 1 find the categories represent in metadata

all_result = countyID

for (factor in factors) {
  factor_metadata = metadata[grepl(factor,metadata$Id),]
  result = rep(0, times=length(countyID))
  for (year in c(2010,2011,2012,2013,2014,2015,2016)) {
    tmp_data = subset(data, Year == year)
    tmp_data = tmp_data[,c("Year", "GEO.id2", intersect(as.matrix(factor_metadata[,1]), colnames(data)))]

    #normalization
    normalization = function(x)
    {
      min = min(x)
      max = max(x)
      if((max-min) == 0) return (x)
      return ((x-min) / (max-min))
    }

    tmp_data = cbind( tmp_data[,1:2], apply(tmp_data[,3:ncol(tmp_data)],2,normalization))

    #PCA降维
    PCA = function(matrix)
    {
      pca = prcomp(matrix,scale=TRUE)
      eigs = pca$sdev^2
      var_pca=round(cumsum(eigs)/sum(eigs),4)
      this_var <- get_pca_var(pca)
      n=min(which(var_pca>0.85))#n is the dimension that expalained 85% variance
      if(n == 1){
        mc = this_var$cor[,1:n]
      } else
      {
        mc=rowSums(this_var$cor[,1:n]) #this should be the weight for the 3 columns
      }
      return(mc)
    }
    weight = PCA(apply(tmp_data, 2, as.numeric)[,3:ncol(tmp_data)])
    result = cbind(result, as.vector(as.matrix(tmp_data[,3:ncol(tmp_data)]) %*% weight) )
  }
  result = as.matrix(apply(result, 1, sum))
  colnames(result) = factor
  all_result = cbind(all_result, result)
}

colnames(all_result)[1] = "FIPS_Combined"

#get ratio of drug for every counties
rawdata=read.xlsx("MCM_NFLIS_Data.xlsx", sheet="Data")
rawdata = rawdata[,c("YYYY", "COUNTY", "FIPS_Combined", "DrugReports", "TotalDrugReportsCounty")]

calculateTotalDrugs = function(x, rawdata)
{
  TotalDrugReportsCounty = sum(unique(subset(rawdata, FIPS_Combined == x)[,"TotalDrugReportsCounty"]))
  DrugReports = sum(subset(rawdata, FIPS_Combined == x)[,"DrugReports"])
  return(DrugReports/TotalDrugReportsCounty)
}
drug_ratio = cbind(as.matrix(countyID), apply(as.matrix(countyID), 1, calculateTotalDrugs, rawdata))
colnames(drug_ratio) = c("FIPS_Combined", "Drug Ratio")

test = as.matrix(merge(drug_ratio, all_result, all = "T", by = "FIPS_Combined"))
library(Hmisc)
t = rcorr(test[,2:ncol(test)])$r
corrleation = as.matrix(sort(t[,"Drug Ratio"]))


##CTE534_Índices=group
##Imagen=raster
##SWIR1=number 8
##SWIR2=number 9
##NDTI=output raster
##showplots

NDTI <- raster::overlay(Imagen[[SWIR1]],
                        Imagen[[SWIR2]],
                        fun=function(x,y){(x-y)/(x+y)})
plot(NDTI)


nf = layout(matrix(c(1, 2, 2, 2, 3, 3, 4, 4, 5, 5, 5, 6), nrow = 4, ncol = 3,  byrow = FALSE), respect = TRUE)
layout.show(nf)
nf = layout(matrix(c(1, 2, 2, 2, 3, 3, 4, 4, 5, 5, 5, 6), nrow = 4, ncol = 3,  byrow = FALSE))
layout.show(nf)


#' steadman_class
#'
#' Computes the correspondent Steadman's apparent temperature class.
#'
#' @param steadman_index numeric  Steadman index value.
#' @return class of apparent temperature.
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  class,  apparent temperature.
#'
#' @export
#'
#'
#'
#'

steadman_class=function(steadman_index) {

                         res=ifelse(is.na(steadman_index),
                                    NA,
                                    as.numeric(cut(steadman_index, c(-100,-4.99,0.01,5.01,10.01,27.01,30.01,35.01,40.01,100),right=T,label=c(1:9))))
                         return(res)
}


context("Test date2timeperiod")

# Create data
n <- 15000 #size of dataset
nyr <- 20 # number of years in data
nSamples <- 100 # set number of dates
nSites <- 50 # set number of sites
set.seed(125)

# Create somes dates
first <- as.Date(strptime("1980/01/01", "%Y/%m/%d"))
last <- as.Date(strptime(paste(1980+(nyr-1),"/12/31", sep=''), "%Y/%m/%d"))
dt <- last-first
Date <- first + (runif(nSamples)*dt)

# Create time periods dataframe
time_periods <- data.frame(start=c(1980,1990),end=c(1989,1999))

test_that("Test errors and warnings", {

  Date2 <- data.frame(start = Date, end = Date+100)

  expect_error(tps <- date2timeperiod(Date, data.frame(start=c(1980,1990,1995),end=c(1989,1999,2008))),
               'In time_periods year ranges cannot overlap')
  expect_error(tps <- date2timeperiod(Date, data.frame(start=c(1980,1990,2005),end=c(1989,1999,2000))),
               'In time_periods end years must be greater than or equal to start years')

})

test_that("Test time period allocation", {

  tps <- date2timeperiod(head(Date), time_periods)

  expect_equal(tps, c(2,1,1,1,2,2))

  tps2 <- date2timeperiod(head(data.frame(start = Date, end = Date + 500)), time_periods)

  expect_equal(tps2, c(2,1,1,1,NA,NA))

})


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

if (length(args)!=3) {
  stop("Usage:  Rscript compute_7q10.r <station_name> <roll_days> <return_period>", call.=FALSE)
}

ignore_missing <- FALSE
roll_days <- as.numeric(args[2])
return_period <- as.numeric(args[3])

result <- fasstr::compute_frequency_quantile(station_number=args[1], roll_days=roll_days, return_period=return_period, ignore_missing=FALSE)

cat(result)


# Summarize the NatCap InVest output onto our analysis grid

##############################
## Process NatCap Wind data ##
##############################
require(raster)
require(sf)
require(data.table)

gridsize = 0.25 # size of grid for the CMPS analysis, in degrees

# read in data
wind_west <- raster('../NatCap_temp/westcoastwind/output/npv_US_millions.tif')
	# image(wind_west)
wind_east <- raster('../NatCap_temp/eastcoastwind/output/npv_US_millions.tif')
	# image(wind_east)

grid <- readRDS('temp/SPsf2.rds') # the analysis grid

# project to LL
wind_east.t <- projectRaster(wind_east, crs=crs(grid))
wind_west.t <- projectRaster(wind_west, crs=crs(grid)) # slow step

# extract from raster to the grid cells: VERY SLOW approach
# wind_east_df <- extract(x=wind_east.t, y=as(grid[grid$lon > -100,], 'Spatial'), method='bilinear', fun=mean, na.rm=TRUE) # get raster values by climate grid cell
# wind_west_df <- extract(x=wind_west.t, y=as(grid[grid$lon < -100,], 'Spatial'), method='bilinear', fun=mean, na.rm=TRUE)
# wind_east_df <- cbind(npv = wind_east_df, grid[grid$lon > -100, c('lon', 'lat')])
# wind_west_df <- cbind(npv = wind_west_df, grid[grid$lon < -100, c('lon', 'lat')])

# extract from raster to the grid cells: fast approach
wind_east_dt <- data.table(cbind(coordinates(wind_east.t), npv=extract(x=wind_east.t, y=extent(wind_east.t)))) # get raster values by raster grid cell
wind_west_dt <- data.table(cbind(coordinates(wind_west.t), npv=extract(x=wind_west.t, y=extent(wind_west.t))))
wind_dt <- rbind(wind_east_dt, wind_west_dt) # concatenate

wind_dt[, latgrid := floor(y/gridsize)*gridsize + gridsize/2] # round to nearest CMSP grid center
wind_dt[, longrid := floor(x/gridsize)*gridsize + gridsize/2]

wind_sum <- wind_dt[, .(npv = mean(npv, na.rm = TRUE)), by = c('latgrid', 'longrid')] # average by climate grid cell

# plot to make sure it worked
wind_sum[, plot(longrid, latgrid, col=c('red', 'blue')[1+(npv > 0)], pch=16, cex=0.05)] # plots of <> a threshold
wind_sum[, plot(longrid, latgrid, col=c('red', 'blue')[1+(npv > 0)], pch=16, cex=0.5, xlim=c(-80, -60), ylim=c(40, 45))] # zoom in

# mark which grids are in climate grid
grid$latgrid <- floor(grid$lat/gridsize)*gridsize + gridsize/2 # round to nearest CMSP grid center (to fix some rounding errors)
grid$longrid <- floor(grid$lon/gridsize)*gridsize + gridsize/2
    plot(grid$longrid, grid$latgrid, pch=16, cex=0.05) # check it

wind_sum[, keep := FALSE] # set up a column to mark the ones to keep
wind_sum[paste(latgrid, longrid) %in% paste(grid$latgrid, grid$longrid), keep := TRUE] # keep if in the climate grid
    wind_sum[, sum(keep)]
    wind_sum[, sum(!keep)]

    wind_sum[keep == TRUE, plot(longrid, latgrid, col=c('red', 'blue')[1+(npv > 0)], pch=16, cex=0.25)] # plots of <> a threshold
    wind_sum[, plot(longrid, latgrid, col=c('red', 'blue')[keep+1], pch=16, cex=0.25)] # plots of not keep/keep

# remove grids not in clim
wind.out <- wind_sum[keep == TRUE, .(lat = latgrid, lon = longrid, npv = npv)]

# convert NAs to lowest value (too deep)
minnpv <- wind.out[!is.na(npv), min(npv)]
wind.out[is.na(npv), npv := minnpv]

    wind.out[, plot(lon, lat, col=c('red', 'blue')[1+(npv > 0)], pch=16, cex=0.25)] # plots of <> a threshold

# are all climate grid cells in the wind object?
missing <- !(paste(grid$latgrid, grid$longrid) %in% wind.out[, paste(lat, lon)])
sum(missing) # 0

# write out
write.csv(wind.out, gzfile('output/wind_npv.csv.gz'))

##############################
## Process NatCap Wave data ##
##############################
require(raster)
require(sf)
require(data.table)

gridsize = 0.25 # size of grid of the climate data, in degrees

# read in data
wave_west <- raster('../NatCap_temp/westcoastwave/output/npv_usd.tif')
    # image(wave_west)
wave_east <- raster('../NatCap_temp/eastcoastwave/output/npv_usd.tif')
    # image(wave_east)

grid <- readRDS('temp/SPsf2.rds') # the analysis grid

# project to LL
wave_east.t <- projectRaster(wave_east, crs=crs(grid))
wave_west.t <- projectRaster(wave_west, crs=crs(grid)) # took 15 min. why? because has to grid the whole globe from -180 to 180.

# split west into east and west of -180
# otherwise R doesn't have enough memory to do the next step all at once
wave_west.t1 <- crop(wave_west.t, extent(165, 180, 40, 65))
wave_west.t2 <- crop(wave_west.t, extent(-180, -100, 0, 90))

# extract from raster to the grid cells: fast approach
wave_east_dt <- data.table(cbind(coordinates(wave_east.t), npv=extract(x=wave_east.t, y=extent(wave_east.t)))) # get raster values by raster grid cell
wave_west_dt1 <- data.table(cbind(coordinates(wave_west.t1), npv=extract(x=wave_west.t1, y=extent(wave_west.t1))))
wave_west_dt2 <- data.table(cbind(coordinates(wave_west.t2), npv=extract(x=wave_west.t2, y=extent(wave_west.t2))))
wave_dt <- rbind(wave_east_dt, wave_west_dt1, wave_west_dt2) # concatenate
    nrow(wave_east_dt)
    nrow(wave_west_dt1)
    nrow(wave_west_dt2) # very big
    nrow(wave_dt) # very big

wave_dt[, latgrid := floor(y/gridsize)*gridsize + gridsize/2] # round to nearest climate grid center
wave_dt[, longrid := floor(x/gridsize)*gridsize + gridsize/2]

wave_sum <- wave_dt[, .(npv = mean(npv, na.rm = TRUE)), by = c('latgrid', 'longrid')] # average by climate grid cell
    nrow(wave_sum) # more reasonable

# plot to make sure it worked
wave_sum[, plot(longrid, latgrid, col=c('red', 'blue')[1+(npv > 0)], pch=16, cex=0.05)] # plots of <> a threshold

# mark which grids are in climate grid
grid$latgrid <- floor(grid$lat/gridsize)*gridsize + gridsize/2 # round to nearest climate grid center (to fix some rounding errors)
grid$longrid <- floor(grid$lon/gridsize)*gridsize + gridsize/2

wave_sum[, keep := FALSE] # set up a column to mark the ones to keep
wave_sum[paste(latgrid, longrid) %in% paste(grid$latgrid, grid$longrid), keep := TRUE] # keep if in the climate grid
wave_sum[, sum(keep)]
wave_sum[, sum(!keep)]

wave_sum[keep == TRUE, plot(longrid, latgrid, col=c('red', 'blue')[1+(npv > 0)], pch=16, cex=0.05)] # plots of <> a threshold
wave_sum[, plot(longrid, latgrid, col=c('red', 'blue')[1+keep], pch=16, cex=0.05)] # keep?

# remove grids not in clim
wave.out <- wave_sum[keep == TRUE, .(lat = latgrid, lon = longrid, npv = npv)]

# convert NAs to lowest value (too deep)
minnpv <- wave.out[!is.na(npv), min(npv)]
wave.out[is.na(npv), npv := minnpv]

wave.out[, plot(lon, lat, col=c('red', 'blue')[1+(npv > 0)], pch=16, cex=0.05)] # plots of <> a threshold

# are all climate grid cells in the wave object?
missing <- !(paste(grid$latgrid, grid$longrid) %in% wave.out[, paste(lat, lon)])
sum(missing) # 0

# write out
write.csv(wave.out, gzfile('output/wave_npv.csv.gz'))


#setwd('~/Msc/Sem 1/DBMS/DBMS-Codes')
source('candidate.r')
source('closure.r')

#Check wether there is super Dependency or Not
super_dependency <- function(lhs,super){
  condition = FALSE
  for(j in 1:length(super)){
    temp <- super[j]
    for(i in strsplit(lhs,"")[[1]]){
      temp <- sub(i,"",temp)
    }
    if((nchar(temp) == 0)){
      condition <- TRUE
      break
    }
  }
  return(condition)
}

#Update the rows of original Data Frame
update_fd <- function(original,updates){
  for(i in 1:nrow(updates)){
    for(j in 1:nrow(original)){
      if((updates[i,'V1'] == original[j,'V1']) && (updates[i,'V2'] == original[j,'V2'])){
        original[j,'V3'] = updates[i,'V3']
        break
      }
    }
  }
  return(original)
}

#Decomposing Relation
decompose_relation <- function(input,tables){
  #Removing FD's that do not voilate NF Rule
  temp <- input[input['V3']== (tables+1), ]
  loop_condition = TRUE
  rows = nrow(temp)
  while(loop_condition){

    #Row number of FD's that need to be separated
    closure <- find_closure(temp[1,'V1'],temp)$rows
    update <- temp[closure,]
    temp <- temp[-closure,]

    #Updating the Fd's in Original FD's
    update_rows <- is.na(match(paste0(input$V1,input$V2),paste0(update$V1,update$V2)))
    input[update_rows == FALSE,'V3'] = tables + 1
    tables <- tables + 1

    #If no more updates required Terminate the loop
    if(nrow(temp) == 0)
      loop_condition = FALSE
  }
  #Return updated Fd's & Max Number of Tables formed
  return(list("input" = input,"tables" = tables))
}

#Checking weather Relation is in 2NF?
bcnf <- function(input){

  #Adding New Column to Define the Relation in which FD is after decomposition
  V3 = c(rep(1,nrow(input)))
  input <- cbind(input,V3)

  no_of_relation = 1;
  #Execute 2NF till all Relations are in 2NF
  loop_condition <- TRUE
  while(loop_condition){

    #Checking for all Decomposed Relations
    for(i in 1:no_of_relation){
      temp <- input[input['V3'] == i,]
      if(nrow(temp) > 0){
        two_nf = TRUE

        attr <- find_attr(temp)
        super <- keys(attr,temp,'s')
        for(j in 1:nrow(temp)){
          if(!super_dependency(temp[j,'V1'],super)){
            temp[j,'V3'] = no_of_relation + 1
            two_nf = FALSE
          }
        }
        if(!two_nf){
          output <- decompose_relation(temp,no_of_relation)
          temp <- output$input
          no_of_relation <- output$tables
        }else{
          loop_condition = FALSE
        }
      }
      if(nrow(temp) > 0)
        input <- update_fd(input,temp)
    }
  }
  return(input)
}


# 4. faza: Napredna analiza podatkov

# library(ggplot2)
# library(GGally)
# library(dplyr)
# library(tmap)

# source("lib/libraries.r", encoding="UTF-8")

placa <- povprecna.mesecna.placa %>% filter(leto == "2020", vrsta.place == "neto")
placa$povprecna.placa[placa$obcina == "Osilnica"] <- 714.13

tabela.za.analizo <- struktura.prebivalstva %>% filter(leto == "2020",
                                                       izobrazba == " Višješolska, visokošolska - Skupaj"
) %>% group_by(obcina
) %>%
  summarise(delez.visokoizobrazenih = round((sum(stevilo) / sum(prebivalci))* 100,2)) %>%
  left_join(placa, by = "obcina") %>% dplyr::select(obcina, delez.visokoizobrazenih, povprecna.placa)

################################# METODA VODITELJEV ####################################################

# library(cluster)

obrisi = function(podatki, hc = TRUE, od = 2, do = NULL) {
  n = nrow(podatki)
  if (is.null(do)) {
    do = n - 1
  }

  razdalje = dist(podatki)

  k.obrisi = tibble()
  for (k in od:do) {
    if (hc) {
      o.k = hclust(razdalje) %>%
        cutree(k) %>%
        silhouette(razdalje)
    } else {
      set.seed(123)
      o.k = kmeans(podatki, k)$cluster %>%
        silhouette(razdalje)
    }
    k.obrisi = k.obrisi %>% bind_rows(
      tibble(
        k = rep(k, n),
        obrisi = o.k[, "sil_width"]
      )
    )
  }
  k.obrisi$k = as.ordered(k.obrisi$k)

  k.obrisi
}

obrisi.povprecje = function(k.obrisi) {
  k.obrisi.povprecje = k.obrisi %>%
    group_by(k) %>%
    summarize(obrisi = mean(obrisi))
}

obrisi.k = function(k.obrisi) {
  obrisi.povprecje(k.obrisi) %>%
    filter(obrisi == max(obrisi)) %>%
    summarize(k = min(k)) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}

r.km <- tabela.za.analizo[, -1] %>% obrisi(hc = FALSE)

optimalno.stevilo.skupin <- obrisi.k(r.km)

set.seed(123)

tabela.za.analizo.skupine <- unique(tabela.za.analizo$obcina) %>% sort()
razlicni.elementi.skupine <- lvls != tabela.za.analizo.skupine
primerjava.elementi.skupine <- data.frame(obcina.zemljevid = parse_character(lvls),
                                          obcina.skupine = tabela.za.analizo.skupine)[razlicni,]

primerjava.elementi.skupine.na.zemljevidu <- tabela.za.analizo %>%
  left_join(primerjava.elementi.skupine, by = c("obcina" = "obcina.skupine")) %>%
  mutate(obcina = ifelse(is.na(obcina.zemljevid), obcina, obcina.zemljevid) %>% factor()) %>%
  dplyr::select(-obcina.zemljevid)

tabela.za.analizo.norm <- primerjava.elementi.skupine.na.zemljevidu %>%
  dplyr:: select(delez.visokoizobrazenih, povprecna.placa) %>% scale()

rownames(tabela.za.analizo.norm) <- primerjava.elementi.skupine.na.zemljevidu$obcina
skupine <- kmeans(tabela.za.analizo.norm, optimalno.stevilo.skupin, nstart=1000)
skupine$tot.withinss

skupine.zemljevid <- data.frame(obcina = primerjava.elementi.skupine.na.zemljevidu$obcina,
                                Skupina = factor(skupine$cluster))

mapa3 <- tm_shape(merge(obcine, skupine.zemljevid, by.x = "OB_UIME", by.y = "obcina")) + tm_polygons("Skupina")
tmap_mode("view")

#################################### NAPOVED ############################################################

# library(ranger)

slovenija.place.mesecno <- read_csv2("podatki/slovenija_place_mesecno.csv", skip = 2, na="-",
                                     locale=locale(encoding="Windows-1250"), col_names = TRUE)

slovenija.place.mesecno <- slovenija.place.mesecno %>%
  rename("mesec" = "MESEC", "placa" = "Neto plača"
         ) %>%
  mutate(neto = placa / 100
         ) %>%
  dplyr::select(mesec, neto
                ) %>%
  map_df(rev)

zamakni <- function(x, n){c(rep(NA, n), x)[1:length(x)]}

naredi.df <- function(x){
  data.frame(placa = x,
             placa1 = zamakni(x, 1),
             placa2 = zamakni(x, 2),
             placa3 = zamakni(x, 3),
             placa4 = zamakni(x, 4))
  }

df <- naredi.df(slovenija.place.mesecno$neto)
model = ranger(formula = placa ~ ., data = df %>% drop_na())

n = nrow(df)

df2 <- naredi.df(c(slovenija.place.mesecno$neto, NA))
napoved <- predict(model, data = df2[n+1,])$predictions
df2[n+1,1] = napoved

datumi<- seq(as.Date("2006-1-1"), as.Date("2021-12-1"), by = "months")

pricakovanje <- as_tibble(data.frame(
  datumi,
  df2$placa))
df2[(n+1):(n+10),1]

napoved.graf <- ggplot(pricakovanje) + geom_line(mapping = aes(x = datumi, y = df2.placa), color = "red")+
  geom_line(mapping = aes(x = datumi, y = df2.placa, color = datumi <= as.Date("2021-11-1")), show.legend = FALSE)+
  labs(
    x = "Leto",
    y = "Povprečna mesečna neto plača",
    title = "Gibanje povprečne mesečne neto plače v Sloveniji od leta 2006 do 2021"
  )

################################### LINEARNA REGRESIJA #####################################################

graf.regresija <- ggplot(pricakovanje, aes(x=datumi, y=df2.placa)) + geom_point() +
  xlab("Leto") + ylab("Povprečna mesečna neto plača")+
  ggtitle("Rast povprečne mesečne plače v Sloveniji od leta 2006 do 2021")
linearna.regresija <- graf.regresija + geom_smooth(method="lm", formula = y ~ x)


####### Correlations between effect sizes of CpGw with lowest p-value (top 100) in different summary statistics
# M.Suderman

# load summary statistics (CpG, estimate, p-value)
# create list of analysis with lists of CpGs available in all analysis (ewas.list)

get.top.sites <- function(ewas,n)
  rownames(ewas)[order(ewas$p.value)[1:n]]

top.sites <- sapply(ewas.list, get.top.sites, n=100)

top.corr <- sapply(1:length(ewas.list),
                   function(i)
                     sapply(1:length(ewas.list),
                            function(j)
                              cor(ewas.list[[i]][top.sites[,i], "estimate"],
                                  ewas.list[[j]][top.sites[,i], "estimate"],
                                  use="p")))
print(top.corr)


#similar to t-test.r script
#This script calculates t-test between TOTAL energy (COUL+LJ) WT and VAR
#name1,name2 for input files for COUL and LJ
#change input/output file names and path

x<-1:343
out<-c()
for(i in x)
{	for(j in x)
	{
		if(j>i)
		{
			#name<-"coul-sr-30sample-"+i+"-"+j+".txt"
			name1 <-paste0('../30sample/coul-sr-30sample-',i,'-',j,'.txt', collapse = "" )  #paste0('coul-sr-30sample-',i,'-',j,'.txt', collapse = "" )
	#	 	cat(i,"\t", j,"\n")
			name2 <-paste0('../LJ-SR/30sample/lj-sr-30sample-',i,'-',j,'.txt', collapse = "" )
			f1<-read.delim(file=name1,sep="\t", header=F)
			f2<-read.delim(file=name2,sep="\t", header=F)
			wt_cl<-f1[,2]
			v_cl<-f1[,3]
                       wt_lj<-f2[,2]
                        v_lj<-f2[,3]

		       tot_wt<-wt_cl+wt_lj
		       tot_v<-v_cl+v_lj

			#t.test(wt,v)
			mwt<-mean(tot_wt)
			mv<-mean(tot_v)
			pval<-t.test(tot_wt,tot_v)$p.value
			diff<-mwt-mv
			absdiff<-abs(diff)
			a<-cbind(i,j,pval)
			out<-rbind(out,a)

			#sink("../pval.txt")
			cat(i,"\t",j,"\t",pval,"\n")
			line=paste(i,' ',j,' ',pval,' ',mwt,' ',mv,' ',diff,' ',absdiff, collapse = "" )
			write(line,file="30-tot-pval.txt",append=TRUE)
		}
	}
}
#sink("../pval.txt")
#print(out)
#sink()


library("data.table")		# fread (fast csv reading)

#filename = "response-time-of-chunks-of-calls.csv"
filename = "results-with-memory/raw-1-10-5.csv"
#filename = "results/raw-1-10-5.csv"
pdf(file=sprintf("%s-%s.pdf", filename, format(Sys.time(), format="%d-%B-%Y")))
numFirstValuesToIgnore = 10000000

colors = c("red", "blue", "green", "black", "darkred", "darkviolet")

# returns a data.table (by default)
## which enhances/extends a data.frame
### which in turn is a list of vectors.
#### Each vector in the list represents a row with its column values.
csvTable = fread(filename, skip=numFirstValuesToIgnore)

rowCount = csvTable[, .N]
cat(sprintf("\nYour input file contains %d lines.\n\n", rowCount))

chunkSize = rowCount/1000
cat(sprintf("The chunk size was set to %d calls.\n\n", chunkSize))

# csvTable with an additional column "id" which contains the row numbers (necessary for grouping; see below)
csvTable[, id:=1:.N]

print(csvTable)

# default column name: "V" followed by the column number
thread <- csvTable[["V1"]]
time <- csvTable[["V2"]]
memory <- csvTable[["V3"]]
gcActivity <- csvTable[["V4"]]

# grouped*Time is a table with "id" and "V1"
groupedMaxTime <- csvTable[, max(V2), by=.((id-1)%/%chunkSize)]
groupedMeanTime <- csvTable[, mean(V2), by=.((id-1)%/%chunkSize)]
groupedMedianTime <- csvTable[, median(V2), by=.((id-1)%/%chunkSize)]
groupedMinTime <- csvTable[, min(V2), by=.((id-1)%/%chunkSize)]

groupedMeanMemory = NULL
if (is.null(memory)) {
	groupedMeanMemory <- list()
} else {
	groupedMeanMemory <- csvTable[, mean(V3), by=.((id-1)%/%chunkSize)]
}

groupedSumGcActivity = NULL
if (is.null(gcActivity)) {
	groupedSumGcActivity <- list()
} else {
	groupedSumGcActivity <- csvTable[, sum(V4), by=.((id-1)%/%chunkSize)]
}

maxTimes <- groupedMaxTime[["V1"]]
meanTimes <- groupedMeanTime[["V1"]]
medianTimes <- groupedMedianTime[["V1"]]
minTimes <- groupedMinTime[["V1"]]

meanMemory <- groupedMeanMemory[["V1"]]

sumGcActivity <- groupedSumGcActivity[["V1"]]

##### start plotting #####

# increase the width of the plot (margin) due to multiple y-axes
#5.1,4.1,4.1,2.1			# default margin in R
par(mar = c(5.1+3,4.1,4.1+2,2.1+5))
# disable scientific number representation, e.g., 1e+07
options(scipen=10)

ts.plot(
	ts(maxTimes), ts(meanTimes), ts(medianTimes), ts(minTimes),
	gpars = list(yaxt="n", xaxt="n"),
	col=colors,
	type="l",
	log="y",
	xlab="Chunk",
	ylab="Response time (in us) of a chunk"
)
# display x-ticks with "th" as suffix
ticks <- axTicks(1)
axis(1, at = ticks, labels=sprintf("%dth", ticks))
# display y-ticks in micro seconds (so, we divide the current ticks by 1000)
ticks <- axTicks(2)
axis(2, at = ticks, labels=ticks/1000)

if (!is.null(memory)) {
par(new=T)
ts.plot(ts(meanMemory),
	gpars = list(axes=FALSE, xaxt="n", yaxt="n"),
	col=colors[5],
	type="l",
	xlab="",
	ylab=""
)
# display y-ticks in mega bytes (so, we divide the current ticks by 1024*1024)
ticks <- axTicks(2)
axis(4, at = ticks, labels=sprintf("%.0f", ticks/(1024*1024)), col=colors[5])
mtext("Mean heap memory consumption (in MB) of a chunk", side=4, line=2)
}

if (!is.null(gcActivity)) {
par(new=T)
ts.plot(ts(sumGcActivity),
		gpars = list(axes=FALSE, xaxt="n", yaxt="n"),
		col=colors[6],
		type="l",
		xlab="",
		ylab=""
)
# display y-ticks
ticks <- axTicks(2)
axis(4, at = ticks, labels=ticks, col=colors[6], line=4)
mtext("Sum GC collection count of a chunk", side=4, line=6)
}

# disable clipping (to not cut off the legends outside the plot)
par(xpd=TRUE)
legend("top", c("max", "mean", "median", "min"),
	fill=colors,
	horiz=TRUE,
	title=sprintf("Each chunk of %d calls is aggregated via:", chunkSize),
	inset=c(0,-0.16)
)

legend("bottom", c("mean heap", "sum gc"),
	fill=colors[5:6],
	horiz=TRUE,
	title=sprintf("Memory observations"),
	inset=c(0,-0.35)
)

# reset margin to default
par(mar = c(5.1,4.1,4.1,2.1))

i=1
plot(maxTimes, col=colors[i], type="l")
plot(meanTimes, col=colors[i+1], type="l")
plot(medianTimes, col=colors[i+2], type="l")
plot(minTimes, col=colors[i+3], type="l")
if (!is.null(memory)) {
	plot(meanMemory, col=colors[i+4], type="l")
}
if (!is.null(gcActivity)) {
	plot(sumGcActivity, col=colors[i+5], type="l")
}

### experimental code ###
#print("experimental code follows...")

#csvTable = fread(filename, skip=0, nrows=10)
#csvTable = fread(filename, skip=numFirstValuesToIgnore, select=c(1,2))
#csvTable = fread(filename, skip=numFirstValuesToIgnore, select=c("thread","time"))

#print(csvTable)

# increase the width of the plot (margin) due to multiple y-axes
#par(oma = c(0, 2, 0, 2))

# returns the column named "thread" as vector
#csvTable[["thread"]]

# returns the column with number 1 as vector
#csvTable[1]

#numRows = csvTable[, .N]

# default column name: "V" followed by the column number
#x <- seq(1:numRows)

#groupedTime <- csvTable[,c(V2),by=V1]
#print(groupedTime)

# x and y are each a list of values
#plot(x,y)
# y label is "-log_10(p)"
#plot(x,y, ylab=expression(-log[10](italic(p))))

# axis(..): side=2 means left side; side=4 means right side

#labels <- sapply(ticks, function(i) as.expression(bquote(10^ .(i))))
# labels <- c("a", "b", "c")

# write pdf
invisible(dev.off())


#!/usr/bin/env Rscript

library(lattice)

data <- read.table("demo3_output.txt")
names(data) <- c("r", "loglike")

#convert to like from log-like and normalize
data$like <- exp(data$loglike)
norm <- data$like/max(data$like)
data$like <- data$like/norm

# Make the output directory if needed.
if (! file.exists("plots"))
   dir.create("plots")

#make plot
png("plots/demo3.png")
xyplot(like~r, data, xlab="Tensor ratio r", ylab="Likelihood", grid=TRUE, type="l")
invisible(dev.off())


\name{dist2}
\alias{dist2}
\title{
Calculate Pairwise Distance from a Matrix
}
\description{
Calculate Pairwise Distance from a Matrix
}
\usage{
dist2(x, pairwise_fun = function(x, y) sqrt(sum((x - y)^2)), ...)
}
\arguments{

  \item{x}{A matrix or a list. If it is a matrix, the distance is calculated by rows.}
  \item{pairwise_fun}{A function which calculates distance between two vectors.}
  \item{...}{Pass to \code{\link[stats:dist]{as.dist}}.}

}
\details{
You can construct any type of distance measurements by defining a pair-wise distance function.
The function is implemented by two nested \code{for} loops, so the efficiency may not be so good.
}
\value{
A \code{\link[stats]{dist}} object.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
lt = lapply(1:10, function(i) {
    sample(letters, sample(6:10, 1))
})
dist2(lt, function(x, y) {
    length(intersect(x, y))/length(union(x, y))
})
}


# Pull PWT national accounts data into dataframe
p <- read.csv("~/Dropbox/project/studyguide/data/pwt91_na.csv", header=TRUE)

p$scon <- round(p$v_c/p$v_gdp,digits=2) # calculate consump share
p$sgfcf <- round(p$v_i/p$v_gdp,digits=2) # calculate cap formation as share

stable <- p[ which(p$countrycode %in% c("USA", "CAN", "MEX", "GBR", "AUS")),]
catchup <- p[ which(p$countrycode %in% c("USA", "DEU", "JPN", "KOR", "CHN","NGA")),]
usa <- p[ which(p$countrycode %in% c("USA")),]

fig <- plot_ly(stable, x = ~year, y = ~scon, linetype = ~countrycode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Consumption share of GDP', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Consumption share',range = c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "pwt-stable-scon")

fig <- plot_ly(catchup, x = ~year, y = ~scon, linetype = ~countrycode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Consumption share of GDP', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Consumption share',range = c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "pwt-catchup-scon")

fig <- plot_ly(stable, x = ~year, y = ~sgfcf, linetype = ~countrycode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Gross capital formation share of GDP', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Gross capital formation share',range = c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "pwt-stable-sgfcf")

fig <- plot_ly(catchup, x = ~year, y = ~sgfcf, linetype = ~countrycode, type = 'scatter', mode = 'lines+markers')
fig <- layout(fig, title = list(text = 'Gross capital formation share of GDP', x=0),
              xaxis = list(title = 'Year'),
              yaxis = list (title = 'Gross capital formation share',range = c(0,1)),
              hovermode="x unified")
api_create(fig, filename = "pwt-catchup-sgfcf")


piusBenchmark_AMI_Ver = function(MVec = NULL, NVec = NULL, numSubgroupsVec = NULL, lambdaVec = NULL,
                          univVec = NULL, iStrength = 1, sigmaMax = 0.1, thresholdMult = 10 ^ (-3),
                          maxSteps = 10 ^ 4, tStep = 10 ^ (-2), intTime = 1, interSmplMult = 0.01,
                          returnParams = FALSE, conGraph = NULL, rollRange = 0.025, numClust = NULL,
                          numReplicates = 2, numComputeClusters = 64){

  #  ARGS:
  #
  #  RETURNS:

  source("piusBenchmarkDFCreator.r")
  source("piusDFTest_AMI_Ver.r")

  treatmentDF = piusBenchmarkDFCreator(MVec = MVec, NVec = NVec, numSubgroupsVec = numSubgroupsVec,
                                       lambdaVec = lambdaVec, univVec = univVec)

  testResultsDF = piusDFTest_AMI_Ver(treatmentDF = treatmentDF, iStrength = iStrength, sigmaMax = sigmaMax,
                                     thresholdMult = thresholdMult, maxSteps = maxSteps, tStep = tStep,
                                     intTime = intTime, interSmplMult = interSmplMult,
                                     returnParams = returnParams, conGraph = conGraph,
                                     rollRange = rollRange, numClust = numClust,
                                     numReplicates = numReplicates, numComputeClusters = numComputeClusters)

  return(testResultsDF)

} #  end  piusBenchmark_AMI_Ver  function


#Begin by changing the working directory
setwd("ADD OWN WORKING DIRECTORY HERE")   # Set working directory

# Install and load all the required packages

install.packages("psych")
library(psych)		# For tesing multidimensionality of variables
install.packages("granovaGG")
library(granovaGG)	# To visualise the dependent sample assessment plots (Figure 2)
install.packages("PMCMR")
library(PMCMR)		# For the non-parametric pair-wise comaprisons of ecosystem services (Figure 3)
install.packages("gridExtra")
library(gridExtra)	# To allow two plots to be group alongside each other (e.g. Figure 2)

# Open the survey data and attach the data.frame  to make data handling simpler
ES <-  read.table("Survey_data.txt",header=TRUE, sep="\t", na.strings="NA", dec=".", strip.white=TRUE)

# Flip the values for question 11, which asked about an ecosystem DISservice.
ES$Q11 <- 3-ES$Q11
attach(ES)

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

#############################################
#											#
#   Test responses for unidimensionality	#
#											#
#############################################

# For odd-numbered question (Ecosystem services benefits)
# NOTE: questions along different scales have already been removed
omB <- omega(subset(ES, select=c(Q1,Q3,Q11,Q13,Q15)),poly=T,plot=F)
omB$omega_h		# Hierarchical omega
omB$ECV			# Expalined common variance
omB$alpha		# Cronbach's alpha

# For even numbered questions (damage-causing activities)
# NOTE: questions along different scales have already been removed
omD <- omega(subset(ES, select=c(Q4,Q6,Q10,Q12,Q14)),poly=T,plot=F)
omD$omega_h		# Hierarchical omega
omD$ECV			# Expalined common variance
omD$alpha		# Cronbach's alpha

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

#################################################################
#																#
# 	Comparing self-reported and community perceived responses	#
#																#
#################################################################

# (1) Benefits from wetlands
benefit.self <- apply(cbind(Q1,Q15,Q11),1,mean)		# self-reported benefits
benefit.group <- apply(cbind(Q3,Q13),1,mean)	 	# community-perceived benefit
wilcox.test(benefit.self, benefit.group, paired = TRUE, alternative = "less")

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

# (2) Damage-causing activities
damage.self <- apply(cbind(Q4,Q6,Q14),1,mean)  	# self-reported damage
damage.group <- apply(cbind(Q10,Q12),1,mean) 	# community-perceived damage
wilcox.test(damage.self, damage.group, paired = TRUE, alternative = "less")

#############################
#							#
# 	Figure 2 in manuscript	#
#							#
#############################

png(filename="Figure 2.png",width=12,height=12,units="cm",res=600)

plot1 <- granovagg.ds(cbind(benefit.group,benefit.self),main="",xlab="Self-reported benefit",ylab="Perceived group benefit") + theme(legend.position="bottom",legend.direction="horizontal")
plot2 <- granovagg.ds(cbind(damage.group,damage.self),main="",xlab="Self-reported damage",ylab="Perceived group damage") + theme(legend.position="bottom",legend.direction="horizontal")
grid.arrange(plot1, plot2, ncol=2)

dev.off()  # Figure should be saved in working directory

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

#############################################
#											#
# 	Comparing types of ecosyetm services	#
#											#
#############################################

# Assign resonses to ecosystem service category
# (Note: self-reported and community-expected are both included because they are strongly related)

provision <- apply(cbind(Q1,Q3,Q7,Q15),1,mean)	# provisioning ecosystem services
regulate <- apply(cbind(Q5,Q11),1,mean)			# regulating ecosystem services
culture <- apply(cbind(Q9,Q13),1,mean)			# cultural ecosystem services

# Carry of Friedman test
friedman.test(cbind(provision,regulate,culture))

# Carry out two types of post-hoc multiple comparison tests (both give the same results)
posthoc.friedman.conover.test(DV, p.adjust.method="bonferroni")	# Conover's test
posthoc.friedman.nemenyi.test(DV)								# Nemenyi's test

#############################
#							#
# 	Figure 3 in manuscript	#
#							#
#############################

# First,create a function to calculate the standard error
se <- function(x){sd(x)/sqrt(length(x))}

# Calculate the mean values and standard error for each ecosystem service type
means <- c(mean(provision), mean(regulate), mean(culture))
ses <- c(se(provision), se(regulate), se(culture))

# Create a dummy vector for the x-axis
xax <- c(1,2,3)

# Make plot for Figure 2
png(filename="Figure 3.png",width=12,height=12,units="cm",res=600)

par(mai=c(0.75,0.8,0.1,0.1))
plot(means~xax,pch=15,cex=2,ylab="Benefits from wetlands", ylim=c(1,1.8),xlim=c(0.4,3.6),xaxt = "n", xlab="",las=2)
axis(1,at=c(1,2,3),label=c("","",""))
mtext(side=1, at=c(1,2,3),line = c(2,2,2), text=c("Provisiong\nservices", "Regulating\nservices","Cultural\nservices"))
arrows(xax,means,xax,means+ses,angle=90)#,col="red")
arrows(xax,means,xax,means-ses,angle=90)#,col="red")

# Add annotations of significant groups from post-hoc test
text(c(1,2,3),c(1.4,1.65,1.33),c("a","b","a"))

dev.off()  # Figure should be saved in working directory

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

#####################################################
#													#
# 	Modeling the benefits obtained from wetlands	#
#													#
#####################################################

# Create new variables to denote the average damage and benefit from wetlands (note: only include unidimensional questions)
# Define demographic variables as either categorical or continuous variable

damage <- apply(cbind(Q4,Q6,Q10,Q12,Q14),1,mean)
benefit <- apply(cbind(Q1,Q3,Q11,Q13,Q15),1,mean)
education <- as.factor(ES$Education)
gender <- as.factor(ES$Gender)
employment <- as.factor(ES$Work)
role <- as.factor(ES$Position)
age <- ES$Age
residence <- ES$Residence

# Define the multiple linear regression
es.lm <- lm(benefit ~ damage + age + education + gender + employment + role + residence, na.action = "na.fail")

# This command reports the coefficents used in Table 2
summary(es.lm)
# This command is for the F-test assocaited with anova to test the significance of variable (Table 2)
anova(es.lm)

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


# context("Simulation of Annotated Phylogenetic Trees")

# Function to compute degree distribution
degseq <- function(x) {
  ind <- as.data.frame(table(x[,2]), responseName = "ind")
  oud <- as.data.frame(table(x[,1]), responseName = "oud")

  ans <- merge(ind, oud, by="Var1", all = TRUE)
  ans[is.na(ans)] <- 0
  as.vector(table(ans$ind + ans$oud))
}

# test_that("Simulating Trees", {
  set.seed(121)
  n <- 100
  d <- vector("integer", n)

  ds <- c(n, 1, n-2)

  expect_equivalent(ds, degseq(sim_tree(n)$edge))
# })

checkout_annotations <- function(x) {
  sapply(
    lapply(x, "[[", "tip.annotation"),
    function(z) tabulate(z+1, 2)
  )
}

# test_that("Simulating informative annotated trees", {

  set.seed(1)
  ans <- lapply(1:100, function(i) raphylo(5, informative = TRUE))
  ans <- checkout_annotations(ans)

  # There must be zeros and ones in all trees!
  expect_true(all(ans[1,] >= 1))
  expect_true(all(ans[2,] >= 1))

# })

# test_that("Dropping annotations", {
  set.seed(1)
  sizes <- ceiling(runif(1e3, .01)*300)
  ans <- lapply(sizes, raphylo, Pi = .5, psi=c(0,0), mu_d=c(.5, .5), mu_s=c(.5, .5))
  ans0 <- checkout_annotations(ans)

  # Dropping half of it and keeping informative
  ans1 <- lapply(ans, rdrop_annotations, pcent=.5, informative = TRUE)
  ans1 <- checkout_annotations(ans1)

  expect_equal(mean(colSums(ans1)/colSums(ans0)), .5, tol = .025)

  # Dropping 2/3 of it and keeping informative
  ans2 <- lapply(ans, rdrop_annotations, pcent=2/3, informative = TRUE)
  ans2 <- checkout_annotations(ans2)

  expect_equal(mean(colSums(ans2)/colSums(ans0)), 1/3, tol = .05)

  # Zeros are more likely to be droped
  ans3 <- lapply(ans, rdrop_annotations, pcent = .5, informative = TRUE,
                 prob.drop.0 = 2/3)
  ans3 <- checkout_annotations(ans3)
  ans3 <- ans3[1,]/colSums(ans3)

  expect_equal(abs(mean(ans3) - .3333), 0, tol = .1)

# })

# test_that("Mislabeling", {

  # Ramdom tree (fully annotated) ---------------------------------------------
  set.seed(1)
  x <- raphylo(20, P=4, Pi=.02)

  # All are ones/zeros
  all_ones <- mislabel(x, psi = c(1, 0))
  all_zero <- mislabel(x, psi = c(0, 1))

  expect_true(all(all_ones$tip.annotation == 1))
  expect_true(all(all_zero$tip.annotation == 0))

  # All oposite
  all_flipped <- mislabel(x, psi = c(1, 1))
  expect_equivalent(x$tip.annotation, 1 - all_flipped$tip.annotation)

  # Same tests but setting annotations equal to 9 ------------------------------

  # Dropping annotations
  x <- rdrop_annotations(x, .5)

  # All are ones/zeros
  all_ones <- mislabel(x, psi = c(1, 0))
  all_zero <- mislabel(x, psi = c(0, 1))

  # Number of 9s is preserved
  expect_equal(sum(all_ones$tip.annotation == 9), sum(x$tip.annotation == 9))
  expect_equal(sum(all_zero$tip.annotation == 9), sum(x$tip.annotation == 9))

  expect_true(all(all_ones$tip.annotation[all_ones$tip.annotation != 9] == 1))
  expect_true(all(all_zero$tip.annotation[all_zero$tip.annotation != 9] == 0))

  # All oposite
  all_flipped <- mislabel(x, psi = c(1, 1))
  expect_equivalent(
    x$tip.annotation[x$tip.annotation != 9],
    1 - all_flipped$tip.annotation[all_flipped$tip.annotation != 9])

# })

# test_that("Deterministic results including node types", {

  # Fake tree assuring evolution
  dat2   <- as.phylo(matrix(c(1, 2, 1, 3, 2, 4, 2, 5), ncol=2, byrow = TRUE))

  getann <- function(x) {
    ans <- structure(
      c(x$tip.annotation, x$node.annotation),
      names = c(x$tree$tip.label, x$tree$node.label))
    ans[order(as.integer(names(ans)))]
  }

  tree2  <- new_aphylo(tip.annotation=rbind(0,0,0), tree = dat2)
  ans0 <- raphylo(tree = tree2, mu_d = c(1, 0), Pi = 1, psi = c(0,0),
                  eta = c(1,1), node.type = NULL)
  ans1 <- raphylo(tree = tree2, mu_d = c(0, 1), Pi = 1, psi = c(0,0),
                  eta = c(1,1), node.type = NULL)
  ans2 <- raphylo(tree = tree2, mu_d = c(1, 1), Pi = 1, psi = c(0,0),
                  eta = c(1,1), node.type = NULL)

  expect_equivalent(getann(ans0), rep(1, 5))        # Only gains
  expect_equivalent(getann(ans1), c(1, 0, 0, 0, 0)) # All losses
  expect_equivalent(getann(ans2), c(1, 0, 0, 1, 1)) # Mixed

  types <- c(1, 0, 1, 1, 1)
  tree3 <- new_aphylo(
    tree = dat2, tip.annotation = rbind(0,0,0),
    node.type = types[dat2$node.label],
    tip.type  = types[dat2$tip.label],
    )

  (ans3  <- raphylo(
    tree = tree3,
    mu_s = c(0, 0), # Nothing happens in speciation nodes (1)
    mu_d = c(1, 0), # Duplication nodes gain a function
    Pi   = 0,       # Start with no function
    eta  = c(1, 1), # Everything is reported
    psi  = c(0,0),  # Nothing is misclassified
    node.type = NULL
    ))

  expect_equivalent(getann(ans3), c(0, 0, 0, 1, 1))

  types <- c(1, 0, 1, 1, 1)
  tree3 <- new_aphylo(
    tree           = dat2,
    tip.annotation = rbind(0,0,0),
    node.type = types[dat2$node.label],
    tip.type  = types[dat2$tip.label],
    )

  (ans3  <- raphylo(
    tree = tree3,
    mu_s = c(0, 0), # Nothing happens in speciation nodes (1)
    mu_d = c(0, 1), # Duplication nodes loss a function
    Pi   = 1,       # Start with a function
    eta  = c(1, 1), # Everything is reported
    psi  = c(0, 0), # Nothing is misclassified
    node.type = tree3$node.type
  ))

  expect_equivalent(getann(ans3), c(1, 1, 1, 0, 0))
# })