################################################################################
# Part of the R/EpiILM package
#
# AUTHORS:
#         Waleed Almutiry <wkmtierie@qu.edu.sa>,
#         Vineetha Warriyar. K. V. <vineethawarriyar.kod@ucalgary.ca> and
#         Rob Deardon <robert.deardon@ucalgary.ca>
#
# Based on:
#                Deardon R, Brooks, S. P., Grenfell, B. T., Keeling, M. J., Tildesley,
#                M. J., Savill, N. J., Shaw, D. J.,  Woolhouse, M. E. (2010).Inference
#                for individual level models of infectious diseases in large
#                populations. Statistica Sinica, 20, 239-261.
#
#
# Free software under the terms of the GNU General Public License, version 2,
# a copy of which is available at http://www.r-project.org/Licenses/.
################################################################################

epimcmc <- function (object, tmin = NULL, tmax, niter,
                     sus.par.ini, trans.par.ini = NULL, beta.ini = NULL, spark.ini = NULL,
                     Sformula = NULL, Tformula = NULL,
                     pro.sus.var, pro.trans.var = NULL, pro.beta.var = NULL, pro.spark.var = NULL,
                     prior.sus.dist, prior.trans.dist = NULL, prior.beta.dist = NULL, prior.spark.dist = NULL,
                     prior.sus.par, prior.trans.par = NULL, prior.beta.par = NULL, prior.spark.par = NULL,
                     adapt = FALSE, acc.rate = NULL) {

  if (!is(object, "epidata")) {
    stop("The object must be in a class of \"epidata\"", call. = FALSE)
  } else {

    # error checks for input arguments

    if (any(is.null(object$type) | !(object$type %in% c("SI", "SIR"))) == TRUE) {
      stop("epimcmc: Specify type as \"SI\" or \"SIR\" ", call. = FALSE)
    }

    if (!is.vector(object$inftime)) {
      stop('epimcmc: inftime is not a vector')
    }

    n <- length(object$inftime)

    if (object$type == "SIR") {
      infperiod = object$remtime - object$inftime
    }

    if (all(is.null(object$contact) &  is.null(object$XYcoordinates)) == TRUE) {
      stop("epimcmc: Specify contact network or x, y coordinates")
    }

    if (is.null(tmin)) {
      tmin <- 1
    }

    # susceptibility parameters:

    ns <- length(sus.par.ini)

    # formula for susceptibility function
    if (!is.null(Sformula)) {
      covmat.sus <- model.matrix(Sformula)
      if (all((ncol(covmat.sus) == length(all.vars(Sformula))) & (ns != length(all.vars(Sformula)))) == TRUE) {
        stop("epimcmc: Check Sformula (no intercept term) and the dimension of susceptibility parameters", call. = FALSE)
      } else if (all((ncol(covmat.sus) > length(all.vars(Sformula))) & (ns != ncol(covmat.sus))) == TRUE) {
        stop("epimcmc: Check Sformula (intercept term) and the dimension of susceptibility parameters", call. = FALSE)
      }
    } else {
      if (ns == 1) {
        covmat.sus <- matrix(1.0, nrow = n, ncol = ns)
      }
    }

    if (any(is.null(prior.sus.dist) | !(all(prior.sus.dist %in% c("halfnormal", "gamma","uniform")))) == TRUE) {
      stop("epimcmc: Specify prior for susceptibility parameters as \"halfnormal\" ,  \"gamma\" or \"uniform\"  ", call. = FALSE)
    }

    prostda <- vector(mode = "numeric", length = ns)
    if (ns == 1) {
      prostda <- pro.sus.var
    } else if (ns > 1) {
      if (length(pro.sus.var) != ns) {
        stop('epimcmc: Specify proposal variance for each susceptibility parameter')
      }
      for (i in 1:ns) {
        prostda[i] <- pro.sus.var[i]
      }
    }

    alphapar <- list(NULL)
    len.alphapar <- ns - sum(prostda == 0)
    if (len.alphapar != 0){
      j <- 1
      for (i in 1:ns) {
        if (prostda[i] != 0){
          alphapar[[j]] <- list(NULL)
          alphapar[[j]][[1]] <- prior.sus.dist[i]
          j <- j + 1
        } else {
          j <- j
        }
      }
    } else {
      alphapar[[1]] <- list(NULL)
      alphapar[[1]][[1]] <- "uniform" # just to fill the list and it is not being used at all.
    }

    if (all(ns == 1 & len.alphapar != 0) == TRUE) {
      if (any((prior.sus.dist == "gamma") | (prior.sus.dist == "uniform")) == TRUE) {
        if (is.null(prior.sus.par)) {
          stop('epimcmc: Specify prior.sus.par as a vector or a 1 by 2 matrix.')
        } else {
          alphapar[[1]][[2]] <- prior.sus.par
        }
      } else if (prior.sus.dist == "halfnormal") {
        if (is.null(prior.sus.par)) {
          stop('epimcmc: Specify the variance of the half normal prior distribution for prior.sus.par.')
        } else {
          alphapar[[1]][[2]] <- c(prior.sus.par[1], 0)
        }
      }
    } else if (all(ns == 1 & len.alphapar == 0) == TRUE) {
      alphapar[[1]][[2]] <- c(0, 0)
    } else if (all(ns > 1 & len.alphapar != 0) == TRUE) {
      if (any(is.null(prior.sus.par) |  !is.matrix(prior.sus.par)) == TRUE) {
        stop('epimcmc: Specify prior.sus.par as a matrix with each row corresponds to each susceptibility parameter')
      } else {
        j <- 1
        for (i in 1:ns) {
          if (prostda[i] != 0){
            alphapar[[j]][[2]] <- prior.sus.par[i,]
            j <- j + 1
          } else {
            j <- j
          }
        }
      }
    } else if (all(ns > 1 & len.alphapar == 0) == TRUE) {
      alphapar[[1]][[2]] <- c(0, 0)
    }# end if - ns

    # transmissibility parameters:

    if (!is.null(trans.par.ini)) {
      nt <- length(trans.par.ini)
      flag.trans <- 1
    } else {
      nt <- 1
      flag.trans <- 0
      phipar <- 1
    }

    # formula for transmissibility function
    if (flag.trans == 1) {
      if (is.null(Tformula)) {
        stop("epimcmc: Tformula is missing. It has to be specified with no intercept term and number of columns equal to the length of trans.par", call. = FALSE)
      } else if (!is.null(Tformula)) {
        covmat.trans <- model.matrix(Tformula)
        if (all((ncol(covmat.trans) == length(all.vars(Tformula))) & (nt != length(all.vars(Tformula)))) == TRUE) {
          stop("epimcmc: Check Tformula. It has to be with no intercept term and number of columns equal to the length of trans.par", call. = FALSE)
        }
      }
    } else if (flag.trans == 0) {
      covmat.trans <- matrix(1.0, nrow = n, ncol = nt)
    }

    if (all(!is.null(prior.trans.dist) & !(all(prior.trans.dist %in% c("halfnormal", "gamma","uniform")))) == TRUE) {
      stop("epimcmc: Specify prior for transmissibility parameters as \"halfnormal\" ,  \"gamma\" or \"uniform\"  ", call. = FALSE)
    }

    if (all(is.null(prior.trans.dist) & flag.trans == 1) == TRUE) {
      stop("epimcmc: Specify prior for transmissibility parameters as \"halfnormal\" ,  \"gamma\" or \"uniform\"  ", call. = FALSE)
    }

    # proposal variance for transmissibility parameters
    prostdt <- vector(mode = "numeric", length = nt)
    if (all(flag.trans == 1 & nt == 1) == TRUE) {
      if (is.null(pro.trans.var)) {
        stop('epimcmc: Specify proposal variance for the transmissibility parameter')
      }
      prostdt <- pro.trans.var
    } else if (all(flag.trans == 1 & nt > 1) == TRUE) {
      if (is.null(pro.trans.var)) {
        stop('epimcmc: Specify proposal variance for each transmissibility parameter')
      }
      if (length(pro.trans.var) != nt) {
        stop('epimcmc: Specify proposal variance for each transmissibility parameter')
      }
      for (i in 1:nt) {
        prostdt[i] <- pro.trans.var[i]
      }
    } else {
      prostdt <- NULL
    }

    if (flag.trans == 1){
      phipar <- list(NULL)
      len.phipar <- nt - sum(prostdt == 0)
      if (len.phipar != 0){
        j <- 1
        for (i in 1:nt) {
          if (prostdt[i] != 0){
            phipar[[j]] <- list(NULL)
            phipar[[j]][[1]] <- prior.trans.dist[i]
            j <- j + 1
          } else {
            j <- j
          }
        }
      } else {
        phipar[[1]] <- list(NULL)
        phipar[[1]][[1]] <- "uniform" # just to fill the list and it is not being used at all.
      }
    } else {
      phipar <- 1
    }

    # prior selection for transmissibility parameters
    if (flag.trans == 1) {

      if (nt == 1 & len.phipar != 0) {
        if (any((prior.trans.dist == "gamma") | (prior.trans.dist == "uniform")) == TRUE) {
          if (is.null(prior.trans.par)) {
            stop('epimcmc: Specify prior.trans.par as a vector or a 1 by 2 matrix.')
          } else {
            phipar[[1]][[2]] <- prior.trans.par
          }
        } else if (prior.trans.dist == "halfnormal") {
          if (is.null(prior.trans.par)) {
            stop('epimcmc: Specify the variance of the half normal prior distribution for prior.trans.par.')
          } else {
            phipar[[1]][[2]] <- c(prior.trans.par[1], 0)
          }
        }
      } else if (all(nt == 1 & len.phipar == 0) == TRUE) {
        phipar[[1]][[2]] <- c(0, 0)
      } else if (all(nt > 1 & len.phipar != 0) == TRUE) {
        if (any(is.null(prior.trans.par) |  !is.matrix(prior.trans.par)) == TRUE) {
          stop('epimcmc: Specify prior.trans.par as a matrix with each row corresponds to each transmissibility parameter')
        } else {
          j <- 1
          for (i in 1:nt) {
            if (prostdt[i] != 0){
              phipar[[j]][[2]] <- prior.trans.par[i,]
              j <- j + 1
            } else {
              j <- j
            }
          }
        }
      } else if (all(nt > 1 & len.phipar == 0) == TRUE) {
        phipar[[1]][[2]] <- c(0, 0)
      }# end if - nt
    }# end if - flag.trans

    # BETA:

    if (!is.null(object$contact)) {
      if (length(object$contact)/(n * n) == 1) {
        ni <- 1

        if (any(!is.null(beta.ini) | !is.null(prior.beta.dist) | !is.null(pro.beta.var) | !is.null(prior.beta.par)) == TRUE) {
          stop("As the model has only one contact network, The model does not have a network parameter beta, beta.ini, prior.dist.beta, prior.beta.var, and pro.beta.var must be assigned to their default values = NULL", .call = FALSE)
        }

        flag.beta <- 0

        betapar <- list(NULL)
        betapar[[1]] <- "uniform" # just to fill the list and it is not being used at all.
        betapar[[2]] <- c(0, 0)

      } else if (length(object$contact)/(n * n) > 1) {

        if (is.null(beta.ini)) {
          stop("epimcmc: The initial values beta.ini of the network parameters has to specified", call. = FALSE)
        }
        ni <- length(beta.ini)

        if (length(object$contact)/(n * n) != ni) {
          stop('epimcmc:  Dimension of beta  and the number of contact networks are not matching')
        }

        flag.beta <- 1

        if (any(is.null(prior.beta.dist) | !(all(prior.beta.dist %in% c("halfnormal", "gamma","uniform")))) == TRUE) {
          stop("epimcmc: Specify prior for beta as \"halfnormal\" ,  \"gamma\" or \"uniform\"  ", call. = FALSE)
        }

        if (length(prior.beta.dist) != ni) {
          stop('epimcmc: Specify prior distributions for each of the network parameters beta, prior.beta.dist')
        }

        # proposal variance for  beta
        prostdb <- vector(mode = "numeric", length = ni)
        if (length(pro.beta.var) != ni) {
          stop('epimcmc: Specify proposal variance for each beta parameter')
        }
        for (i in 1:ni) {
          prostdb[i] <- pro.beta.var[i]
        }

        betapar <- list(NULL)
        if (flag.beta == 0) {
          len.betapar <- 0
        } else {
          len.betapar <- ni - sum(prostdb == 0)
        }

        if (len.betapar != 0){
          j <- 1
          for (i in 1:ni) {
            if (prostdb[i] != 0){
              betapar[[j]] <- list(NULL)
              betapar[[j]][[1]] <- prior.beta.dist[i]
              j <- j + 1
            } else {
              j <- j
            }
          }
        } else {
          betapar[[1]] <- list(NULL)
          betapar[[1]][[1]] <- "uniform" # just to fill the list and it is not being used at all.
        }
        # prior selection for kernel parameters
        if (len.betapar != 0) {
          if (any(is.null(prior.beta.par) |  !is.matrix(prior.beta.par)) == TRUE) {
            stop('epimcmc: Specify prior.beta.par as a matrix with each row corresponds to each beta parameter')
          } else {
            j <- 1
            for (i in 1:ni) {
              if (prostdb[i] != 0){
                betapar[[j]][[2]] <- prior.beta.par[i,]
                j <- j + 1
              } else {
                j <- j
              }
            }
          }
        } else if (len.betapar == 0) {
          betapar[[1]][[2]] <- c(0, 0)
        }# end if - ni
      }

    } else if (is.null(object$contact)) {

      if (is.null(object$XYcoordinates)) {
        stop("epimcmc: Specify contact network or x, y coordinates")
      }

      ni <- length(beta.ini)

      if (ni > 1) {
        stop("epimcmc: The input of beta.ini has more than one value while the considered distance-based ILM needs only one spatial parameter, beta.")
      }

      if (any(is.null(prior.beta.dist) | !(all(prior.beta.dist %in% c("halfnormal", "gamma","uniform")))) == TRUE) {
        stop("epimcmc: Specify prior for beta as \"halfnormal\" ,  \"gamma\" or \"uniform\"  ", call. = FALSE)
      }

      if (length(pro.beta.var) != ni) {
        stop('epimcmc: Specify only one proposal variance for the spatial parameter beta, pro.beta.var')
      }

      if (length(prior.beta.dist) != ni) {
        stop('epimcmc: Specify only one prior distribution for the spatial parameter beta, prior.beta.dist')
      }

      flag.beta <- 1

      prostdb <- pro.beta.var

      betapar <- list(NULL)
      len.betapar <- ni - sum(prostdb == 0)
      betapar[[1]] <- list(NULL)
      if (len.betapar != 0){
        betapar[[1]][[1]] <- prior.beta.dist
      } else {
        betapar[[1]][[1]] <- "uniform" # just to fill the list and it is not being used at all.
      }
      # prior selection for kernel parameters
      if (len.betapar != 0) {
        if (any((prior.beta.dist == "gamma") | (prior.beta.dist == "uniform")) == TRUE) {
          if (is.null(prior.beta.par)) {
            stop('epimcmc: Specify prior.beta.par as a vector or a 1 by 2 matrix.')
          } else {
            betapar[[1]][[2]] <- prior.beta.par
          }
        } else if (prior.beta.dist == "halfnormal") {
          if (is.null(prior.beta.par)) {
            stop('epimcmc: Specify the variance of the half normal prior distribution for prior.beta.par.')
          } else {
            betapar[[1]][[2]] <- c(prior.beta.par[1], 0)
          }
        }

      } else if (len.betapar == 0) {
        betapar[[1]][[2]] <- c(0, 0)
      }
    }

    # SPARK parameter:

    if (!is.null(spark.ini)) {
      flag <- 1
      if (is.null(pro.spark.var)) {
        stop("epimcmc: Specify proposal variance for spark", call. = FALSE)
      }
      if (is.null(prior.spark.dist)) {
        stop("epimcmc22: Specify prior for spark", call. = FALSE)
      }
      if (any(is.null(prior.spark.dist) | !(prior.spark.dist %in% c("halfnormal", "gamma","uniform"))) == TRUE) {
        stop("epimcmc2: Specify prior for spark term as \"halfnormal\" ,  \"gamma\" or \"uniform\"  ", call. = FALSE)
      }
      sparkpar <- list(NULL)
      length(sparkpar) <- 2
      sparkpar[[1]] <- prior.spark.dist
      if (any((prior.spark.dist == "gamma") | (prior.spark.dist == "uniform")) == TRUE) {
        if (is.null(prior.spark.par)) {
          stop('epimcmc: Specify prior.spark.par as a vector or a 1 by 2 matrix.')
        } else {
          sparkpar[[2]] <- c(prior.spark.par)
        }
      } else if (prior.spark.dist == "halfnormal") {
        if (is.null(prior.spark.par)) {
          stop('epimcmc: Specify the variance of the half normal prior distribution for prior.spark.par.')
        } else {
          sparkpar[[2]] <- c(prior.spark.par[1], 0)
        }
      }

    } else if (is.null(spark.ini)) {
      flag <-  0
      sparkpar <- list(NULL)
      sparkpar[[2]] <- c(0, 0)
    }

    # proposal variance for  spark

    if (flag == 1) {
      prostdsp <- pro.spark.var
    } else {
      prostdsp <- 0.0
    }

    if (all(flag == 0 & flag.trans == 0 & flag.beta == 0) == TRUE) {
      mcmcscale <- c(prostda)
    } else if (all(flag == 0 & flag.trans == 0 & flag.beta == 1) == TRUE) {
      mcmcscale <- c(prostda, prostdb)
    } else if (all(flag == 0 & flag.trans == 1 & flag.beta == 0) == TRUE) {
      mcmcscale <- c(prostda, prostdt)
    } else if (all(flag == 0 & flag.trans == 1 & flag.beta == 1) == TRUE) {
      mcmcscale <- c(prostda, prostdt, prostdb)
    } else if (all(flag == 1 & flag.trans == 0 & flag.beta == 0) == TRUE) {
      mcmcscale <- c(prostda, prostdsp)
    } else if (all(flag == 1 & flag.trans == 0 & flag.beta == 1) == TRUE) {
      mcmcscale <- c(prostda, prostdb, prostdsp)
    } else if (all(flag == 1 & flag.trans == 1 & flag.beta == 0) == TRUE) {
      mcmcscale <- c(prostda, prostdt, prostdsp)
    } else if (all(flag == 1 & flag.trans == 1 & flag.beta == 1) == TRUE) {
      mcmcscale <- c(prostda, prostdt, prostdb, prostdsp)
    }

    scalemc <- mcmcscale[mcmcscale !=0]

    if (all(flag == 0 & flag.trans == 0 & flag.beta == 0) == TRUE) {
      mcmcinit <- c(sus.par.ini)
    } else if (all(flag == 0 & flag.trans == 0 & flag.beta == 1) == TRUE) {
      mcmcinit <- c(sus.par.ini, beta.ini)
    } else if (all(flag == 0 & flag.trans == 1 & flag.beta == 0) == TRUE) {
      mcmcinit <- c(sus.par.ini, trans.par.ini)
    } else if (all(flag == 0 & flag.trans == 1 & flag.beta == 1) == TRUE) {
      mcmcinit <- c(sus.par.ini, trans.par.ini, beta.ini)
    } else if (all(flag == 1 & flag.trans == 0 & flag.beta == 0) == TRUE) {
      mcmcinit <- c(sus.par.ini, spark.ini)
    } else if (all(flag == 1 & flag.trans == 0 & flag.beta == 1) == TRUE) {
      mcmcinit <- c(sus.par.ini, beta.ini, spark.ini)
    } else if (all(flag == 1 & flag.trans == 1 & flag.beta == 0) == TRUE) {
      mcmcinit <- c(sus.par.ini, trans.par.ini, spark.ini)
    } else if (all(flag == 1 & flag.trans == 1 & flag.beta == 1) == TRUE) {
      mcmcinit <- c(sus.par.ini, trans.par.ini, beta.ini, spark.ini)
    }

    initmc <- mcmcinit[mcmcscale!=0]

    p <- function(xx) {

      ms <- which(mcmcscale[1: ns] == 0)
      nns <- ns - length(ms)
      if (length(ms) != 0) {
        xs <- vector("double", length = ns)
        xs[ms] <- mcmcinit[ms]
        xs[-ms] <- xx[1: nns]
      } else {
        xs <- xx[1: nns]
      }

      if (flag.trans == 1) {
        mt <- which(mcmcscale[(1+ns): (ns+nt)] == 0)
        nnt <- nt - length(mt)
        if (length(mt) != 0) {
          xt <- vector("double", length = nt)
          xt[mt] <- mcmcinit[mt+ns]
          xt[-mt] <- xx[(1+nns): (nns+nnt)]
        } else {
          xt <- xx[(1+nns): (nns+nnt)]
        }
      } else {
        nnt <- 0
        xt <- NULL
      }

      if (flag.beta == 1) {
        if (flag.trans == 1) {
          mi <- which(mcmcscale[(1+ns+nt): (ns+nt+ni)] == 0)
        } else {
          mi <- which(mcmcscale[(1+ns): (ns+ni)] == 0)
        }
        nni <- ni - length(mi)

        if (flag.trans == 1) {
          if (length(mi) != 0) {
            xi <- vector("double", length = ni)
            xi[mi] <- mcmcinit[mi+ns+nt]
            xi[-mi] <- xx[(1+nns+nnt): (nns+nnt+nni)]
          } else {
            xi <- xx[(1+nns+nnt): (nns+nnt+nni)]
          }
        } else {
          if (length(mi) != 0) {
            xi <- vector("double", length = ni)
            xi[mi] <- mcmcinit[mi+ns+nnt]
            xi[-mi] <- xx[(1+nns+nnt): (nns+nnt+nni)]
          } else {
            xi <- xx[(1+nns+nnt): (nns+nnt+nni)]
          }
        }
      } else {
        nni <- 0
        xi <- NULL
      }

      if (flag == 1) {
        if(length(xx) > nns+nnt+nni) {
          xsp <- xx[nns+nnt+nni+1]
        } else if (all(length(xx) == nns+nnt+nni & mcmcscale[ns+nt+ni+1] == 0) == TRUE) {
          xsp <- mcmcinit[ns+nt+ni+1]
        }
      } else {
        xsp <- NULL
      }

      loglikeILM <- epilike(object = object, tmin = tmin, tmax = tmax, sus.par = xs,
                            trans.par = xt, beta = xi, spark = xsp,
                            Sformula = Sformula, Tformula = Tformula)

      if (nns != 0) {
        palpha = 0
        for (i in 1:nns) {
          if (alphapar[[i]][[1]] == "uniform") {
            palpha <- palpha + dunif(xx[i], min = alphapar[[i]][[2]][1],
                                     max = alphapar[[i]][[2]][2], log = TRUE)
          } else if (alphapar[[i]][[1]] == "gamma") {
            palpha <- palpha + dgamma(xx[i], shape = alphapar[[i]][[2]][1],
                                      rate = alphapar[[i]][[2]][2], log = TRUE)
          } else if (alphapar[[i]][[1]] == "halfnormal") {
            palpha <- palpha + dhalfnorm(xx[i], scale = alphapar[[i]][[2]][1], log = TRUE)
          }
        }
      } else {
        palpha = 0
      }

      if (all(flag.trans == 1 & nnt != 0) == TRUE) {
        pphi = 0
        for (i in 1:nnt) {
          if (phipar[[i]][[1]] == "uniform") {
            pphi <- pphi + dunif(xx[i+nns], min = phipar[[i]][[2]][1],
                                 max = phipar[[i]][[2]][2], log = TRUE)
          } else if (phipar[[i]][[1]] == "gamma") {
            pphi <- pphi + dgamma(xx[i+nns], shape = phipar[[i]][[2]][1],
                                  rate = phipar[[i]][[2]][2], log = TRUE)
          } else if (phipar[[i]][[1]] == "halfnormal") {
            pphi <- pphi + dhalfnorm(xx[i+nns], scale = phipar[[i]][[2]][1], log = TRUE)
          }
        }
      } else {
        pphi = 0
      }

      if (nni != 0) {
        pbeta = 0
        for (i in 1:nni) {
          if (betapar[[i]][[1]] == "uniform") {
            pbeta <- pbeta + dunif(xx[i+nns+nnt], min = betapar[[i]][[2]][1],
                                   max = betapar[[i]][[2]][2], log = TRUE)
          } else if (betapar[[i]][[1]] == "gamma") {
            pbeta <- pbeta + dgamma(xx[i+nns+nnt], shape = betapar[[i]][[2]][1],
                                    rate = betapar[[i]][[2]][2], log = TRUE)
          } else if (betapar[[i]][[1]] == "halfnormal") {
            pbeta <- pbeta + dhalfnorm(xx[i+nns+nnt], scale = betapar[[i]][[2]][1], log = TRUE)
          }
        }
      } else {
        pbeta = 0
      }

      if (flag == 1) {
        if (sparkpar[[1]] == "uniform") {
          pspark <- dunif(xx[nns+nnt+nni+1], min = sparkpar[[2]][1],
                          max = sparkpar[[2]][2], log = TRUE)
        } else if (sparkpar[[1]] == "gamma") {
          pspark <- dgamma(xx[nns+nnt+nni+1], shape = sparkpar[[2]][1],
                           rate = sparkpar[[2]][2], log = TRUE)
        } else if (sparkpar[[1]] == "halfnormal") {
          pspark <- pspark + dhalfnorm(xx[nns+nnt+nni+1], scale = sparkpar[[2]][1], log = TRUE)
        }
      } else {
        pspark = 0.0
      }

      return(loglikeILM + palpha + pphi + pbeta + pspark)
    }

    if (is.null(object$contact)) {
      kernel.type <- "distance-based discrete-time ILM"
      result <- MCMC(p = p, n = niter, init = initmc, scale = scalemc,
                     adapt = adapt, acc.rate = acc.rate)
    } else if (!is.null(object$contact)) {
      kernel.type <- "network-based discrete-time ILM"
      result <- MCMC(p = p, n = niter, init = initmc, scale = scalemc,
                     adapt = adapt, acc.rate = acc.rate)
    }

    alphanames <- c()
    for (i in 1:ns) {
      alphanames <- c(alphanames, paste("alpha.", i, sep = ""))
    }

    if (flag.trans == 1) {
      phinames <- c()
      for (i in 1:nt) {
        phinames <- c(phinames, paste("phi.", i, sep = ""))
      }
    }

    if (flag.beta == 1) {
      betanames <- c()
      for (i in 1:ni) {
        betanames <- c(betanames, paste("beta.", i, sep = ""))
      }
    }

    if (all(flag == 0 & flag.trans == 0 & flag.beta == 0) == TRUE) {
      nnames <- c(alphanames)
    } else if (all(flag == 0 & flag.trans == 0 & flag.beta == 1) == TRUE) {
      nnames <- c(alphanames, betanames)
    } else if (all(flag == 1 & flag.trans == 0 & flag.beta == 0) == TRUE) {
      nnames <- c(alphanames, "spark")
    } else if (all(flag == 1 & flag.trans == 0 & flag.beta == 1) == TRUE) {
      nnames <- c(alphanames, betanames, "spark")
    } else if (all(flag == 0 & flag.trans == 1 & flag.beta == 0) == TRUE) {
      nnames <- c(alphanames, phinames)
    } else if (all(flag == 0 & flag.trans == 1 & flag.beta == 1) == TRUE) {
      nnames <- c(alphanames, phinames, betanames)
    } else if (all(flag == 1 & flag.trans == 1 & flag.beta == 0) == TRUE) {
      nnames <- c(alphanames, phinames, "spark")
    } else if (all(flag == 1 & flag.trans == 1 & flag.beta == 1) == TRUE) {
      nnames <- c(alphanames, phinames, betanames, "spark")
    }

    finalnames <- nnames[mcmcscale!=0]

    Estimates <- data.frame(result$samples)
    colnames(Estimates) <- finalnames

    Loglikelihood <- c(result$log.p)
    #      colnames(Loglikelihood) <- "Loglikelihood"

    ki <- match(nnames,finalnames)

    nki <- which(nnames %in% finalnames)

    fullsamples <- matrix(0, ncol = length(nnames), nrow = niter)
    fullsamples[,nki] <- result$samples
    nnki <- which(is.na(ki))

    if (length(nnki) == 1) {
      fullsamples[,nnki] <- rep(mcmcinit[nnki], niter)
    } else if (length(nnki) > 1){
      for (i in 1:length(nnki)) {
        fullsamples[,nnki[i]] <- rep(mcmcinit[nnki[i]], niter)
      }
    }
  }

  # mcmc result as a coda object

  if (flag.trans == 1) {
    n.trans.par <- nt
  } else {
    n.trans.par <- 0
  }
  if (flag.beta == 1) {
    n.ker.par <- ni
  } else {
    n.ker.par <- 0
  }

  output <- list(type = object$type, kernel.type = kernel.type, Estimates = Estimates,
                 Loglikelihood = Loglikelihood, Fullsample = fullsamples,
                 n.sus.par = ns, n.trans.par = n.trans.par, n.ker.par = n.ker.par)

  class(output) <- "epimcmc"
  output

} # End of function

summary.epimcmc <- function(object, ...) {
  if (!is(object, "epimcmc")) {
    stop("The object has to be of \"epimcmc\" class", call. = FALSE)
  }
  if (object$type == "SI") {
    cat(paste("Model:", object$type, object$kernel.type,"\n"))
    cat(paste("Method: Markov chain Monte Carlo (MCMC) \n"))
    summary(window(mcmc(object$Estimates), ...))
  } else if (object$type == "SIR") {
    cat(paste("Model:", object$type, object$kernel.type,"\n"))
    cat(paste("Method: Markov chain Monte Carlo (MCMC) \n"))
    summary(window(mcmc(object$Estimates), ...))
  }
}

plot.epimcmc <- function(x, partype, start = 1, end = NULL, thin = 1, ...) {
  if (is.null(end)) {
    end = nrow(x$Estimates)
  }
  if (!is(x, "epimcmc")) {
    stop("The object x has to be of \"epimcmc\" class", call. = FALSE)
  }
  if (partype == "parameter") {
    plot(window(as.mcmc(x$Estimates), start = start, end = end, thin = thin), ...)
  } else if (partype == "loglik") {
    plot(window(as.mcmc(x$Loglikelihood), start = start, end = end, thin = thin), ...)
  }
}


library(shiny)

shinyUI(
  fluidPage(
  titlePanel("Interactive Normal Distribution"),
  sidebarLayout(
    sidebarPanel(
      sliderInput("obs", "Select the number of observations", min = 1, max = 1000, val = 100),
      br(),
      sliderInput("mean", "Select the mean for the Normal Distribution", min = -10, max = 10, val = 0),
      br(),
      sliderInput("sd", "Select the standard deviation of the Normal Disribution", min = 0, max = 10, val = 1),
      br(),
      radioButtons("colour", "Select the colour of the histogram or line drawing",
                   choices=c("Blue" = "cadetblue3",
                             "Purple" = "violet",
                             "Green" = "darkseagreen")),
      downloadButton("down", "Download"),
      br(),
      helpText("Click the download button to download the data currently being shown")
    ),
    mainPanel(
      tabsetPanel(type = "tabs",
                  tabPanel("Histogram", plotOutput("plot")),
                  tabPanel("Line Drawing", plotOutput("line"), helpText("Note that the number of observations
                                                                        no longer matters; this is simply displaying the
                                                                        distribution with the specified mean and SD.")),
                  tabPanel("Summary", verbatimTextOutput("summary")),
                  tabPanel("Table of Generated Values", tableOutput("table")))

    )
  )
)
)


#dod方法下的射出频率与参数之间的关系
#########说明########
#乙二醇液体
#voltage_pluse，说明高峰电压和基准电压下的射出时间ms
#duty_pluse，随着fv电压频率上升，占空比不同时的射出时间
#height，不同占空比下，随fv上升，弯月面高度的变化
#angle，同上，弯月面锥角的变化
#flowrate_pulse，不同占空比下，随流量变化的射出时间
#flowrate_height，此时的弯月面高度
#flowrate_angle，弯月面角度的变化
#setduty_pulse, 固定占空比为50%时，不同电压频率下，不同流量下的射出时间
#setduty_height，同上，弯月面高度
#setduty_angle，同上，弯月面锥角

#####第一组：随电压频率上升，不同占空比下的射出时间和弯月面信息#####
#####第二组：固定电压频率下，不同流量，不同占空比下的射出时间和弯月面信息####
#####第三组：固定占空比下，不同流量，不同电压频率的射出时间和弯月面信息####

#设定工作区间
setwd("D:/data")
library(xlsx)

setp<-read.xlsx("dod_v_pulse.xls", sheetName = "setduty_pulse", header = TRUE)
seth<-read.xlsx("dod_v_pulse.xls", sheetName = "setduty_height", header = TRUE)
seta<-read.xlsx("dod_v_pulse.xls", sheetName = "setduty_angle", header = TRUE)
#规划区域
par(mfrow=c(2,2), mar=c(4,4,2,2), oma=c(2,1,1,1))

#保存pdf
#pdf("dod_frequency.pdf")

#固定占空比为20%

################################画图-流量与pulse射出时间的关系###########################
plot(setp$flowrate, setp$X10, col=0, xaxs="i", xlim=c(0, 0.001), ylim=c(0.2, 0.5),
xlab="Flow rate (ml/min)", cex.lab=1.2, ylab="Pulse time (ms)", main="Pulse time in various fv", cex.main = 1.5)

model1 = loess(setp$X10~setp$flowrate)
lines(setp$flowrate,  model1$fit, col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

model2 = loess(setp$X25~setp$flowrate)
lines(setp$flowrate,  model2$fit, col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

model3 = loess(setp$X50~setp$flowrate)
lines(setp$flowrate,  model3$fit, col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

model4 = loess(setp$X75~setp$flowrate)
lines(setp$flowrate, model4$fit, col="#EEAD0E", pch=24, lwd=2.5, type="b", lty=2)

legend("bottomright", c("10Hz", "25Hz", "50Hz", "75Hz"), inset=.05, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E"), pch=c(21,22,23, 24), lwd=1.5, lty=2, cex=1.2, bty="n")

################################画图-信息###########################

plot(setp$flowrate, setp$X10,  yaxt="n", xaxt= "n", col=0,  xlab="", ylab="", xlim=c(0,0.001), ylim=c(1, 3), main="Information", cex.main = 1.5)
text(0.00025, 2.8, "Liquids - Ethylene glycol", col="black", adj=0, cex=1.5)
text(0.00025, 2.5, "Distance - 1mm", col="black", adj=0, cex=1.5)
text(0.00025, 2.2, "Nozzle - 24G - 0.55mm", col="black", adj=0, cex=1.5)
text(0.00025, 1.9, "Flowrate -  0.0002ml/min", col="black", adj=0, cex=1.5)
text(0.00025, 1.6, "Voltage frequency - 20Hz", col="black", adj=0, cex=1.5)
text(0.00025, 1.3, "Duty cycle - 20%", col="black", adj=0, cex=1.5)

#legend("bottomleft", c("k=0.1", "k=0.2", "k=0.3", "k=0.5", "k=0.8"), inset=.05, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E", "#27408B"), pch=c(21,22,23,24,25), lwd=1.5, lty=2, cex=1.2, bty="n")

#################################画图--弯月面高度#############################
plot(seth$flowrate, seth$X10, col=0, xaxs="i", xlim=c(0, 0.001), ylim=c(0.3, 0.4),
xlab="Flow rate (ml/min)", cex.lab=1.2, ylab="Height of Meniscus (mm)", main="Meniscus height in various fv", cex.main = 1.5)

lines(lowess(seth$flowrate, seth$X10), col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

lines(lowess(seth$flowrate, seth$X25), col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

lines(lowess(seth$flowrate, seth$X50), col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

lines(lowess(seth$flowrate, seth$X75), col="#EEAD0E", pch=24, lwd=2.5, type="b", lty=2)

legend("bottomright", c("10Hz", "25Hz", "50Hz", "75Hz"), inset=.05, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E"), pch=c(21,22,23,24), lwd=1.5, lty=2, cex=1.2, bty="n")

###############################画图--弯月面角度#############################
plot(seta$flowrate, seta$X10, col=0, xaxs="i",xlim=c(0, 0.001), ylim=c(65, 90),
xlab="Flow rate (ml/min)", cex.lab=1.2, ylab="Taylor fale (°)", main="Meniscus Angle in various fv", cex.main = 1.5)

lines(lowess(seta$flowrate, seta$X10), col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

lines(lowess(seta$flowrate, seta$X25), col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

lines(lowess(seta$flowrate, seta$X50), col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

lines(lowess(seta$flowrate, seta$X75), col="#EEAD0E", pch=24, lwd=2.5, type="b", lty=2)

legend("topright", c("10Hz", "25Hz", "50Hz", "75Hz"), inset=.05, col=c("#458B74", "#FF00FF", "#EE0000", "#EEAD0E"), pch=c(21,22,23,24), lwd=1.5, lty=2, cex=1.2, bty="n")

#mtext("乙二醇 | H = 1mm | Nozzle 24G | Q = 0.0002ml/min | Fv = 20Hz | Duty = 20%", 1, line=1, col="black", cex=1.3, font=2, outer=TRUE)

#dev.off()


wideScreen()

task_definitions <- generate_task_csvs_for_cat(7,1)
# make_nice_task_animation(task_definitions)

mylen <- 10
set_choice <- sample(1:31)[1:mylen]
input_H <- cat1$H_matrix[,set_choice]
input_bounds <- cat1$bounds_tuple_of_numeric[1:mylen]
const_C <- generate_tasks_and_corresponding_constraints_via_df(input_H, task_definitions$redirection_tasks, input_bounds)
# nored_constraints <- pbmclapply(const_C$constraints, eliminate_redundant)
p_per_C <- lapply(const_C$constraints,har_sample,100)
variances <- lapply(p_per_C, function(x) {apply(x, 2, var)}) %>% dcrb
print("set_choice")
print(set_choice)
print(variances)

if(all(c(
	every_solution_is_ind_valid(p_per_C, const_C$constraints)))){
	print("All sampled solutions meet set requirements")
} else{
	print("Error: sample does not match constraints")
}

to_midpt <- diagonal_merge_constraint_list(const_C$constraints)
to_midpt %>% har_sample(10)

velocity_constraint <- generate_full_velocity_constraint(to_midpt, 1.0, 1.0, mylen)
constraint_with_velocity_requirements <- merge_constraints(to_midpt,velocity_constraint)

Q
culled <- function(B, A, max_delta){
	a_connections_per_soln_in_b <- pbapply(B, 1, function(b_soln){
		max_delta_vals <- apply(A, 1, function(a_soln){
				return(max(abs(b_soln[1:31] - a_soln[1:31])))
				})
		print(summary(max_delta_vals))
		return(max_delta_vals < max_delta)
		})
	return(B[a_connections_per_soln_in_b,])
}
L <- lapply(p_per_C, function(x){
	x$solution_id <- 1:nrow(x)
	rr <- data.table(x)
	# rr %>% setorder("adf")
	return(rr[1:10000])
	})

L_out <- list()
#initialization
L_prime_i <- L[[1]]
for (i in seq(1,9)) {
	L_prime_i <- culled(L[[i + 1]], L_prime_i, 0.125)
	L_out <- c(L_prime, L_prime_i)
}

muscle_bounds <- get_muscle_bounds_for_rhs_task(nulltask)

nulltask <- const1$constraints[[1]]
get_muscle_bounds_for_rhs_task(nulltask)

nored <- pbmclapply(const1$constraints, eliminate_redundant)
nonred_then_diag <- diagonal_merge_constraint_list(nored)

bigg <- diagonal_merge_constraint_list(const1$constraints)

d <- fread("data/nine_task_equivalence_matrix.csv",skip=1)[,2:10]
d[is.na(d)] <- 0
c_in_cTx <- rep(1,ncol(bigg$constr))
#minimize l1 sum activation
lp_result <- lp("min", objective.in = c_in_cTx, const.mat = bigg$constr,
    const.dir = bigg$dir, const.rhs = bigg$rhs,
    compute.sens = 0)

pbapply(a,1,function(myrow){
	# matrix_subtraction where myrow is the nth element of the first task matrix
	# where b is the entire second task matrix
	starting_point_bigmat <- as.matrix(t(replicate(nrow(b), a[1,])))
	difference_matrix <- as.matrix(b) - starting_point_bigmat
	viable_row_indices <- sapply(difference_matrix, 1, function(x) which(max(abs(x)) < 0.01))
	return(viable_row_indices)
	})

##########

merged_const <- diagonal_merge_constraint_list(const1$constraints)
generate_and_add_velocity_constraint(merged_const, 1,
    1, 31)

directions <- cbind(rbind(diag(3),diag(3)*-1),zeros(6,3))
colnames(directions) <- rownames(cat1$H_matrix)
rownames(directions) <- c("dir_+x",
							"dir_+y",
							"dir_+z",
							"dir_-x",
							"dir_-y",
							"dir_-z")
directional_mvcs <- apply(directions,1,function(direction){
	solution <- maximize_wrench(cat1$H_matrix[,1:20], cat1$bounds_tuple_of_numeric[1:20], direction = direction)
	return(solution$lambda_values)
	})
print(directional_mvcs)


library(plotly)
data<-read.csv("ElectricCarData_Clean.csv",header = TRUE)
fig <- plot_ly(data, x=~RapidCharge,y = ~PriceEuro,color =~RapidCharge, type = "box", boxpoints = "all", jitter = 0.3,
               pointpos = -1.8)

fig


# This script takes the brownfields data and adds a new column called
# `On Tribal Lands` indicating whether or not a property was found to
# be on tribal lands.

# Limitations of this methodology and script warnings:
# 1. A property is represented entirely by a single
#    (longitude, latitude) point. It's possible that the property
#    overlaps with tribal lands, but the single point representing the
#    property does not -- In this case, this script erroneously says that
#    property is not on tribal lands.
# 2. Tribal lands are defined as the union of the following areas:
#    * 2019 Tribal Census Tracts
#    * 2019 Alaska Native Regional Corporations
#    * 2019 American Indian/Alaska Native/Native Hawaiian Areas National
# 3. Running this script for the first time involves downloading ~10 MB
#    worth of shapefiles.
# 4. The last section of the script `GENERATE CSV WITH TRIBAL INDICATOR`
#    may take a very long time to run.

library(sp)
library(tigris)
# setwd("<path-to-repo>/scripts/rebecca-burwei")

######## FUNCTIONS AND OBJECTS #############################

# Downloads spatial polygons for tribal lands from Census,
# or loads them from cache if previously downloaded.
options(tigris_use_cache = TRUE)
tribal <- tribal_census_tracts()
tribal <- c(
  as(alaska_native_regional_corporations(), "Spatial"),
  as(native_areas(), "Spatial"),
  as(tribal_census_tracts(), "Spatial")
)

is_tribal <- function(longitude, latitude){
  # Arguments: Must provide longitude, latitude in decimal degrees format.
  # Returns: True if the (long, lat) point is on tribal lands,
  #          False if it's not,
  #          NA if inputs are invalid.

  # Return NA if either input is NA.
  if(is.na(longitude) | is.na(latitude)){
    return(NA)
  }

  # Convert longitude, latitude into standard format
  coords <- cbind(longitude, latitude)
  spdf <- SpatialPointsDataFrame(coords, data.frame(ID=1:1))

  # Check if the point is in any of the tribal polygons
  for(polygons in tribal){
    proj4string(spdf) <- proj4string(polygons)
    result <- over(spdf, polygons)
    if(sum(!is.na(result)) > 0){
      # If `result` contains any non-NAs, then a match was found,
      # and the point is on tribal lands
      return(TRUE)
    }
  }
  return(FALSE)
}

######## UNIT TESTS ##########################################

# Check that O'Hare airport is not on tribal lands
if(is_tribal(-87.836723, 41.977226) == TRUE){
  stop("Unit test failed for `is_tribal` function.")
}

# Check that the Navajo Nation Welcome Center is on tribal lands
if(is_tribal(-109.18735977257617, 36.06740957280979) == FALSE){
  stop("Unit test failed for `is_tribal` function.")
}

######## GENERATE CSV WITH TRIBAL INDICATOR ###################
######## This section is slow to run.

# Run is_tribal function on brownfields data
dat <- read.csv("../../data/brownfields_data_with_county_geoid/brownfields_data_with_county_geoid.csv")
dat["Property.Longitude"] <- as.numeric(as.character(dat$Property.Longitude))
dat["Property.Latitude"] <- as.numeric(as.character(dat$Property.Latitude))
dat["On.Tribal.Lands"] = apply(
  dat[, c("Property.Longitude","Property.Latitude")], 1, function(x) is_tribal(x[1],x[2])
  )
print(summary(dat$On.Tribal.Lands))

# Write new CSV with On.Tribal.Lands field
write.csv(dat,
  "../../data/_volunteer_created_datasets/brownfields_data_with_on_tribal_lands.csv"
)

#9:10


#upload library
library(VennDiagram)

#Then generate 3 sets of words.There I generate 3 times 200 SNPs names.
SNP_pop_1=paste(rep("SNP_" , 200) , sample(c(1:1000) , 200 , replace=F) , sep="")
SNP_pop_2=paste(rep("SNP_" , 200) , sample(c(1:1000) , 200 , replace=F) , sep="")
SNP_pop_3=paste(rep("SNP_" , 200) , sample(c(1:1000) , 200 , replace=F) , sep="")

#The goal of the Venn Diagram is to count how many words are common between SNP_pop_1 and SNP_pop_2, between SNP_pop_1 and SNP_pop_3 and so on...
#The venn.diagram function do it automatically and draw it! (you will get a png file in your current working directory)

venn.diagram(
x = list(SNP_pop_1 , SNP_pop_2 , SNP_pop_3),
category.names = c("SNP pop 1" , "SNP pop 2 " , "SNP pop 3"),
filename = '#14_venn_diagramm.png',
	output = TRUE ,
  	imagetype="png" ,
	height = 480 ,
	width = 480 ,
	resolution = 300,
	compression = "lzw",
	lwd = 2,
	lty = 'blank',
	fill = c('yellow', 'purple', 'green'),
	cex = 1,
	fontface = "bold",
	fontfamily = "sans",
	cat.cex = 0.6,
	cat.fontface = "bold",
	cat.default.pos = "outer",
	cat.pos = c(-27, 27, 135),
	cat.dist = c(0.055, 0.055, 0.085),
	cat.fontfamily = "sans",
	rotation = 1
	)


setwd("~/pCloudDrive/Profissional/ciencia-de-dados/codenation.dev/desafio_nota_do_enem")
getwd()

library(dplyr)     # Filtragens
library(psych)     # Scatterplot Matrix
library(e1071)     # SVM
library(rpart)     # RANDON FOREST
library(readr)     # GERAR CSV
library(tidyverse) # Drop_NA()
library(readxl)    # Importar xls
library(randomForest) # MODELO RANDONFOREST

# ****************************************************
# ***                   DADOS                      ***
# ***                                              ***
# ****************************************************
# Etapa 1 - Coletando os dados
# Para voltar ao estado normal comacurácia de 93.49 basta deixar as 3 primeiras linhas aqui antes da outra tratativa
tempo <- Sys.time()
# Prever notas faltantes de redação
source("reconstruir_dados_com_na.R", encoding = "UTF-8")
fim <- Sys.time()
tempo_para_prever_outras_notas <- fim - inicio
tempo_para_prever_outras_notas

notateste <- read.csv("test.csv")
PIB_2016 <- read_excel("PIB-2016.xls")

variaveis_descriminantes <- c("NU_NOTA_MT", "NU_NOTA_CN", "NU_NOTA_CH", "NU_NOTA_LC", "NU_NOTA_REDACAO", "Q006", "TP_ESCOLA", "Q047", "CO_UF_RESIDENCIA", "TP_SEXO", "NU_NOTA_COMP2", "Q001", "Q024", "NU_NOTA_COMP3", "NU_NOTA_COMP5", "NU_NOTA_COMP4", "NU_IDADE", "Q027", "NU_NOTA_COMP1", "SG_UF_RESIDENCIA")

nota <- nota[,variaveis_descriminantes]

colnames(nota)

# ****************************************************
# ***                   INCLUIR                    ***
# ***                NOVAS VARIÁVEIS               ***
# ****************************************************
#média do pib por estado
PIB_2016 = PIB_2016 %>% filter(Ano == 2016)
PIB_2016 = PIB_2016[c(names(PIB_2016)[5], names(PIB_2016)[42])]
MEDIA_PIB_2016 = aggregate(PIB_2016$`Produto Interno Bruto per capita\n(R$ 1,00)`,
                           by=list(PIB_2016$`Sigla da Unidade da Federação`),
                           FUN = mean)
colnames(MEDIA_PIB_2016) = c("SG_UF_RESIDENCIA","media")

# Criar regioes com os estados por prova
glimpse(notateste$SG_UF_RESIDENCIA)
table(notateste$SG_UF_RESIDENCIA)
x <- c(notateste$SG_UF_RESIDENCIA)
lookup <- c( AC = "NORTE",  AL = "NORDESTE",  AM = "NORTE",  AP = "NORTE",  BA = "NORDESTE", CE = "NORDESTE", DF = "CENTRO-OESTE", ES = "SUDESTE", GO = "CENTRO-OESTE", MA = "NORDESTE", MG = "SUDESTE", MS = "CENTRO-OESTE", MT = "CENTRO-OESTE", PA = "NORTE", PB = "NORDESTE", PE = "NORDESTE", PI = "NORDESTE", PR = "SUL", RJ = "SUDESTE", RN = "NORDESTE", RO = "NORTE", RR = "NORTE", RS = "SUL", SC = "SUL", SE = "NORDESTE", SP = "SUDESTE", TO = "NORTE")
uniao = lookup[x]
regioes = unname(uniao)
table(regioes)
notateste$regioes = regioes
table(notateste$regioes)
names(table(notateste$regioes))

#Transformar os dois datasets com as mesmas variáveis
notateste = merge(notateste,MEDIA_PIB_2016)
nomes <- names(notateste)

# Criar regioes com os estados por prova
glimpse(nota$SG_UF_RESIDENCIA)
table(nota$SG_UF_RESIDENCIA)
x <- c(nota$SG_UF_RESIDENCIA)
lookup <- c( AC = "NORTE",  AL = "NORDESTE",  AM = "NORTE",  AP = "NORTE",  BA = "NORDESTE", CE = "NORDESTE", DF = "CENTRO-OESTE", ES = "SUDESTE", GO = "CENTRO-OESTE", MA = "NORDESTE", MG = "SUDESTE", MS = "CENTRO-OESTE", MT = "CENTRO-OESTE", PA = "NORTE", PB = "NORDESTE", PE = "NORDESTE", PI = "NORDESTE", PR = "SUL", RJ = "SUDESTE", RN = "NORDESTE", RO = "NORTE", RR = "NORTE", RS = "SUL", SC = "SUL", SE = "NORDESTE", SP = "SUDESTE", TO = "NORTE")
uniao = lookup[x]
regioes = unname(uniao)
table(regioes)
nota$regioes = regioes
table(nota$regioes)
names(table(nota$regioes))

#Transformar os dois datasets com as mesmas variáveis
nota = merge(nota, MEDIA_PIB_2016)

# ****************************************************
# ***                   TREINO                     ***
# ***                                              ***
# ****************************************************
# Segmentando apenas os dados que temos no treino
treinando = nota
# ****************************************************
# ***              FORMATO NUMÉRICO                ***
# ****************************************************
glimpse(treinando)
#Transformar para numérico
treinando$SG_UF_RESIDENCIA = as.numeric(treinando$SG_UF_RESIDENCIA)
treinando$TP_SEXO = as.numeric(treinando$TP_SEXO)
treinando$Q001 = as.numeric(treinando$Q001)
treinando$Q006 = as.numeric(treinando$Q006)
treinando$Q024 = as.numeric(treinando$Q024)
treinando$Q047 = as.numeric(treinando$Q047)
treinando$regioes = as.factor(treinando$regioes)
treinando$regioes = as.numeric(treinando$regioes)

# excluir coluna SG_UF_RESIDENCIA
treinando = treinando[c(-1)]
nota = treinando
glimpse(nota)

# ****************************************************
# ***                   TESTE                      ***
# ***                                              ***
# ****************************************************

# Criar variável de segurança
testando = notateste
testando$Q027 = as.numeric(testando$Q027)

testando$TP_DEPENDENCIA_ADM_ESC = NULL
testando$TP_ENSINO = NULL

## LIMPEZA Retirando valores NA da tabela
testando = testando %>% drop_na()
any(is.na(testando))

# Transformar variaveis em numeric
testando$SG_UF_RESIDENCIA = as.numeric(testando$SG_UF_RESIDENCIA)
testando$TP_SEXO = as.numeric(testando$TP_SEXO)
testando$Q001 = as.numeric(testando$Q001)
testando$Q002 = as.numeric(testando$Q002)
testando$Q006 = as.numeric(testando$Q006)
testando$Q024 = as.numeric(testando$Q024)
testando$Q025 = as.numeric(testando$Q025)
testando$Q026 = as.numeric(testando$Q026)
testando$Q047 = as.numeric(testando$Q047)
testando$CO_PROVA_CN = as.numeric(testando$CO_PROVA_CN)
testando$CO_PROVA_CH = as.numeric(testando$CO_PROVA_CH)
testando$CO_PROVA_LC = as.numeric(testando$CO_PROVA_LC)
testando$CO_PROVA_MT = as.numeric(testando$CO_PROVA_MT)
testando$regioes = as.factor(testando$regioes)
testando$regioes = as.numeric(testando$regioes)
notateste = testando
testando$NU_INSCRICAO = NULL

# Vizualizar se os dados estão em estado numérico para envolver no algoritmo
glimpse(testando)

# ****************************************************
# ***               MODELOS DE ML                  ***
# ***                                              ***
# ****************************************************

##Regressão linear múltipla
# Etapa 3: Treinando o Modelo (usando os dados de treino)
modelo <- lm(NU_NOTA_MT ~ ., data = treinando)

# Visualizando os coeficientes
modelo

previsao1 <- predict(modelo, testando)
View(previsao1)

#treinando$Prev = previsao1

# Etapa 4: Avaliando a Performance do Modelo
# Mais detalhes sobre o modelo
summary(modelo)
####### -> 46%

# Lembre-se que correlação não implica causalidade

#### RANDONFOREST (Arvores de decisão) ####
trainset = treinando
testset = testando

# Modelo Tradicional
modelo_rf_v1 = rpart(NU_NOTA_MT ~ ., data = trainset, control = rpart.control( cp = .000999999999999999))
summary(modelo_rf_v1)

#Modelo Melhorado Ideal 600|40
model <- randomForest(NU_NOTA_MT ~
                        NU_NOTA_CN +
                        NU_NOTA_CH +
                        NU_NOTA_LC +
                        NU_NOTA_REDACAO +
                        Q006 +
                        TP_ESCOLA +
                        Q047 +
                        CO_UF_RESIDENCIA +
                        TP_SEXO +
                        NU_NOTA_COMP2 +
                        Q001 +
                        Q024 +
                        NU_NOTA_COMP3 +
                        NU_NOTA_COMP5 +
                        NU_NOTA_COMP4 +
                        NU_IDADE +
                        Q027 +
                        NU_NOTA_COMP1
                      ,
                      data = trainset,
                      ntree = 600,
                      nodesize = 50)

# Previsões nos dados de teste
tree_pred = predict(model, testset)

enviotree = data.frame(notateste$NU_INSCRICAO)
colnames(enviotree) = c("NU_INSCRICAO")
enviotree$NU_NOTA_MT = tree_pred

write.csv(enviotree, "answer.csv", row.names = FALSE)
# 93.51 %
# 93.49 % COM  SELEÇÃO DAS VARIÁVEIS --> NU_NOTA_MT ~ NU_NOTA_CN + NU_NOTA_CH + NU_NOTA_LC + NU_NOTA_REDACAO +  Q006 + TP_ESCOLA + Q047 + CO_UF_RESIDENCIA + TP_SEXO + NU_NOTA_COMP2 + media + Q001 + Q024 + NU_NOTA_COMP3 + NU_NOTA_COMP5 + NU_NOTA_COMP4 + NU_IDADE + Q027 + NU_NOTA_COMP1 + regioes
# 93.55 % Com Reconstrução dos dados

##FILTER SELECTION
modelo <- randomForest(NU_NOTA_MT ~ . ,
                       data = trainset,
                       ntree = 600,
                       nodesize =30,
                       importance = TRUE)

importance(modelo, scale = TRUE)

#Variáveis mais relevantes Importância das feautures

importancia_pred <- as.data.frame(importance(modelo, scale = TRUE))
importancia_pred <- rownames_to_column(importancia_pred, var = "variable")
p1 <- ggplot(data = importancia_pred, aes(x = reorder(variable, `%IncMSE`),
                                          y = `%IncMSE`,
                                          fill = `%IncMSE`)) +
  labs(x = "variable", title = "Redução do MSE") +
  geom_col() +
  coord_flip() +
  theme_bw() +
  theme(legend.position = "bottom")

p2 <- ggplot(data = importancia_pred, aes(x = reorder(variable, IncNodePurity),
                                          y = IncNodePurity,
                                          fill = IncNodePurity)) +
  labs(x = "variable", title = "Redução de pureza") +
  geom_col() +
  coord_flip() +
  theme_bw() +
  theme(legend.position = "bottom")

library(cowplot)
cowplot::plot_grid(p1, p2)


# model_vcov generic function ----
model_vcov <- function(model, ...) UseMethod("model_vcov", model)

# model_vcov lm and glm method ----
model_vcov.lm <- model_vcov.glm <- function(model, type = 0, var_cluster = NULL, ...) {

  # run checks ----
  if (!is.null(var_cluster) & nrow(model$model) != length(var_cluster)) stop("When using var_cluster, nrow(model$model) must equal length(var_cluster)!")

  # compute variance covariance matrix ----
  mat <- vcov(model)
  if(type == 0) {
    vcov_mat <- mat
  } else {
    if (type == 1 & !is.null(var_cluster)) {
      vcov_mat <- multiwayvcov::cluster.vcov(model, var_cluster)
    } else if (type == 2 & !is.null(var_cluster)) {
      vcov_mat <- multiwayvcov::cluster.boot(model, var_cluster, R = 1000, boot_type = "wild", wild_type = function() sample(c(-1, 1), 1))
    }
    colnames(vcov_mat) <- colnames(mat)
    row.names(vcov_mat) <- row.names(mat)
  }
  out <- list(model = model, vcov_mat = vcov_mat)

  # set attributes ----
  if (type == 0) {
    attr(out, "type") <- "standard"
    attr(out, "var_cluster") <- NULL
  } else if(type == 1){
    attr(out, "type") <- "robust"
    attr(out, "var_cluster") <- var_cluster
  } else if(type == 2){
    attr(out, "type") <- "robust_boot"
    attr(out, "var_cluster") <- var_cluster
  }
  class(out) <- c("mod_vcov", class(out))

  return(out)
}


library(ggplot2)

### Titanic: Machine Learning from Disaster ###

# Data Visualization #

# working directory
setwd("/your-path/titanic-ml")

# reading feature engineered and raw data
train = read.csv("./engineered-data/train_notenc.csv")
test = read.csv("./engineered-data/test_notenc.csv")
torig = read.csv("train.csv")

# sex, age, fare and class
ggplot(aes(x=train$Sex, y=train$Age, color=as.factor(train$Survived)), data=train) + geom_point()
ggplot(aes(x=train$Sex, y=train$Fare, color=as.factor(train$Survived)), data=train) + geom_point()
ggplot(aes(x=train$Age, y=train$Fare, color=as.factor(train$Survived)), data=train) + geom_point()
ggplot(aes(x=train$family_size, y=train$Fare, color=as.factor(train$Survived)), data=train) + geom_point()
ggplot(aes(x=train$family_size, y=train$Age, color=as.factor(train$Survived)), data=train) + geom_point()

# position on the boat: front, middle ,aft
ggplot(aes(x=train$Fare, y=train$room_pos, color=as.factor(train$Survived)), data=train) + geom_point()
ggplot(aes(x=train$Age, y=train$room_pos, color=as.factor(train$Survived)), data=train) + geom_point()

# position on the boat: deck number
ggplot(aes(y=train$Fare, x=train$deck, color=as.factor(train$Survived)), data=train) + geom_point()
ggplot(aes(y=train$Age, x=train$deck, color=as.factor(train$Survived)), data=train) + geom_point()
ggplot(aes(y=train$family_size, x=train$deck, color=as.factor(train$Survived)), data=train) + geom_point()

# title
ggplot(aes(x=train$Title, y=train$Age, color=as.factor(train$Survived)), data=train) + geom_point()
ggplot(aes(x=train$Title, y=train$Fare, color=as.factor(train$Survived)), data=train) + geom_point()
ggplot(aes(x=train$Title, y=train$family_size, color=as.factor(train$Survived)), data=train) + geom_point()

# familiy surnames
ggplot(aes(x=train$Surname, y=train$Age, color=as.factor(train$Survived)), data=train) + geom_point()
ggplot(aes(x=train$Surname, y=train$Fare, color=as.factor(train$Survived)), data=train) + geom_point()


require(ggplot2)

dataset <-read.table("../Processed/move_count.csv", header=TRUE, sep=",")

p1 <- ggplot(dataset, aes(x=move_count)) + geom_histogram(binwidth=1)
ggsave(plot=p1, file="move_count_distribution.pdf")

dataset <- read.table("../Processed/elo.csv", header=TRUE, sep=",")

p2 <- ggplot(dataset,aes(x=WhiteElo))+geom_histogram(binwidth=10)
ggsave(plot=p2, file="white_elo_distribution.pdf")


# extremes
library(dplyr)

species_traits <- read.csv("data/species_and_their_traits.csv", header=TRUE, stringsAsFactors = FALSE)

sla <- species_traits %>%
    select(-count) %>%
    filter(TraitName == "Leaf area per leaf dry mass (specific leaf area, SLA or 1/LMA): petiole excluded") %>%
    mutate(TraitName = "SLA") # Make the trait name easier to work with))

extreme_species_quad <- sla %>%
    group_by(City, quadrat) %>%
    filter(value == min(value) | value==max(value)) %>%
    arrange(City, quadrat, value)

extreme_species_city <- sla %>%
    group_by(City) %>%
    filter(value == min(value) | value==max(value)) %>%
    arrange(City, value)

extreme <- sla %>%
    filter(value == min(value) | value==max(value)) %>%
    arrange(value)


source(file.path(PROJECT_DIR, "R/functions/load_sig.r"))

fn.cd38.cor = file.path(PROJECT_DIR, "generated_data", "CHI", "robust_corr_genes.txt")
fn.cd38.cor.all = file.path(PROJECT_DIR, "generated_data", "CHI", "robust_corr_all.genes.txt")
df.rob = read.table(fn.cd38.cor.all, sep="\t", header = TRUE, row.names = NULL)

fn.stab = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_genes_stability.txt")
df.stab = read.table(fn.stab, sep="\t", header = TRUE, row.names = 1)

# test signature
ng=20
gene.sig = load_sig(fn.cd38.cor, "cor.mean.sd.ratio", ntop=ng)

isv.seq = seq(0,1,by=0.05)
mat.rank = matrix(nrow=length(isv.seq), ncol=length(gene.sig))
rownames(mat.rank) = isv.seq
colnames(mat.rank) = gene.sig

df.comb = cbind(df.rob, df.stab) %>%
  arrange(-cor.mean.sd.ratio)

for(i in seq_along(isv.seq)) {
  gi = df.comb$ISV >= isv.seq[i]
  mat.rank[i,] = match(gene.sig, df.comb$gene[gi]) / sum(gi)
}
isv.ng = sapply(isv.seq, function(x)sum(df.comb$ISV>=x))

df.rank = mat.rank %>% as.data.frame() %>%
  tibble::rownames_to_column("ISV.th") %>%
  gather("gene","rank",-ISV.th) %>%
  mutate(ISV.th = as.numeric(ISV.th), gene = factor(gene, levels=gene.sig))

ggplot(df.rank, aes(ISV.th, rank, group=gene, col=gene)) +
  geom_vline(xintercept = 0.75, col="black", lty = 1) +
  geom_line(size=1) +
  geom_point(fill="white", size=1, shape=21, stroke=1) +
  scale_x_reverse() +
  scale_y_reverse() +
  xlab("ISV threshold") +
  ylab("relative rank") +
  theme_bw() +
  theme(legend.key.size = unit(0.4, "cm"))

fn.fig = file.path(PROJECT_DIR, "figure_generation", "CD38.20gene.sig.rank.rel_vs_ISV.th")
ggsave(paste0(fn.fig,".png"), w=5,h=4)
ggsave(paste0(fn.fig,".pdf"), w=5,h=4)


#--------------------------------------------------------------------------
# Extract subsets of data from the original netcdf files
# from SOUTH to NORTH
#
# "/data02/PostClim/PostClim_qiyu"
#
#   "../obs/1970.rds,...,2005.rds" => could further include obs.2006-2015
#   "../MPI_SMHI-RCA4/19700101-19701231.rds,...,20010101-20051231.rds"
#
#--------------------------------------------------------------------------

rm(list=ls())
library(ncdf4)

## SeNorge
#-----------

# Original netcdf is from North to South, so need to
# Flip a matrix, then convert to a vector
mat2vec <- function(x){
  x.flip <- x[,ncol(x):1]
  c(x.flip)
}

# Boundaries
x_start <- 236; x_size <- 341
y_start <- 740; y_size <- 381

# Write
dir <- "//hdata/grid/metdata/met_obs_v2.1/tm/archive"
files <- list.files(dir)
subfiles <- files[14:49] # since 14=year=1970; 49=year=2005
years <- seq(1970,2005,1)
filenames <- paste(dir,subfiles,sep = "/")

for (j in 1:36){
  nc <- nc_open(filenames[j],readunlim=F)
  nt <- nc$dim$time$len
  mylist <- list()
  for (i in 1:nt){
    mylist[[i]] <- ncvar_get(nc, "mean_temperature",
                             start=c(x_start,y_start,i),
                             count=c(x_size, y_size,1))
  }
  tmlist <- lapply(mylist, mat2vec)
  nc_close(nc)
  year <- years[j]
  dat.mat <- do.call(cbind,tmlist)
  rdsname <- paste("/data02/PostClim/PostClim_qiyu/obs/",year,".rds",sep="")
  saveRDS(dat.mat,rdsname)
}
#-------------

## RCM
#-----------

# Boundaries
x_start <- 217; x_count <- 32
y_start <- 316; y_count <- 34

# Choose one RCM
RCM <- "MPI_SMHI-RCA4"
dir <- paste("/data/MetData/",RCM,"/Temp/ctrl/netcdf",sep="")
filelist <- list.files(dir)
#"tas_EUR-11_MPI-M-MPI-ESM-LR_historical_r1i1p1_SMHI-RCA4_v1a_day_19700101-19701231.nc"

for (j in 1:length(filelist)){
  year <- substr(filelist[j],65,81)  #"19700101-19701231"
  nc <- nc_open(file.path(dir,filelist[j]),readunlim=F)
  nt <- nc$dim$time$len
  mylist <- list()
  for (i in 1:nt){
    d <- ncvar_get(nc,"tas",start=c(x_start,y_start,i),count=c(x_count,y_count,1))
    mylist[[i]] <- c(d)
  }
  nc_close(nc) #original netcdf is from South to  North
  dat.mat <- do.call(cbind,mylist)
  rdsname <- paste("/data02/PostClim/PostClim_qiyu/",RCM,"/",year,".rds",sep="")
  saveRDS(dat.mat,rdsname)
}


# Parallel programming

# A. CPUs
# By default R uses 1 core when processing
# 1. Check for number of cores
# Load the parallel package
library(parallel)

# Store the number of cores in the object no_of_cores
no_of_cores <- detectCores()

# Print no_of_cores
no_of_cores

# B. Moving to parApply
# Determine the number of available cores
detectCores()

# Create a cluster via makeCluster
cl <- makeCluster(2)

# Parallelize this code. dd: relates to the DataFrame
parApply(cl, dd, 2, median)

# Stop the cluster
stopCluster(cl)

# C. Using parSapply
# play() function game
play <- function() {
  total <- no_of_rolls <- 0
  while(total < 10) {
    total <- total + sample(1:6, 1)

    # If even. Reset to 0
    if(total %% 2 == 0) total <- 0
    no_of_rolls <- no_of_rolls + 1
  }
  no_of_rolls
}

library("parallel")
# Create a cluster via makeCluster (2 cores)
cl <- makeCluster(2)

# Export the play() function to the cluster. Makes it easier to work with the function in a cluster
clusterExport(cl, "play")

# Re-write sapply as parSapply
res <- parSapply(cl, 1:100, function(i) play())

# Stop the cluster
stopCluster(cl)

# D. Timing parSapply
# Set the number of games to play
no_of_games <- 1e5

## Time serial version
system.time(serial <- sapply(1:no_of_games, function(i) play()))

## Set up cluster
cl <- makeCluster(4)
clusterExport(cl, "play")

## Time parallel version
system.time(par <- parSapply(cl, 1:no_of_games, function(i) play()))

## Stop cluster
stopCluster(cl)


data

design <- matrix(0, nrow=36, ncol=36)
design

X <- read.csv("~/Desktop/designMatrix.csv", header=FALSE)

dig <- diag(1, nrow=36, ncol=36)

nm <- c("u", paste("g", 1:9, sep=""), paste("s", 1:36, sep=""))
X <- cbind(X, dig)
X <- as.matrix(X)
fit <- lm(sample$Yield ~ X)
names(X) <- nm


#' clomin_custom
#'
#' Calculate minimal custom clothing insulation value required to reach thermal comfort in moderate thermal environments ( -0.5 < PMV <0.5) based on PMV ISO 7730.
#'
#' @param t numeric        Air temperature in degC.
#' @param rh numeric       Air Relative humidity in percentage.
#' @param wind numeric     Wind speed in meters per second.
#' @param tr numeric       Mean radiant temperature in degC.
#' @param age   numeric    Age in years.
#' @param mbody numeric    Body Mass in kg.
#' @param ht numeric       Heigth of subject in meters.
#' @param gender character Sex of the subject. Default is "male" otherwise "female".
#' @return clomin_custom
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  minimal clo
#' @export
#'
#'
#'
#'

clomin_custom=function(t,rh,wind,tr,age,mbody,ht,gender="male")  {
  ct$assign("t", as.array(t))
  ct$assign("rh", as.array(rh))
  ct$assign("wind", as.array(wind))
  ct$assign("mtrad", as.array(tr))
  ct$assign("age", as.array(age))
  ct$assign("mbody", as.array(mbody))
  ct$assign("ht", as.array(ht))
  ct$assign("gender", as.array(gender))
  ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=clomin_custom(t[i],rh[i],wind[i],mtrad[i],age[0],mbody[0],ht[0],gender[0])};")
  res=ct$get("res")
  return(ifelse(res==9999,NA,res))
}


# Left-handedness Methylation scores calculation: based on weights from ALSPAC adults EWAS and DNA methylation data from NTR adults
# V.Odintsova, J.van Dongen

# Load data
# load methylation data NTR adults with samples in rows, CpGs in columns (beta)
# load covariates NTR adults (covariates)
# load summary statistics ALSPAC adults EWAS (all_weights)

# Create weight datasets with CpGs at 3 p-value thresholds (10^-1,10^-3,10^-5)
model1 <- all_weights[which(all_weights$P < 10^-1),]
model2 <- all_weights[which(all_weights$P < 10^-3),]
model3 <- all_weights[which(all_weights$P < 10^-5),]

# Calculate scores
calc_scores <- function (model) {
  OL <- intersect(colnames(beta),rownames(model))
  weights <- model[OL,]
  met <- beta[,OL]
  Nsubjects <- nrow(met)
  NCpGs <- ncol(met)
  products <- matrix(NA,nrow=Nsubjects, ncol=NCpGs)
  for (i in 1:Nsubjects) {
    for (j in 1:NCpGs)  {
      products[i,j] <- met[i,j] * weights[j,"Estimate"]  }}
  score <- rowSums(products,na.rm=T)
  return(score)
}

Nscores <- 3
scores <-data.frame(matrix(NA,nrow=nrow(beta), ncol=Nscores))
rownames(scores) <- rownames(beta)

scores[1] <- calc_scores(model1)
scores[2] <- calc_scores(model2)
scores[3] <- calc_scores(model3)

# Standardize the scores
scaled.scores <- scale(scores)
scaled.scores <- as.data.frame(scaled.scores)
colnames(scaled.scores) <- c("10^-1", "10^-3", "10^-5")

# Save


# Heatmap and clustering based on log transformed read counts
# ============================================================

# Load heatmap.2
library(gplots)

# Parse arguments
args = commandArgs(trailingOnly=TRUE)
setwd(args[1])
in_filename = args[2]
delta = as.double(args[3])
out_filename = args[4]
W = as.integer(args[5])
H = as.integer(args[6])
S = as.integer(args[7])
r = as.integer(args[8])
svg_out = args[9]

# Read data
sgcounts_File = read.csv(file=in_filename,head=TRUE,sep="\t")
sgcounts = sgcounts_File[1:nrow(sgcounts_File),3:(ncol(sgcounts_File)-1)]

# Process data and plot
log_sgcounts = log(sgcounts+delta)
DataMatrix = as.matrix(log_sgcounts)
col_palette = colorRampPalette(c("yellow","orange","red"))(n = 40)
png(paste(out_filename,".png",sep=""), width = W, height = H, pointsize = S)
heatmap.2(DataMatrix,trace="none",col=col_palette,dendrogram="column",margins=c(r,r),labRow="")
dev.off()
if (svg_out == "True") {
  svg(paste(out_filename,".svg",sep=""))
  heatmap.2(DataMatrix,trace="none",col=col_palette,dendrogram="column",margins=c(r,r),labRow="")
  dev.off()
}


suppressMessages(library(pbdDMAT))
source("setup.r")
init.grid(quiet=TRUE)
comm.set.seed(SEED, diff=TRUE)

n = 250
m = as.integer((NUM_GPUS * GB_PER_GPU) * (BYTES_PER_VALUE / n))

GRID_TYPE = PROC_GRID_TALL
.pbd_env$ICTXT = GRID_TYPE
.pbd_env$BLDIM = c(BLOCKSIZE, BLOCKSIZE)
g = base.blacs(GRID_TYPE)

t_gen = mpitime(x <- ddmatrix("runif", m, n))
t_op = mpitime(crossprod(x))

p = sprintf("crossprod,%d,%d,%d,%d,%d,%d,%d,%f,%f\n", comm.size(), g$NPROW, g$NPCOL, m, n, BLOCKSIZE, BLOCKSIZE, t_gen, t_op)
comm.cat(p, quiet=TRUE)

finalize()


library(pROC)

# load gene expression data
fn.ge = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_GE_matrix_gene.txt")
dat = fread(fn.ge, data.table = F) %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("gene") %>%
  data.matrix()

fn.si = file.path(PROJECT_DIR, "generated_data", "CHI", "CHI_sample_info_2.txt")
info = fread(fn.si) %>%
  mutate(subject = as.character(subject))

fn.poB = file.path(PROJECT_DIR, "generated_data", "CHI", "flow_percent_of_B_filtered.txt")
flow.poB = fread(fn.poB) %>% tibble::column_to_rownames("sample") %>%
  data.matrix()

fn.info = file.path(PROJECT_DIR, "generated_data", "CHI", "flow_sample_info_filtered.txt")
flow.info = fread(fn.info) %>%
  mutate(subject = as.character(subject))

flow.df = flow.info %>% dplyr::select(sample) %>% add_column(CD38hi = flow.poB[,"Gate3"])

info = info %>% left_join(flow.df, by="sample")

fn.si.new = sub(".txt", "_CD38hi.txt", fn.si)
fwrite(info, fn.si.new, sep="\t", quote=T)

si = with(info, time == 0 & Response %in% c("low","high") & !is.na(CD38hi))
sum(si)
dat = dat[,si]
info = info[si,] %>% mutate(Response = factor(Response, levels=c("low","high")))

# select temporary stable genes --------------------------
fn.stab = "generated_data/CHI/CHI_genes_stability.txt"
ge.stab = fread(fn.stab, sep="\t")
gidx = ge.stab$ISV >= 0.75
sum(gidx)
stopifnot(identical(ge.stab$gene, rownames(dat)))
dat.ts = dat[gidx,]

# calculate robust regression removing ns samples --------
ns = 2
cmb = combn(1:nrow(info), ns)
# cc.rob = matrix(NA,nrow=nrow(edat.gene),ncol=ncol(cmb))
cc.rob = matrix(NA,nrow=sum(gidx),ncol=ncol(cmb))
for (ic in 1:ncol(cmb)) {
  cat(ic," ")
  ridx = cmb[,ic]
  cc.rob[,ic] = cor(t(dat[gidx,-ridx]), info$CD38hi[-ridx], method="spearman", use="pairwise.complete.obs")
}
rownames(cc.rob) = rownames(dat)[gidx]
cc.rob.rank = apply(-cc.rob,2,rank)
ntop = 20
cc.rob.ntop = rowSums(cc.rob.rank<=ntop)

cc.rob.mean = apply(cc.rob,1,mean)
cc.rob.median = apply(cc.rob,1,median)
cc.rob.sd = apply(cc.rob,1,sd)
cc.rob.1cv = cc.rob.mean / cc.rob.sd
cc.rob.ntop.rank = rank(cc.rob.ntop)

cc.rob.1cv.ord = order(cc.rob.1cv,decreasing = T)
cc.rob.1cv.sort = sort(cc.rob.1cv,decreasing = T)
head(cc.rob.1cv.sort, 10)

# calculate AUC for each gene
auc.one=matrix(nrow=nrow(dat.ts), ncol=3)
for (k in 1:nrow(dat.ts)) {
  X = dat.ts[k,]
  Y = info$Response
  auc.one[k, c(2,1,3)] = ci.auc(Y,X,direction="<", quiet=T)
}
rownames(auc.one) = rownames(dat.ts)
colnames(auc.one) = c("auc.gene", "auc.ci95.min", "auc.ci95.max")

# output
df.out = data.frame(cor.ntop20 = cc.rob.ntop / ncol(cmb) *100,
                    cor.mean = cc.rob.mean,
                    cor.sd = cc.rob.sd,
                    cor.median = cc.rob.median,
                    cor.mean.sd.ratio = cc.rob.1cv,
                    as.data.frame(auc.one)) %>%
  tibble::rownames_to_column("gene")

fn.cor = file.path(PROJECT_DIR, "generated_data","CHI","robust_corr_genes.txt")
fwrite(df.out, fn.cor, sep="\t", quote=T)

ng = 30
df.top = df.out %>%
  select(-cor.median) %>%
  arrange(desc(cor.mean.sd.ratio)) %>%
  top_n(ng, cor.mean.sd.ratio)

names(df.top) = c(
  "Gene",
  "% of iterations in top 20",
  "Mean of correlation coefficients",
  "SD of correlation coefficients",
  "Mean to SD ratio",
  "AUC for predicting titer response",
  "AUC, lower bound of 95% CI",
  "AUC, upper bound of 95% CI"
)

fn.cor = file.path(PROJECT_DIR, "generated_data","CHI",sprintf("robust_corr_genes_top%d.txt", ng))
fwrite(df.top, fn.cor, sep="\t", quote=T)


model_soilevaporation <- function (diffusionLimitedEvaporation = 6605.505,
         energyLimitedEvaporation = 448.24){
    #'- Name: SoilEvaporation -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: SoilEvaporation Model
    #'            * Author: Pierre Martre
    #'            * Reference: Modelling energy balance in the wheat crop model SiriusQuality2:
    #'            Evapotranspiration and canopy and soil temperature calculations
    #'            * Institution: INRA Montpellier
    #'            * ExtendedDescription: Starting from a soil at field capacity, soil evaporation  is assumed to
    #'                be energy limited during the first phase of evaporation and diffusion limited thereafter.
    #'                Hence, the soil evaporation model considers these two processes taking the minimum between
    #'                the energy limited evaporation (PtSoil) and the diffused limited
    #'                evaporation
    #'            * ShortDescription: Starting from a soil at field capacity, soil evaporation  is assumed to
    #'            be energy limited during the first phase of evaporation and diffusion limited thereafter.
    #'            Hence, the soil evaporation model considers these two processes taking the minimum between
    #'            the energy limited evaporation (PtSoil) and the diffused limited
    #'            evaporation
    #'- inputs:
    #'            * name: diffusionLimitedEvaporation
    #'                          ** description : diffusion Limited Evaporation
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 6605.505
    #'                          ** min : 0
    #'                          ** max : 10000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'            * name: energyLimitedEvaporation
    #'                          ** description : energy Limited Evaporation
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 448.240
    #'                          ** min : 0
    #'                          ** max : 1000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    #'                          ** inputtype : variable
    #'- outputs:
    #'            * name: soilEvaporation
    #'                          ** description : soil Evaporation
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0
    #'                          ** max : 5000
    #'                          ** unit : g m-2 d-1
    #'                          ** uri : http://www1.clermont.inra.fr/siriusquality/?page_id=547
    soilEvaporation <- min(diffusionLimitedEvaporation, energyLimitedEvaporation)
    return (list('soilEvaporation' = soilEvaporation))
}


#' PMV_ISO7730
#'
#' Calculate Predicted Mean Vote (PMV) following ISO 7730.
#'
#' @param t numeric    Air temperature in degC.
#' @param rh numeric   Relative humidity in percentage.
#' @param wind numeric Windspeed in meter per second.
#' @param tr numeric Mean radiant temperature in degC.
#' @param M numeric    Metabolic work in Watt per mq of the subject.
#' @param W   numeric  Mechanical work rate in Watt per mq of the subject.
#' @param clo numeric  Available basic clothing insulation in clo.
#' @return Predicted Mean Vote
#'
#'
#' @author  Istituto per la Bioeconomia Firenze CNR Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords PMV_ISO7730
#'
#' @export
#'
#'
#'
#'

PMV_ISO7730=function(t,rh,wind,tr,M,W,clo) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("wind", as.array(wind))
                         ct$assign("tr", as.array(tr))
                         ct$assign("M", as.array(M))
                         ct$assign("W", as.array(W))
                         ct$assign("clo", as.array(clo))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=PMV_ISO7730(t[i],rh[i],wind[i],tr[i],M[i],W[0],clo[0])};")
                         res=ct$get("res")
                         return(res)
}


library(testthat)

source("../src/utilities.r")

test_that("is.wholenumber",{
  expect_true(is.wholenumber(-1))
  expect_true(is.wholenumber(0))
  expect_true(is.wholenumber(1))
  expect_true(is.wholenumber(10000000000))

  expect_false(is.wholenumber(0.1))
  expect_false(is.wholenumber(-0.1))

  expect_error(is.wholenumber("w"))
  expect_error(is.wholenumber(c(0,1,2,3)))
  expect_error(is.wholenumber(TRUE))
})

test_that("are_elements_equal",{
  expect_true(are_elements_equal(1))
  expect_true(are_elements_equal(c(1,1)))
  expect_true(are_elements_equal(c(1.22,1.22)))
  expect_true(are_elements_equal(rep(1,times=1000)))

  expect_false(are_elements_equal(c(1,2)))
  expect_false(are_elements_equal(c(-1,1)))

})


# inc_plot_radial_columncharts.r

# go through all data in the selection

for (i in 1:length(mySelection)) {
myCountry<-myData[mySelection[i],3:length(myData)]+1
myCountry[is.na(myCountry)]<-1    # replacing missing values

# ... produce a list for every country

myCountryData<-NULL
for (j in 1:length(myCountry))
{
myCountryData<-c(myCountryData,list(0:as.numeric(myCountry[j])))
}
radial.pie(myDataMargin,label.prop=1.35,show.grid.labels=F,boxed.radial=F,show.radial.grid=F,grid.bg=par("bg"),grid.col=myGridColour,labels=myNames,sector.colors=myRColours,mar=myRadial_mar,radial.lim=c(0,11),xpd=T)

radial.pie(myCountryData,label.prop=1.35,show.grid.labels=F,boxed.radial=F,show.radial.grid=T,grid.bg=par("bg"),grid.col=myGridColour,labels=myNames,sector.colors=myRColours,mar=myRadial_mar,radial.lim=c(0,11),xpd=T,add=T)

radial.pie(myDataCenter,label.prop=1.35,show.grid.labels=F,boxed.radial=F,show.radial.grid=F,grid.bg=par("bg"),grid.col=myGridColour,labels=myNames,sector.colors=myMColours,mar=myRadial_mar,radial.lim=c(0,11),xpd=T,add=T)

myTitle<-myData[mySelection[i], "COUNTRY"]
mtext(myTitle,3,line=myMLine,adj=0.5,cex=2,col="white")
}


#####################################################################
#
# This script looks at a given list of genes (usually, the barcoded
# component of the 125 or 249 gene sets from Shah et al) and the
# number of genes that are across threshold.
#
#####################################################################

popnBelowThres <- function(geneList,theThres=10,thePops=c('dorsal','ventral',
			'intermediate','dg_d','dg_v','ca3_d','ca3_v','pv',
			'sst')){

	# Retrieve FPKM data.
	tempMat <- subFpkmMatrix(geneList)
	tempMat <- tempMat[,thePops]

	tempMax <- apply(tempMat,1,max)
	belowThres <- sum(tempMax < theThres)

	print(paste('For',length(tempMax),'genes, the total number below a threshold of',theThres,'is',belowThres))
}


print(lapply(1:100, isPrime))


  expand.weights = function (x, w){
    # expand a list of values and weights to allow brute force
    # calculation of means, frequency distributions, etc.
    weights = sort(unique(w))

    out = NULL
    for (i in weights) {
      a = x[ which(w == i) ]
      b = rep.int(a, i)
      out = c(out, b)
    }
    return(out)
  }


# RandomPlots.r
#               RBLandau 20171112

# f n P l o t R a n d o m M o n t h l y V s B a s e l i n e
fnPlotRandomMonthlyVsBaseline <- function(nCopies){

    trows.m <- fnSelectCopies(dat.auditrandom.monthly, nCopies)
    trows.t <- fnSelectCopies(dat.auditbaseline, nCopies)
    lossmax.m <- max(trows.m$mdmlosspct)
    lossmax.t <- max(trows.t$mdmlosspct)
    lossmax <- max(lossmax.m, lossmax.t) + 0.5

    #  M O N T H L Y  ( M )
    gp <- ggplot(data=trows.m, aes(trows.m, x=(lifem), y=safe(mdmlosspct)))
    gp <- gp +
            scale_x_log10("sector half-life (megahours) A") +
            scale_y_log10("% permanent document losses B") +
            ylim(0, lossmax) +
            annotation_logticks()
    gp <- gp +
            geom_point(data=trows.m,
                color="red", size=5, shape='M') +
            geom_line(data=trows.m,
                linetype="dashed", color="blue", size=1)

    # B A S E L I N E   T O T A L   A U D I T  ( number )
    gp <- gp +  aes(trows.t, x=(lifem), y=(safe(mdmlosspct)))
    gp <- gp +
            annotation_logticks()
    gp <- gp +
            geom_point(data=trows.t,
                color="red", size=5, shape=(48+nCopies)) +
            geom_line(data=trows.t,
                linetype="dashed", color="blue", size=1)

    # I D E N T I F Y I N G   G I N G E R B R E A D
    gp <- gp + ggtitle(sprintf("(copies = %s)",nCopies)
                        %+% " With RANDOM auditing sampling WITH replacement,"
                        %+% "\ninstead of TOTAL auditing of collection,"
                        %+% "\nsome docs are missed entirely, increasing losses")
    gp <- gp + xlab("sector half-life (megahours) E")
    gp <- gp + ylab("% permanent document losses F")
    gp <- gp + theme(
                axis.text=element_text(size=12),
                axis.title=element_text(size=18),
                plot.title=element_text(size=20,face="bold"),
                panel.border = element_rect(color = "black", fill=NA, size=1)
                )

    return(gp)
}

# f n P l o t R a n d o m V a r i o u s S e g m e n t s
fnPlotRandomVariousSegments <- function(nCopies){

    trows.m <- fnSelectCopies(dat.auditrandom.monthly, nCopies)
    trows.q <- fnSelectCopies(dat.auditrandom.quarterly, nCopies)
    trows.s <- fnSelectCopies(dat.auditrandom.semiannually, nCopies)
    lossmax.m <- max(trows.m$mdmlosspct)
    lossmax.q <- max(trows.q$mdmlosspct)
    lossmax.s <- max(trows.s$mdmlosspct)
    lossmax <- max(lossmax.m, lossmax.q, lossmax.s) + 0.5

    #  M O N T H L Y  ( M )
    gp <- ggplot(data=trows.m,aes(trows.m, x=(lifem), y=(safe(mdmlosspct))))
    gp <- gp +
            scale_x_log10("sector half-life (megahours) G") +
            scale_y_log10("% permanent document losses H") +
            ylim(0, lossmax) +
            annotation_logticks()
    gp <- gp +
            geom_point(data=trows.m,
                color="red", size=5, shape='M') +
            geom_line(data=trows.m,
                linetype="dashed", color="blue", size=1)

    # Q U A R T E R L Y  ( Q )
    gp <- gp +  aes(trows.q, x=(lifem), y=(safe(mdmlosspct)))
    gp <- gp +
            annotation_logticks()
    gp <- gp +
            geom_point(data=trows.q,
                color="red", size=5, shape='Q') +
            geom_line(data=trows.q,
                linetype="dashed", color="blue", size=1)

    # S E M I A N N U A L L Y  ( S )
    gp <- gp +  aes(trows.s, x=(lifem), y=(safe(mdmlosspct)))
    gp <- gp +
            annotation_logticks()
    gp <- gp +
            geom_point(data=trows.s,
                color="red", size=5, shape='S') +
            geom_line(data=trows.s,
                linetype="dashed", color="blue", size=1)

    # I D E N T I F Y I N G   G I N G E R B R E A D
    gp <- gp + ggtitle(sprintf("(copies = %s)",nCopies)
                        %+% " With RANDOM auditing"
                        %+% " sampling WITH replacement,"
                        %+% "\nmore frequent small segments are actually worse")
    gp <- gp + xlab("sector half-life (megahours) M")
    gp <- gp + ylab("% permanent document losses N")
    gp <- gp + theme(
                axis.text=element_text(size=12),
                axis.title=element_text(size=18),
                plot.title=element_text(size=20,face="bold"),
                panel.border = element_rect(color = "black", fill=NA, size=1)
                )

    return(gp)
}

#END


 GPS<-function(outfile_name='GPS_results.txt',N_best=10, fname="data.csv", directory_name="C://GPS//"){

 setwd(directory_name)    #set directory
 GEO=read.csv("geo.csv", header=TRUE,row.names=1)
 GEO=GEO[,1:2]
 GEN=(read.csv("gen.csv", header=TRUE,row.names=1))  #as.numeric
 TRAINING_DATA=read.csv(fname, header=TRUE, row.names=1)
 y=dist(GEO)
 x=dist(GEN)

 LL=length(y)
 for(l in 1:LL){
    if(y[l]>=70 || x[l] >=0.8) {y[l]=0; x[l]=0;}
 }

 eq1<-lm(y~x);

 GROUPS=unique(TRAINING_DATA$GROUP)

 write("Population\tSample_no\tSample_id\Prediction\tLat\tLon",outfile_name, append=FALSE)

 N_best<-min(N_best,length(GEO[,1]))

 for(GROUP in GROUPS){
 Y=subset( TRAINING_DATA, TRAINING_DATA$GROUP_ID==GROUP)
 K=length(Y[,1])
       for(a in 1:    K)
       {
       X<-Y[a,1:9]
       E<-rep(0, length(GEO[,1])  )  ;
       minE=10000; minG=-1; second_minG=-1;
       for(g  in 1: length(GEO[,1])){
            ethnic<-attributes(GEO[g,])$row.names;
            gene<-as.numeric(GEN[ethnic,1:9])
            E[g]<-   sqrt(sum((gene-X)^2))
            }
           minE=c();minE<-c(minE,sort(E,FALSE)[1:N_best])
           minG=c();
            for(g  in 1: length(GEO[,1])){
                  for(j in 1:N_best){
                 if( isTRUE(all.equal(minE[j], E[g]))){minG[j]=g;}

                  }
                  }

          minG;
          radius<-E[minG];
          best_ethnic<- attributes(GEO[minG,])$row.names; #best_ethnic;
          radius_geo=(eq1[[1]][2]*radius[1])
          W<- (minE[1]/minE)^4;
          W=W/(sum(W));
          delta_lat<-(GEO[minG,][[1]]-GEO[minG[1],][[1]])
          delta_lon<-(GEO[minG,][[2]]-GEO[minG[1],][[2]])
          new_lon<-sum(W*delta_lon)
          new_lat<-sum(W*delta_lat)
          lo1<-new_lon*min(1,radius_geo/sqrt(new_lon^2+new_lat^2) )
          la1<-new_lat*min(1,radius_geo/sqrt(new_lon^2+new_lat^2))
          write(paste(GROUP, a, row.names(Y[a,]), best_ethnic[1],GEO[minG[1],1]+la1,GEO[minG[1],2]+lo1, sep="\t"),outfile_name, append=TRUE)
}
   }
 return ("Done!");
}


# Reading the dataset
mpg <-read.csv("highway_mpg.csv", stringsAsFactors = FALSE)
View(mpg)
str(mpg)

install.packages("tidyr")
library(tidyr)
mpg2 <- mpg %>% gather(mpg, "Year   of Establishment", "year", -manufacturer)
View(mpg2)
mpg4<- unite_(mpg, "FuelEfficiency", c("drv","fl"))
View(mpg4)
mpg3<- mpg4 %>% separate(FuelEfficiency, c("drv", "f1"))
View(mpg3)
install.packages("dplyr")
library(dplyr)
mpgMutate <- mpg %>% mutate(nv=cyl+displ)
View(mpgMutate)

mpgGroupBy <- mpg %>%group_by(model)
View(mpgGroupBy)
mpgSummarize<- mpg %>% group_by(displ) %>% summarize(avg_displ=mean(displ))
mpgSummarize
View(mpgSummarize)
mpgArrange<- mpg %>%arrange(mpg$year)
View(mpgArrange)
glimpse(mpg)
mpgSubset <- select(mpg,   manufacturer, model)
View(mpgSubset)
mpgFilter <- mpg %>% filter(year>2000)
View(mpgFilter)
library(lubridate) # work with dates
library(dplyr) # data manipulation (filter, summarize, mutate)
library(ggplot2) # graphics
library(gridExtra) # tile several plots next to each other

library(scales)

# Create a group_by object using the year column
mpg.grp.year <- group_by(mpg, year) # column name to group by
class(mpg.grp.year)

# how many measurements were made each year?
tally(mpg.grp.year)
summarize(mpg.grp.year,
+           mean(displ)   # calculate the annual mean of displ
+ )

summarize(mpg.grp.year,
+           mean(displ, na.rm = TRUE)
+ )

mpg %>%
+ group_by(year) %>% # group by year
+ tally() # count measurements per year

year.sum <- mpg %>%
+ group_by(year) %>% # group by year
+ summarize(mean(displ, na.rm=TRUE))
> year.sum

str(year.sum)

qplot(mpg.grp.year$displ, mpg.grp.year$year,xlab = "Displacement", ylab = "year",main = "Manipulating Grouped Data")


blocks <- rbind(c("B","O"),
 c("X","K"),
 c("D","Q"),
 c("C","P"),
 c("N","A"),
 c("G","T"),
 c("R","E"),
 c("T","G"),
 c("Q","D"),
 c("F","S"),
 c("J","W"),
 c("H","U"),
 c("V","I"),
 c("A","N"),
 c("O","B"),
 c("E","R"),
 c("F","S"),
 c("L","Y"),
 c("P","C"),
 c("Z","M"))

canMake <- function(x) {
  x <- toupper(x)
  used <- rep(FALSE, dim(blocks)[1L])
  charList <- strsplit(x, character(0))
  tryChars <- function(chars, pos, used, inUse=NA) {
    if (pos > length(chars)) {
      TRUE
    } else {
      used[inUse] <- TRUE
      possible <- which(blocks == chars[pos] & !used, arr.ind=TRUE)[, 1L]
      any(vapply(possible, function(possBlock) tryChars(chars, pos + 1, used, possBlock), logical(1)))
    }
  }
  setNames(vapply(charList, tryChars, logical(1), 1L, used), x)
}
canMake(c("A",
           "BARK",
           "BOOK",
           "TREAT",
           "COMMON",
           "SQUAD",
           "CONFUSE"))


###########################################################
## Handy function to sort one data frame's rows by order ##
## of another, dimensionally-matching data frame         ##
##                                                       ##
## Author: Eric Magar emagar at itam dot mx              ##
## Created: 16mar2021                                    ##
## Revised: 16mar2021                                    ##
###########################################################

sortBy <- function(target, By){
    t <- target; b <- By;
    do.call(rbind, lapply(seq_len(nrow(b)),
            function(i) as.character(unlist(t[i,])[order(unlist(-b[i,]))]))) # change to -b for decreasing order
}

#############
## example ##
#############
## v1 <- data.frame(c1=c(30,15,3), c2=c(10,25,2), c3=c(20,35,4))
## l1 <- data.frame(c1=c("thirty","fifteen","three"), c2=c("ten","twenty-five","two"), c3=c("twenty","thirty-five","four"))
## v1.sorted <- t(apply(v1, 1, function(x) sort(x, decreasing = TRUE))) # sort each row of df -- http://stackoverflow.com/questions/6063881/sorting-rows-alphabetically
## l1.sorted <- sortBy(target = l1, By = v1)
## sortBy(target = v1, By = v1)

#############
## comment ##
#############
## this sorts matrix rows faster than function above
## vot <- t(apply(v1, 1, function(x) sort(x, decreasing = TRUE)))


context("Stats")

test_that("plot succeeds even if some computation fails", {
  p1 <- ggplot(mtcars, aes(disp, mpg)) +
    geom_point() +
    facet_grid(gear ~ carb)
  p2 <- p1 + geom_smooth()

  b1 <- ggplot_build(p1)
  expect_equal(length(b1$data), 1)

  expect_warning(b2 <- ggplot_build(p2))
  expect_equal(length(b2$data), 2)

})

# helper function for stat calc tests.
test_stat <- function(stat) {
  stat$data <- transform(stat$data, PANEL = 1)
  dat <- stat$compute_aesthetics(stat$data, ggplot())
  dat <- add_group(dat)
  stat$calc_statistic(dat, NULL)
}

context("stat-bin")

test_that("stat_sum", {
  dat <- data.frame(x = c("a", "b", "c"), y = c(1, 5, 10))

  # Should get an error when mapping/setting y and also using stat_bin
  # But errors caught by internal tryCatch :()
#   expect_error(ggplot_build(ggplot(dat, aes(x=x, y=y)) + geom_bar()),
#     "Mapping a variable to y and also using stat=\"bin\"")
#   expect_error(p <- ggplot_build(ggplot(dat, aes(x=x, y=y)) + geom_bar(stat="bin")),
#     "Mapping a variable to y and also using stat=\"bin\"")
#
#   expect_error(p <- ggplot_build(ggplot(dat, aes(x=x)) + geom_bar(y=5)),
#     "Mapping a variable to y and also using stat=\"bin\"")

  # This gives an error  (it would probably be OK if just one
  # of these happened, but this test looks for both)
  dat2 <- data.frame(x = c("a", "b", "c", "a", "b", "c"), y = c(1, 5, 10, 2, 3, 4))
#  expect_error(
#     p <- ggplot_build(ggplot(dat2, aes(x=x, y=y)) + geom_bar()))
})

context("stat-sum")

test_that("stat_sum", {
  d <- diamonds[1:1000, ]
  all_ones <- function(x) all.equal(mean(x), 1)

  ret <- test_stat(stat_sum(aes(x = cut, y = clarity), data =  d))
  expect_equal(dim(ret), c(38, 5))
  expect_equal(sum(ret$n), nrow(d))
  expect_true(all_ones(ret$prop))

  ret <- test_stat(stat_sum(aes(x = cut, y = clarity, group = 1), data =  d))
  expect_equal(dim(ret), c(38, 5))
  expect_equal(sum(ret$n), nrow(d))
  expect_equal(sum(ret$prop), 1)

  ret <- test_stat(stat_sum(aes(x = cut, y = clarity, group = cut), data =  d))
  expect_equal(dim(ret), c(38, 5))
  expect_equal(sum(ret$n), nrow(d))
  expect_true(all_ones(tapply(ret$prop, ret$x, FUN = sum)))

  ret <- test_stat(stat_sum(aes(x = cut, y = clarity, group = cut, colour = cut), data =  d))
  expect_equal(dim(ret), c(38, 6))
  expect_equal(ret$x, ret$colour)
  expect_equal(sum(ret$n), nrow(d))
  expect_true(all_ones(tapply(ret$prop, ret$x, FUN = sum)))

  ret <- test_stat(stat_sum(aes(x = cut, y = clarity, group = clarity), data =  d))
  expect_equal(dim(ret), c(38, 5))
  expect_equal(sum(ret$n), nrow(d))
  expect_true(all_ones(tapply(ret$prop, ret$y, FUN = sum)))

  ret <- test_stat(stat_sum(aes(x = cut, y = clarity, group = clarity, colour = cut), data =  d))
  expect_equal(dim(ret), c(38, 6))
  expect_equal(ret$x, ret$colour)
  expect_equal(sum(ret$n), nrow(d))
  expect_true(all_ones(tapply(ret$prop, ret$y, FUN = sum)))

  ret <- test_stat(stat_sum(aes(x = cut, y = clarity, group = 1, weight = price), data =  d))
  expect_equal(dim(ret), c(38, 5))
  expect_equal(sum(ret$n), sum(d$price))
  expect_equal(sum(ret$prop), 1)
})

# helper function for stat calc tests.
test_stat_scale <- function(stat, scale) {
  stat$data <- transform(stat$data, PANEL = 1)
  dat <- stat$compute_aesthetics(stat$data, ggplot())
  dat <- add_group(dat)
  stat$calc_statistic(dat, scale)
}

context("stat-bin2d")

test_that("stat-bin2d", {
  d <- diamonds[1:1000,]

  full_scales <- list(x = scale_x_continuous(limits = range(d$carat, na.rm=TRUE)),
                      y = scale_y_continuous(limits = range(d$depth, na.rm=TRUE)))
  ret <- test_stat_scale(stat_bin2d(aes(x = carat, y = depth), data=d), full_scales)
  expect_equal(dim(ret), c(191,12))

  d$carat[1] <- NA
  d$depth[2] <- NA

  full_scales <- list(x = scale_x_continuous(limits = range(d$carat, na.rm=TRUE)),
                      y = scale_y_continuous(limits = range(d$depth, na.rm=TRUE)))
  ret <- test_stat_scale(stat_bin2d(aes(x = carat, y = depth), data=d), full_scales)
  expect_equal(dim(ret), c(191,12))
})

context("stat-density2d")

test_that("stat-density2d", {

  full_scales <- list(x = scale_x_continuous(limits=c(1,6)),
                      y = scale_y_continuous(limits=c(5,40)))
  ret <- test_stat_scale(stat_density2d(aes(x = wt, y = mpg), data = mtcars), full_scales)
  # Check that the contour data goes beyond data range.
  # The specific values below are sort of arbitrary; but they go beyond the range
  # of the data
  expect_true(min(ret$x) < 1.2)
  expect_true(max(ret$x) > 5.8)
  expect_true(min(ret$y) < 8)
  expect_true(max(ret$y) > 35)

})


library(DeliveryMan)

create_node <- function(posX, posY, cost = .Machine$integer.max) {
  return(list(x = posX, y = posY, cost = cost))
}

distance <- function (x1, y1, x2, y2){
  return(abs(x1 - x2) + abs(y1 - y2))
}

myFunction <- function(roads, car, packages) {
  # roads-> list of two matrixes for traffic conditions hroads and vroads (coordintes bottom left to top right )
  # coordinates stat <1,1> and go to <dim,dim>
  # list of information about your car -> load -> mem -> nextMove
  # matrix about packages
  car$nextMove = 5

  destX = 1
  destY = 1
  if(car$load == 0) {
    # closest package
    distances = distance(car$x, car$y, packages[,1], packages[,2])
    # set packages we already collected to infinite distance
    distances[packages[, 5] != 0] = .Machine$integer.max
    minDistanceIndex = which.min(distances)
    destX = packages[minDistanceIndex, 1]
    destY = packages[minDistanceIndex, 2]

  } else {
    destX = packages[car$load, 3]
    destY = packages[car$load, 4]
  }
  path = find_path(car$x, car$y, destX, destY, roads)
  nextPoint = path[[1]]
  car$nextMove = next_move(car$x, car$y, nextPoint$x, nextPoint$y)
  return(car)
}

get_neighbour <- function(posX, posY, cameFromX, cameFromY, goalX, goalY, costToNode) {
  totalCost = costToNode + distance(posX, posY, goalX, goalY)
  toVisit = TRUE
  return(create_node_info_element(posX, posY, cameFromX, cameFromY, costToNode, totalCost, toVisit =TRUE))
}

get_neighbours <- function (posX, posY, goalX, goalY, costToParentNode, roads) {
  maxY = length(roads$hroads[1,])
  maxX = length(roads$vroads[,1])

  n1 = NULL
  n2 = NULL
  n3 = NULL
  n4 = NULL

  if (posX > 1) {
    cost = roads$hroads[posX-1, posY] + costToParentNode
    n1 = create_node(posX-1,posY, cost)
  }
  if (posX < maxX) {
    cost = roads$hroads[posX, posY] + costToParentNode
    n2 = create_node(posX + 1, posY, cost)
  }
  if (posY > 1) {
    cost = roads$vroads[posX, posY - 1] + costToParentNode
    n3 = create_node(posX,posY - 1, cost)
  }
  if (posY < maxY) {
    cost = roads$vroads[posX, posY] + costToParentNode
    n4 = create_node(posX,posY + 1, cost)
  }
  return(list(n1, n2, n3, n4))
}

find_path <- function (startX, startY, goalX, goalY, roads) {
  pq_cost = c()
  pq_list = list()

  maxX = length(roads$vroads[,1])
  maxY = length(roads$hroads[1,])
  cameFromX <<- matrix(0, nrow = maxX, ncol = maxY)
  cameFromY <<- matrix(0, nrow = maxX, ncol = maxY)
  costToNode <<- matrix(.Machine$double.xmax, nrow = maxX, ncol = maxY)
  visited <<- matrix(FALSE, nrow = maxX, ncol = maxY)

  maxY = length(roads$hroads[1,])
  maxX = length(roads$vroads[,1])

  cost = 0
  node = create_node(startX, startY, 0)
  # priority queue insert
  insert.order <- findInterval(cost, pq_cost)
  pq_cost <- append(pq_cost, cost, insert.order)
  pq_list <- append(pq_list, list(node), insert.order)

  costToNode[startX, startY] = 0
  cameFromX[startX, startY] = startX
  cameFromY[startX, startY] = startY

  current = NULL
  while (length(pq_cost) != 0) {
    # pop queue
    current <- pq_list[[1]]
    pq_cost <- pq_cost[-1]
    pq_list <- pq_list[-1]

    if (current$x == goalX & current$y == goalY) {
      path_list = NULL
      # walk backwards until starting element is reached
      while (current$x != startX | current$y != startY) {
        # get next element
        path_list = append(list(current), path_list)
        current = create_node(cameFromX[current$x, current$y], cameFromY[current$x, current$y], costToNode[current$x, current$y])
      }
      return(path_list)
    }

    neighbours = get_neighbours(current$x, current$y, goalX, goalY, costToNode[current$x, current$y], roads)

    for(n in neighbours) {
      if(is.null(n) == FALSE) {
        if(n$cost < costToNode[n$x, n$y]) {
          cameFromX[n$x,n$y] = current$x
          cameFromY[n$x,n$y] = current$y

          costToNode[n$x, n$y] = n$cost

          totalCost = n$cost + distance(n$x, n$y, goalX, goalY)

          # priority queue insert
          insert.order <- findInterval(totalCost, pq_cost)
          pq_cost <- append(pq_cost, totalCost, insert.order)
          pq_list <- append(pq_list, list(n), insert.order)
        }
      }
    }

  }
  #Failed to find path
  return(NULL)
}

next_move <- function(carX, carY, dirX, dirY) {
  if(!is.numeric(dirX) || !is.numeric(dirY)) {
    return(0)
  }
  xDir = carX - dirX
  yDir = carY - dirY

  if (xDir + yDir < 0) {
    if (xDir == 0) {
      # up
      return(8)
    } else {
      # right
      return(6)
    }
  } else if (xDir + yDir > 0){
    if (xDir == 0) {
      # down
      return(2)
    } else {
      # left
      return(4)
    }
  }
  return(0)
}

startTime = Sys.time()
print(testDM(myFunction, timeLimit = 250))
endTime = Sys.time()
print(endTime - startTime)