# https://stat.ethz.ch/pipermail/r-devel/2003-March/026043.html
# http://www.adamgberger.com/3ps/R/src/library/stats/R/ftable.R
#  File src/library/stats/R/ftable.R
#  Part of the R package,http://www.R-project.org
#
#  This program is free software; you can redistribute it and/or modify
#  it under the terms of the GNU General Public License as published by
#  the Free Software Foundation; either version 2 of the License,or
#  (at your option) any later version.
#
#  This program is distributed in the hope that it will be useful,
#  but WITHOUT ANY WARRANTY; without even the implied warranty of
#  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
#  GNU General Public License for more details.
#
#  A copy of the GNU General Public License is available at
#  http://www.r-project.org/Licenses/

ftable<-function(x,...) UseMethod("ftable")

ftable.default<-function(...,exclude=c(NA,NaN),
                           row.vars=NULL,col.vars=NULL,pcnt=c("n","row","column","total","gtotal")) {
    args<-list(...)
    if (length(args) == 0L)
        stop("nothing to tabulate")
    x<-args[[1L]]
    if(is.list(x))
        x<-table(x,exclude=exclude)
    else if(inherits(x,"ftable")) {
        x<-as.table(x)
    }
    else if(!(is.array(x) && (length(dim(x)) > 1L))) {
        x<-table(...,exclude=exclude)
    }
    dn<-dimnames(x)
    dx<-dim(x)
    n<-length(dx)
    if(!is.null(row.vars)) {
        if(is.character(row.vars)) {
            i<-pmatch(row.vars,names(dn))
            if(any(is.na(i)))
                stop("incorrect specification for 'row.vars'")
            row.vars<-i
        } else if(any((row.vars < 1) | (row.vars > n)))
            stop("incorrect specification for 'row.vars'")
    }
    if(!is.null(col.vars)) {
        if(is.character(col.vars)) {
            i<-pmatch(col.vars,names(dn))
            if(any(is.na(i)))
             stop("incorrect specification for 'col.vars'")
            col.vars<-i
        } else if(any((col.vars < 1) | (col.vars > n)))
            stop("incorrect specification for 'col.vars'")
    }
    i<-1 : n
    if(!is.null(row.vars) && !is.null(col.vars)) {
        all.vars<-sort(c(row.vars,col.vars))
        if (length(all.vars) < n) {
            x<-apply(x,all.vars,sum)
            row.vars<-match(row.vars,all.vars)
            col.vars<-match(col.vars,all.vars)
            dn<-dn[all.vars]
            dx<-dx[all.vars]
        }
    }
    else if(!is.null(row.vars))
        col.vars<-i[-row.vars]
    else if(!is.null(col.vars))
        row.vars<-i[-col.vars]
    else {
        row.vars<-1 : (n-1)
        col.vars<-n
    }

pcnt<-match.arg(pcnt)
if (pcnt!="n") {
    if (pcnt=="row")    {mrg2drop<-col.vars[length(col.vars)]}
    if (pcnt=="column") {mrg2drop<-row.vars[length(row.vars)]}
    if (pcnt=="total")
{mrg2drop<-c(col.vars[length(col.vars)],row.vars[length(row.vars)])}
    if (pcnt=="gtotal") {mrg2drop<-0}
    x<-prop.table(x,i[-mrg2drop])*100
}

    y<-aperm(x,c(rev(row.vars),rev(col.vars)))
    dim(y)<-c(prod(dx[row.vars]),prod(dx[col.vars]))
    attr(y,"row.vars")<-dn[row.vars]
    attr(y,"col.vars")<-dn[col.vars]
    class(y)<-"ftable"
    y
}

ftable.formula<-function(formula,data=NULL,subset,na.action,...)
{
    if(missing(formula) || !inherits(formula,"formula"))
        stop("'formula' missing or incorrect")
    if(length(formula) != 3L)
        stop("'formula' must have both left and right hand sides")
    ## need to cope with '.' in formula
    tt<-if(is.data.frame(data)) terms(formula,data=data)
    else terms(formula,allowDotAsName=T)
    if(any(attr(tt,"order") > 1))
        stop("interactions are not allowed")
    ## here we do NOT want '.' expanded
    rvars<-attr(terms(formula[-2L],allowDotAsName=T),"term.labels")
    cvars<-attr(terms(formula[-3L],allowDotAsName=T),"term.labels")
    rhs.has.dot<-any(rvars == ".")
    lhs.has.dot<-any(cvars == ".")
    if(lhs.has.dot && rhs.has.dot)
        stop("'formula' has '.' in both left and right hand side")
    m<-match.call(expand.dots =F)
    edata<-eval(m$data,parent.frame())
    if(inherits(edata,"ftable")
       || inherits(edata,"table")
       || length(dim(edata)) > 2L) {
        if(inherits(edata,"ftable")) {
            data<-as.table(data)
        }
        varnames<-names(dimnames(data))
        if(rhs.has.dot)
            rvars<-NULL
        else {
            i<-pmatch(rvars,varnames)
            if(any(is.na(i)))
                stop("incorrect variable names in rhs of formula")
            rvars<-i
        }
        if(lhs.has.dot)
            cvars<-NULL
        else {
            i<-pmatch(cvars,varnames)
            if(any(is.na(i)))
                stop("incorrect variable names in lhs of formula")
            cvars<-i
        }
        #ftable(data,row.vars=rvars,col.vars=cvars)
        ftable(data,row.vars=rvars,col.vars=cvars,...)
    }
    else {
        if(is.matrix(edata))
            m$data<-as.data.frame(data)
        m$...<-NULL
        if(!is.null(data) && is.environment(data)) {
            varnames<-names(data)
            if(rhs.has.dot)
                rvars<-seq_along(varnames)[-cvars]
            if(lhs.has.dot)
                cvars<-seq_along(varnames)[-rvars]
        }
        else {
            if(lhs.has.dot || rhs.has.dot)
                stop("cannot use dots in formula with given data")
        }
        m$formula<-as.formula(paste("~",
                                   paste(c(rvars,cvars),
                                         collapse="+")),
                                env=environment(formula))
        m[[1L]]<-as.name("model.frame")
        mf<-eval(m,parent.frame())
        ftable(mf,row.vars=rvars,col.vars=cvars,...)
    }
}

as.table.ftable<-function(x,...)
{
    if(!inherits(x,"ftable"))
        stop("'x' must be an \"ftable\" object")
    xrv<-rev(attr(x,"row.vars"))
    xcv<-rev(attr(x,"col.vars"))
    x<-array(data=c(x),
               dim=c(sapply(xrv,length),
                       sapply(xcv,length)),
               dimnames=c(xrv,xcv))
    nrv<-length(xrv)
    ncv<-length(xcv)
    x<-aperm(x,c(rev(seq_len(nrv)),rev(seq_len(ncv) + nrv)))
    class(x)<-"table"
    x
}

format.ftable<-function(x,quote =T,digits=getOption("digits"),...)
{
    if(!inherits(x,"ftable"))
        stop("'x' must be an \"ftable\" object")
    charQuote<-function(s)
        if(quote) paste("\"",s,"\"",sep="") else s
    makeLabels<-function(lst) {
        lens<-sapply(lst,length)
        cplensU<-c(1,cumprod(lens))
        cplensD<-rev(c(1,cumprod(rev(lens))))
        y<-NULL
        for (i in rev(seq_along(lst))) {
            ind<-1 + seq.int(from=0,to=lens[i] - 1) * cplensD[i + 1]
            tmp<-character(length=cplensD[i])
            tmp[ind]<-charQuote(lst[[i]])
            y<-cbind(rep(tmp,times=cplensU[i]),y)
        }
        y
    }
    makeNames<-function(x) {
        nmx<-names(x)
        if(is.null(nmx))
            nmx<-rep("",length.out=length(x))
        nmx
    }

    xrv<-attr(x,"row.vars")
    xcv<-attr(x,"col.vars")
    LABS<-cbind(rbind(matrix("",nrow=length(xcv),ncol=length(xrv)),
                        charQuote(makeNames(xrv)),
                        makeLabels(xrv)),
                  c(charQuote(makeNames(xcv)),
                    rep("",times=nrow(x) + 1)))
    DATA<-rbind(if(length(xcv)) t(makeLabels(xcv)),
                  rep("",times=ncol(x)),
                  format(unclass(x),digits=digits))
    cbind(apply(LABS,2L,format,justify="left"),
	  apply(DATA,2L,format,justify="right"))
}

write.ftable<-function(x,file="",quote =T,append =F,
			 digits=getOption("digits"))
{
    r<-format.ftable(x,quote=quote,digits=digits)
    cat(t(r),file=file,append=append,
	sep=c(rep(" ",ncol(r) - 1),"\n"))
    invisible(x)
}

print.ftable<-function(x,digits=getOption("digits"),...)
    write.ftable(x,quote =F,digits=digits)

read.ftable<-function(file,sep="",quote="\"",row.var.names,
                        col.vars,skip=0)
{
    if(is.character(file)) {
        file<-file(file,"r")
        on.exit(close(file))
    }
    if(!inherits(file,"connection"))
        stop("'file' must be a character string or connection")
    if(!isSeekable(file)) {
        ## We really need something seekable,see below.  If it is not,
        ## the best we can do is write everything to a tempfile.
        tmpf<-tempfile()
        cat(readLines(file),file=tmpf,sep="\n")
        file<-file(tmpf,"r")
        on.exit({close(file);unlink(tmpf)},add=T)
    }

    z<-utils::count.fields(file,sep,quote,skip)
    n.row.vars<-z[max(which(z == max(z)))] - z[length(z)] + 1

    seek(file,where=0)
    if(skip > 0) readLines(file,skip)
    lines<-readLines(file)
    seek(file,where=0)
    if(skip > 0) readLines(file,skip)

    i<-which(z == n.row.vars)
    ## For an ftable,we have
    ##                     cv.1.nm cv.1.l1 .........
    ##                     cv.2.nm cv.2.l1 .........
    ## rv.1.nm ... rv.k.nm
    ## rv.1.l1 ... rv.k.l1         ...     ...
    ##
    ## so there is exactly one line which does not start with a space
    ## and has n.row.vars fields (and it cannot be the first one).
    j<-i[grep("^[^[:space:]]",lines[i])]
    if((length(j) == 1L) && (j > 1)) {
        ## An ftable: we can figure things out ourselves.
        n.col.vars<-j - 1
        col.vars<-vector("list",length=n.col.vars)
        n<-c(1,z[1 : n.col.vars] - 1)
        for(k in seq.int(from=1,to=n.col.vars)) {
            s<-scan(file,what="",sep=sep,quote=quote,
                      nlines=1,quiet =T)
            col.vars[[k]]<-s[-1L]
            names(col.vars)[k]<-s[1L]
        }
        row.vars<-vector("list",length=n.row.vars)
        names(row.vars)<-scan(file,what="",sep=sep,quote =
                                quote,nlines=1,quiet =T)
        z<-z[-(1 : (n.col.vars + 1))]
    }
    else {
        ## This is not really an ftable.
        if((z[1L] == 1) && z[2L] == max(z)) {
            ## Case A.  File looks like
            ##
            ##                                cvar.nam
            ## rvar.1.nam   ... rvar.k.nam    cvar.lev.1 ... cvar.lev.l
            ## rvar.1.lev.1 ... rvar.k.lev.1  ...        ... ...
            ##
            n.col.vars<-1
            col.vars<-vector("list",length=n.col.vars)
            s<-scan(file,what="",sep=sep,quote=quote,
                      nlines=2,quiet =T)
            names(col.vars)<-s[1L]
            s<-s[-1L]
            row.vars<-vector("list",length=n.row.vars)
            i<-1 : n.row.vars
            names(row.vars)<-s[i]
            col.vars[[1L]]<-s[-i]
            z<-z[-(1 : 2)]
        }
        else {
            ## Case B.
            ## We cannot determine the names and levels of the column
            ## variables,and also not the names of the row variables.
            if(missing(row.var.names)) {
                ## 'row.var.names' should be a character vector (or
                ## factor) with the names of the row variables.
                stop("'row.var.names' missing")
            }
            n.row.vars<-length(row.var.names)
            row.vars<-vector("list",length=n.row.vars)
            names(row.vars)<-as.character(row.var.names)
            if(missing(col.vars) || !is.list(col.vars)) {
                ## 'col.vars' should be a list.
                stop("'col.vars' missing or incorrect")
            }
            col.vars<-lapply(col.vars,as.character)
            n.col.vars<-length(col.vars)
            if(is.null(names(col.vars)))
                names(col.vars)<-
                    paste("Factor",seq_along(col.vars),sep=".")
            else {
                nam<-names(col.vars)
                ind<-which(!nzchar(nam))
                names(col.vars)[ind]<-
                    paste("Factor",ind,sep=".")
            }
        }
    }

    p<-1
    n<-integer(n.row.vars)
    for(k in seq.int(from=1,to=n.row.vars)) {
        n[k]<-sum(z >= max(z) - k + 1) / p
        p<-p * n[k]
    }
    is.row.lab<-rep(rep(c(TRUE,FALSE),length(z)),
                      c(rbind(z - min(z) + 1,min(z) - 1)))
    s<-scan(file,what="",sep=sep,quote=quote,quiet =T)
    values<-as.numeric(s[!is.row.lab])
    tmp<-s[is.row.lab]
    len<-length(tmp)
    for(k in seq.int(from=1,to=n.row.vars)) {
        i<-seq.int(from=1,to=len,by=len / n[k])
        row.vars[[k]]<-unique(tmp[i])
        tmp<-tmp[seq.int(from=2,to=len / n[k])]
        len<-length(tmp)
    }
    values<-matrix(values,
                     nrow=prod(sapply(row.vars,length)),
                     ncol=prod(sapply(col.vars,length)),
                     byrow =T)
    structure(values,
              row.vars=row.vars,
              col.vars=col.vars,
              class="ftable")
}

as.data.frame.ftable<-
function(x,row.names=NULL,optional =F,...)
    as.data.frame(as.table(x),row.names,optional)


# This is a minimal version of the "sandwich" package suitable for use in this course
# It is based on the "sandwich" package: https://cran.r-project.org/web/packages/sandwich/index.html
# Modified 06-03-2021 and this file is licensed under the GPL-2 / GPL-3 license

sandwich <- function(x, bread. = bread, meat. = meat, ...)
{
  if(is.list(x) && !is.null(x$na.action)) class(x$na.action) <- "omit"
  if(is.function(bread.)) bread. <- bread.(x)
  if(is.function(meat.)) meat. <- meat.(x, ...)
  n <- NROW(estfun(x))
  return(1/n * (bread. %*% meat. %*% bread.))
}

meat <- function(x, adjust = FALSE, ...)
{
  if(is.list(x) && !is.null(x$na.action)) class(x$na.action) <- "omit"
  psi <- estfun(x, ...)
  k <- NCOL(psi)
  n <- NROW(psi)
  rval <- crossprod(as.matrix(psi))/n
  if(adjust) rval <- n/(n-k) * rval
  rownames(rval) <- colnames(rval) <- colnames(psi)
  return(rval)
}

vcovOPG <- function(x, adjust = FALSE, ...)
{
  if(is.list(x) && !is.null(x$na.action)) class(x$na.action) <- "omit"
  psi <- estfun(x, ...)
  k <- NCOL(psi)
  n <- NROW(psi)
  rval <- chol2inv(qr.R(qr(psi)))
  if(adjust) rval <- n/(n-k) * rval
  rownames(rval) <- colnames(rval) <- colnames(psi)
  return(rval)
}

vcovHC <- function(x, ...) {
  UseMethod("vcovHC")
}

vcovHC.default <- function(x,
  type = c("HC3", "const", "HC", "HC0", "HC1", "HC2", "HC4", "HC4m", "HC5"),
  omega = NULL, sandwich = TRUE, ...)
{
  type <- match.arg(type)
  rval <- meatHC(x, type = type, omega = omega)
  if(sandwich) rval <- sandwich(x, meat. = rval, ...)
  return(rval)
}

meatHC <- function(x,
  type = c("HC3", "const", "HC", "HC0", "HC1", "HC2", "HC4", "HC4m", "HC5"),
  omega = NULL, ...)
{
  ## ensure that NAs are omitted
  if(is.list(x) && !is.null(x$na.action)) class(x$na.action) <- "omit"

  ## extract X
  X <- model.matrix(x)
  if(any(alias <- is.na(coef(x)))) X <- X[, !alias, drop = FALSE]
  attr(X, "assign") <- NULL
  n <- NROW(X)

  ## get hat values and residual degrees of freedom
  diaghat <- try(hatvalues(x), silent = TRUE)
  df <- n - NCOL(X)

  ## the following might work, but "intercept" is also claimed for "coxph"
  ## res <- if(attr(terms(x), "intercept") > 0) estfun(x)[,1] else rowMeans(estfun(x)/X, na.rm = TRUE)
  ## hence better rely on
  ef <- estfun(x, ...)
  res <- rowMeans(ef/X, na.rm = TRUE)

  ## handle rows with just zeros
  all0 <- apply(abs(ef) < .Machine$double.eps, 1L, all)
  res[all0] <- 0
  ## in case of lm/glm and type = "const" re-obtain the working residuals
  if(any(all0) && substr(type, 1L, 1L) == "c") {
    if(inherits(x, "glm")) {
      res <- as.vector(residuals(x, "working")) * weights(x, "working")
      if(!(substr(x$family$family, 1L, 17L) %in% c("poisson", "binomial", "Negative Binomial"))) {
        res <- res * sum(weights(x, "working"), na.rm = TRUE) / sum(res^2, na.rm = TRUE)
      }
    } else if(inherits(x, "lm")) {
      res <- as.vector(residuals(x))
      if(!is.null(weights(x))) res <- res * weights(x)
    }
  }

  ## if omega not specified, set up using type
  if(is.null(omega)) {
    type <- match.arg(type)
    if(type == "HC") type <- "HC0"
    switch(type,
      "const" = { omega <- function(residuals, diaghat, df) rep(1, length(residuals)) * sum(residuals^2)/df },
      "HC0"   = { omega <- function(residuals, diaghat, df) residuals^2 },
      "HC1"   = { omega <- function(residuals, diaghat, df) residuals^2 * length(residuals)/df },
      "HC2"   = { omega <- function(residuals, diaghat, df) residuals^2 / (1 - diaghat) },
      "HC3"   = { omega <- function(residuals, diaghat, df) residuals^2 / (1 - diaghat)^2 },
      "HC4"   = { omega <- function(residuals, diaghat, df) {
        n <- length(residuals)
	p <- as.integer(round(sum(diaghat),  digits = 0))
	delta <- pmin(4, n * diaghat/p)
        residuals^2 / (1 - diaghat)^delta
      }},
      "HC4m"  = { omega <- function(residuals, diaghat, df) {
        gamma <- c(1.0, 1.5) ## as recommended by Cribari-Neto & Da Silva
        n <- length(residuals)
	p <- as.integer(round(sum(diaghat),  digits = 0))
	delta <- pmin(gamma[1], n * diaghat/p) + pmin(gamma[2], n * diaghat/p)
        residuals^2 / (1 - diaghat)^delta
      }},
      "HC5"   = { omega <- function(residuals, diaghat, df) {
        k <- 0.7 ## as recommended by Cribari-Neto et al.
        n <- length(residuals)
	p <- as.integer(round(sum(diaghat),  digits = 0))
	delta <- pmin(n * diaghat/p, pmax(4, n * k * max(diaghat)/p))
        residuals^2 / sqrt((1 - diaghat)^delta)
      }}
    )
  }

  ## process omega
  if(is.function(omega)) omega <- omega(res, diaghat, df)
  rval <- sqrt(omega) * X
  rval <- crossprod(rval)/n

  return(rval)
}

vcovHC.mlm <- function(x,
  type = c("HC3", "const", "HC", "HC0", "HC1", "HC2", "HC4", "HC4m", "HC5"),
  omega = NULL, sandwich = TRUE, ...)
{
  ## compute meat "by hand" because meatHC() can not deal with
  ## residual "matrices"

  ## ensure that NAs are omitted
  if(is.list(x) && !is.null(x$na.action)) class(x$na.action) <- "omit"

  ## regressors, df, hat values
  X <- model.matrix(x)
  attr(X, "assign") <- NULL
  if(any(alias <- apply(coef(x), 1, function(z) all(is.na(z))))) X <- X[, !alias, drop = FALSE]
  n <- NROW(X)
  diaghat <- hatvalues(x)
  df <- n - NCOL(X)

  ## residuals
  res <- residuals(x)

  ## if omega not specified, set up using type
  if(is.null(omega)) {
    type <- match.arg(type)
    if(type == "HC") type <- "HC0"
    switch(type,
      "const" = {
        warning("not implemented for 'mlm' objects, using vcov() instead")
	return(vcov(x))
       },
      "HC0"   = { omega <- function(residuals, diaghat, df) residuals^2 },
      "HC1"   = { omega <- function(residuals, diaghat, df) residuals^2 * length(residuals)/df },
      "HC2"   = { omega <- function(residuals, diaghat, df) residuals^2 / (1 - diaghat) },
      "HC3"   = { omega <- function(residuals, diaghat, df) residuals^2 / (1 - diaghat)^2 },
      "HC4"   = { omega <- function(residuals, diaghat, df) {
        n <- length(residuals)
	p <- as.integer(round(sum(diaghat),  digits = 0))
	delta <- pmin(4, n * diaghat/p)
        residuals^2 / (1 - diaghat)^delta
      }},
      "HC4m"  = { omega <- function(residuals, diaghat, df) {
        gamma <- c(1.0, 1.5)
        n <- length(residuals)
	p <- as.integer(round(sum(diaghat),  digits = 0))
	delta <- pmin(gamma[1], n * diaghat/p) + pmin(gamma[2], n * diaghat/p)
        residuals^2 / (1 - diaghat)^delta
      }},
      "HC5"   = { omega <- function(residuals, diaghat, df) {
        k <- 0.7
        n <- length(residuals)
	p <- as.integer(round(sum(diaghat),  digits = 0))
	delta <- pmin(n * diaghat/p, pmax(4, n * k * max(diaghat)/p))
        residuals^2 / sqrt((1 - diaghat)^delta)
      }}
    )
  }

  ## process omega
  omega <- apply(res, 2, function(r) omega(r, diaghat, df))

  ## compute crossproduct X' Omega X
  rval <- lapply(1:ncol(omega), function(i) as.vector(sign(res[,i]) * sqrt(omega[,i])) * X)
  rval <- do.call("cbind", rval)
  rval <- crossprod(rval)/n
  colnames(rval) <- rownames(rval) <- colnames(vcov(x))

  ## if necessary compute full sandwich
  if(sandwich) rval <- sandwich(x, meat. = rval, ...)
  return(rval)
}

                 estfun <- function(x, ...)
{
  UseMethod("estfun")
}

estfun.lm <- function(x, ...)
{
  xmat <- model.matrix(x)
  xmat <- naresid(x$na.action, xmat)
  if(any(alias <- is.na(coef(x)))) xmat <- xmat[, !alias, drop = FALSE]
  wts <- weights(x)
  if(is.null(wts)) wts <- 1
  res <- residuals(x)
  rval <- as.vector(res) * wts * xmat
  attr(rval, "assign") <- NULL
  attr(rval, "contrasts") <- NULL
  if(is.zoo(res)) rval <- zoo(rval, index(res), attr(res, "frequency"))
  if(is.ts(res)) rval <- ts(rval, start = start(res), frequency = frequency(res))
  return(rval)
}

estfun.mlm <- function(x, ...)
{
  xmat <- model.matrix(x)
  xmat <- naresid(x$na.action, xmat)
  wts <- weights(x)
  if(is.null(wts)) wts <- 1
  res <- residuals(x)
  cf <- coef(x)
  rval <- lapply(1:NCOL(res), function(i) {
    rv <- as.vector(res[,i]) * wts * xmat
    colnames(rv) <- paste(colnames(cf)[i], colnames(rv), sep = ":")
    rv
  })
  rval <- do.call("cbind", rval)
  attr(rval, "assign") <- NULL
  attr(rval, "contrasts") <- NULL
  if(any(alias <- is.na(as.vector(cf)))) rval <- rval[, !alias, drop = FALSE]
  if(is.zoo(res)) rval <- zoo(rval, index(res), attr(res, "frequency"))
  if(is.ts(res)) rval <- ts(rval, start = start(res), frequency = frequency(res))
  return(rval)
}

estfun.glm <- function(x, ...)
{
  xmat <- model.matrix(x)
  xmat <- naresid(x$na.action, xmat)
  if(any(alias <- is.na(coef(x)))) xmat <- xmat[, !alias, drop = FALSE]
  wres <- as.vector(residuals(x, "working")) * weights(x, "working")
  dispersion <- if(substr(x$family$family, 1, 17) %in% c("poisson", "binomial", "Negative Binomial")) 1
    else sum(wres^2, na.rm = TRUE)/sum(weights(x, "working"), na.rm = TRUE)
  rval <- wres * xmat / dispersion
  attr(rval, "assign") <- NULL
  attr(rval, "contrasts") <- NULL
  res <- residuals(x, type = "pearson")
  if(is.ts(res)) rval <- ts(rval, start = start(res), frequency = frequency(res))
  if(is.zoo(res)) rval <- zoo(rval, index(res), attr(res, "frequency"))
  return(rval)
}

estfun.rlm <- function(x, ...)
{
  xmat <- model.matrix(x)
  xmat <- naresid(x$na.action, xmat)
  wts <- weights(x)
  if(is.null(wts)) wts <- 1
  res <- residuals(x)
  psi <- function(z) x$psi(z) * z
  rval <- as.vector(psi(res/x$s)) * wts * xmat
  attr(rval, "assign") <- NULL
  attr(rval, "contrasts") <- NULL
  if(is.ts(res)) rval <- ts(rval, start = start(res), frequency = frequency(res))
  if(is.zoo(res)) rval <- zoo(rval, index(res), attr(res, "frequency"))
  return(rval)
}

estfun.polr <- function(x, ...)
{
  ## link processing
  mueta <- x$method
  if(mueta == "logistic") mueta <- "logit"
  mueta <- make.link(mueta)$mu.eta

  ## observations
  xmat <- model.matrix(x)[, -1L, drop = FALSE]
  n <- nrow(xmat)
  k <- ncol(xmat)
  m <- length(x$zeta)
  mf <- model.frame(x)
  y <- as.numeric(model.response(mf))
  w <- model.weights(mf)
  if(is.null(w)) w <- rep(1, n)

  ## estimates
  prob <- x$fitted.values[cbind(1:n, y)]
  xb <- if(k >= 1L) as.vector(xmat %*% x$coefficients) else rep(0, n)
  zeta <- x$zeta
  lp <- cbind(0, mueta(matrix(zeta, nrow = n, ncol = m, byrow = TRUE) - xb), 0)

  ## estimating functions
  rval <- matrix(0, nrow = n, ncol = k + m + 2L)
  if(k >= 1L) rval[, 1L:k] <- (-xmat * as.vector(lp[cbind(1:n, y + 1L)] - lp[cbind(1:n, y)]))
  rval[cbind(1:n, k + y)] <- -as.vector(lp[cbind(1:n, y)])
  rval[cbind(1:n, k + y + 1L)] <- as.vector(lp[cbind(1:n, y + 1L)])
  rval <- rval[, -c(k + 1L, k + m + 2L), drop = FALSE]
  rval <- w/prob * rval

  ## dimnames and return
  dimnames(rval) <- list(rownames(xmat), c(colnames(xmat), names(x$zeta)))
  return(rval)
}

estfun.clm <- function(x, ...)
{
  if(x$threshold != "flexible") stop("only flexible thresholds implemented at the moment")

  ## link processing
  mueta <- make.link(x$link)$mu.eta

  ## observations
  xmat <- model.matrix(x)
  if(length(xmat) > 1L) stop("estimating functions for scale regression not implemented yet")
  xmat <- xmat$X[, -1L, drop = FALSE]
  n <- nrow(xmat)
  k <- ncol(xmat)
  m <- length(x$alpha)
  mf <- model.frame(x)
  y <- as.numeric(model.response(mf))
  w <- model.weights(mf)
  if(is.null(w)) w <- rep(1, n)

  ## estimates
  prob <- x$fitted.values
  xb <- if(k >= 1L) as.vector(xmat %*% x$beta) else rep(0, n)
  zeta <- x$alpha
  lp <- cbind(0, mueta(matrix(zeta, nrow = n, ncol = m, byrow = TRUE) - xb), 0)

  ## estimating functions
  rval <- matrix(0, nrow = n, ncol = k + m + 2L)
  if(k >= 1L) rval[, 1L:k] <- (-xmat * as.vector(lp[cbind(1:n, y + 1L)] - lp[cbind(1:n, y)]))
  rval[cbind(1:n, k + y)] <- -as.vector(lp[cbind(1:n, y)])
  rval[cbind(1:n, k + y + 1L)] <- as.vector(lp[cbind(1:n, y + 1L)])
  rval <- rval[, -c(k + 1L, k + m + 2L), drop = FALSE]
  rval <- w/prob * rval

  ## dimnames, re-order and return
  dimnames(rval) <- list(rownames(xmat), c(colnames(xmat), names(x$alpha)))
  ix <- if(k >= 1L) c((k + 1L):(k + m), 1L:k) else 1L:m
  return(rval[, ix, drop = FALSE])
}

estfun.coxph <- function(x, ...)
{
  wts <- x$weights
  if(is.null(wts)) wts <- 1
  wts * residuals(x, type = "score", ...)
}

estfun.survreg <- function(x, ...)
{
  mf <- model.frame(x)
  xmat <- model.matrix(terms(x), mf)
  wts <- model.weights(mf)
  if(is.null(wts)) wts <- 1
  res <- residuals(x, type = "matrix")
  rval <- as.vector(res[,"dg"]) * wts * xmat
  if(NROW(x$var) > length(coef(x))) {
    rval <- cbind(rval, res[,"ds"])
    colnames(rval)[NCOL(rval)] <- "Log(scale)"
  }
  attr(rval, "assign") <- NULL

  return(rval)
}

estfun.nls <- function(x, ...)
{
  rval <- as.vector(x$m$resid()) * x$m$gradient()
  colnames(rval) <- names(coef(x))
  rval
}

estfun.hurdle <- function(x, ...) {
  ## extract data
  Y <- if(is.null(x$y)) model.response(model.frame(x)) else x$y
  X <- model.matrix(x, model = "count")
  Z <- model.matrix(x, model = "zero")
  beta <- coef(x, model = "count")
  gamma <- coef(x, model = "zero")
  fulltheta <- x$theta

  offset <- x$offset
  if(is.list(offset)) {
    offsetx <- offset$count
    offsetz <- offset$zero
  } else {
    offsetx <- offset
    offsetz <- NULL
  }
  if(is.null(offsetx)) offsetx <- 0
  if(is.null(offsetz)) offsetz <- 0
  if(x$dist$zero == "binomial") linkobj <- make.link(x$link)
  wts <- weights(x)
  if(is.null(wts)) wts <- 1
  Y1 <- Y > 0

  ## count component: working residuals
  eta <- as.vector(X %*% beta + offsetx)
  mu <- exp(eta)
  theta <- fulltheta["count"]

  wres_count <- as.numeric(Y > 0) * switch(x$dist$count,
    "poisson" = {
      (Y - mu) - exp(ppois(0, lambda = mu, log.p = TRUE) -
        ppois(0, lambda = mu, lower.tail = FALSE, log.p = TRUE) + eta)
    },
    "geometric" = {
      (Y - mu * (Y + 1)/(mu + 1)) - exp(pnbinom(0, mu = mu, size = 1, log.p = TRUE) -
        pnbinom(0, mu = mu, size = 1, lower.tail = FALSE, log.p = TRUE) - log(mu + 1) + eta)
    },
    "negbin" = {
      (Y - mu * (Y + theta)/(mu + theta)) - exp(pnbinom(0, mu = mu, size = theta, log.p = TRUE) -
        pnbinom(0, mu = mu, size = theta, lower.tail = FALSE, log.p = TRUE) +
	log(theta) - log(mu + theta) + eta)
    })

  ## zero component: working residuals
  eta <- as.vector(Z %*% gamma + offsetz)
  mu <- if(x$dist$zero == "binomial") linkobj$linkinv(eta) else exp(eta)
  theta <- fulltheta["zero"]

  wres_zero <- switch(x$dist$zero,
    "poisson" = {
      ifelse(Y1, exp(ppois(0, lambda = mu, log.p = TRUE) -
        ppois(0, lambda = mu, lower.tail = FALSE, log.p = TRUE) + eta), -mu)
    },
    "geometric" = {
      ifelse(Y1, exp(pnbinom(0, mu = mu, size = 1, log.p = TRUE) -
        pnbinom(0, mu = mu, size = 1, lower.tail = FALSE, log.p = TRUE) - log(mu + 1) + eta), -mu/(mu + 1))
    },
    "negbin" = {
      ifelse(Y1, exp(pnbinom(0, mu = mu, size = theta, log.p = TRUE) -
        pnbinom(0, mu = mu, size = theta, lower.tail = FALSE, log.p = TRUE) +
        log(theta) - log(mu + theta) + eta), -mu * theta/(mu + theta))
    },
    "binomial" = {
      ifelse(Y1, 1/mu, -1/(1-mu)) * linkobj$mu.eta(eta)
    })

  ## compute gradient from data
  rval <- cbind(wres_count * wts * X, wres_zero * wts * Z)
  colnames(rval) <- names(coef(x))
  rownames(rval) <- rownames(X)
  return(rval)
}

estfun.zeroinfl <- function(x, ...) {
  ## extract data
  Y <- if(is.null(x$y)) model.response(model.frame(x)) else x$y
  X <- model.matrix(x, model = "count")
  Z <- model.matrix(x, model = "zero")
  beta <- coef(x, model = "count")
  gamma <- coef(x, model = "zero")
  theta <- x$theta

  offset <- x$offset
  if(is.list(offset)) {
    offsetx <- offset$count
    offsetz <- offset$zero
  } else {
    offsetx <- offset
    offsetz <- NULL
  }
  if(is.null(offsetx)) offsetx <- 0
  if(is.null(offsetz)) offsetz <- 0
  linkobj <- make.link(x$link)
  wts <- weights(x)
  if(is.null(wts)) wts <- 1
  Y1 <- Y > 0

  eta <- as.vector(X %*% beta + offsetx)
  mu <- exp(eta)
  etaz <- as.vector(Z %*% gamma + offsetz)
  muz <- linkobj$linkinv(etaz)

  ## density for y = 0
  clogdens0 <- switch(x$dist,
    "poisson" = -mu,
    "geometric" = dnbinom(0, size = 1, mu = mu, log = TRUE),
    "negbin" = dnbinom(0, size = theta, mu = mu, log = TRUE))
  dens0 <- muz * (1 - as.numeric(Y1)) + exp(log(1 - muz) + clogdens0)

  ## working residuals
  wres_count <- switch(x$dist,
    "poisson" = ifelse(Y1, Y - mu, -exp(-log(dens0) + log(1 - muz) + clogdens0 + log(mu))),
    "geometric" = ifelse(Y1, Y - mu * (Y + 1)/(mu + 1), -exp(-log(dens0) +
      log(1 - muz) + clogdens0 - log(mu + 1) + log(mu))),
    "negbin" = ifelse(Y1, Y - mu * (Y + theta)/(mu + theta), -exp(-log(dens0) +
      log(1 - muz) + clogdens0 + log(theta) - log(mu + theta) + log(mu))))
  wres_zero <- ifelse(Y1, -1/(1-muz) * linkobj$mu.eta(etaz),
    (linkobj$mu.eta(etaz) - exp(clogdens0) * linkobj$mu.eta(etaz))/dens0)

  ## compute gradient from data
  rval <- cbind(wres_count * wts * X, wres_zero * wts * Z)
  colnames(rval) <- names(coef(x))
  rownames(rval) <- rownames(X)
  return(rval)
}

estfun.mlogit <- function(x, ...)
{
  x$gradient
}

                 bread <- function(x, ...)
{
  UseMethod("bread")
}

bread.default <- function(x, ...) {
  nobs0(x) * vcov0(x, ...)
}

bread.lm <- function(x, ...)
{
  if(!is.null(x$na.action)) class(x$na.action) <- "omit"
  sx <- summary.lm(x)
  return(sx$cov.unscaled * as.vector(sum(sx$df[1L:2L])))
}

bread.mlm <- function(x, ...)
{
  if(!is.null(x$na.action)) class(x$na.action) <- "omit"
  cf <- coef(x)
  rval <- summary.lm(x)
  rval <- kronecker(
    structure(diag(ncol(cf)), .Dimnames = rep.int(list(colnames(cf)), 2L)),
    structure(rval$cov.unscaled,  .Dimnames = rep.int(list(rownames(cf)), 2L)) * as.vector(sum(rval$df[1L:2L])),
    make.dimnames = TRUE
  )
  return(rval)
}

bread.glm <- function(x, ...)
{
  if(!is.null(x$na.action)) class(x$na.action) <- "omit"
  sx <- summary(x)
  wres <- as.vector(residuals(x, "working")) * weights(x, "working")
  dispersion <- if(substr(x$family$family, 1L, 17L) %in% c("poisson", "binomial", "Negative Binomial")) 1
    else sum(wres^2)/sum(weights(x, "working"))
  return(sx$cov.unscaled * as.vector(sum(sx$df[1L:2L])) * dispersion)
}

bread.nls <- function(x, ...)
{
  if(!is.null(x$na.action)) class(x$na.action) <- "omit"
  sx <- summary(x)
  return(sx$cov.unscaled * as.vector(sum(sx$df[1L:2L])))
}

bread.polr <- function(x, ...)
{
  vcov(x) * x$n
}

bread.clm <- function(x, ...)
{
  vcov(x) * x$n
}

bread.survreg <- function(x, ...)
  length(x$linear.predictors) * x$var

bread.gam <- function(x, ...)
{
  if(!is.null(x$na.action)) class(x$na.action) <- "omit"
  sx <- summary(x)
  sx$cov.unscaled * sx$n
}

bread.coxph <- function(x, ...)
{
  rval <- x$var * x$n
  dimnames(rval) <- list(names(coef(x)), names(coef(x)))
  return(rval)
}

bread.hurdle <- function(x, ...)
{
  x$vcov * x$n
}

bread.zeroinfl <- function(x, ...)
{
  x$vcov * x$n
}

bread.mlogit <- function(x, ...)
{
  if(!is.null(x$na.action)) class(x$na.action) <- "omit"
  vcov(x) * length(residuals(x))
}

bread.rlm <- function(x, ...)
{
  if(!is.null(x$na.action)) class(x$na.action) <- "omit"
  xmat <- model.matrix(x)
  xmat <- naresid(x$na.action, xmat)
  wts <- weights(x)
  if(is.null(wts)) wts <- 1
  res <- residuals(x)
  psi_deriv <- function(z) x$psi(z, deriv = 1)
  rval <- sqrt(abs(as.vector(psi_deriv(res/x$s)/x$s))) * wts * xmat
  rval <- chol2inv(qr.R(qr(rval))) * nrow(xmat)
  return(rval)
}


rm(list = ls())

# Initial Parameters given by the user.
args <- commandArgs(trailingOnly = TRUE)
datasetName <- args[1] # The name of the community's csv file.
transposition <- as.logical(args[2]) # Choose to transpose the matrix (TRUE) or not (FALSE).
factorsetName <- args[3] # The name of the factor's csv file.
SelectFactor <- as.numeric(args[4]) # Choose Factor.
datasetPath <- args[5] # The directory (path) where the dataset is stored.
permutations <- as.numeric(args[6])
trace <- as.logical(args[7])

setwd(datasetPath)

comm <- read.csv(datasetName, header = TRUE, row.names = 1, sep = ",")
group <- read.csv(factorsetName, header = TRUE, row.names = 1, sep = ",")

# Transpose community matrix.
if (transposition) {
  comm <- t(comm)#; mt <- "comm ~ group[, 1]"
} else if (transposition != TRUE) {
  comm <- comm# ; mt <- "comm ~ group[, 1]"
} else {
  stop("Wrong choice. For matrix's transposition choose TRUE else FALSE.")
}

Ft <- ncol(group)

# Check if the arguments are greater than Factor's columns.
if (((SelectFactor <= 0) || (SelectFactor > Ft))) {
  stop("Wrong choice of Factors, transcends available Factors choices.")
} else {
  group <- group[, SelectFactor]
}

if((permutations < 0) || is.numeric(permutations) != TRUE) {
  stop("Negative permutations number. Use non-negative values.")
}

# Load libraries.
library(vegan)
library(pbdMPI, quiet = TRUE)

init()

# Start the clock.
fullProgramTimer = proc.time()

# TP: Get the size of the cluster.
processors <- comm.size()
myrank <- comm.rank()

parallel = getOption("mc.cores")

if (any(rowSums(comm, na.rm = TRUE) == 0))
  warning("you have empty rows: results may be meaningless")

pfun <- function(x, comm, comp, i, contrp) {
  groupp <- group[perm[x, ]]
  ga <- comm[groupp == comp[i, 1], , drop = FALSE]
  gb <- comm[groupp == comp[i, 2], , drop = FALSE]
  n.a <- nrow(ga)
  n.b <- nrow(gb)
  for (j in seq_len(n.b)) {
    for (k in seq_len(n.a)) {
      mdp <- abs(ga[k, , drop = FALSE] - gb[j, , drop = FALSE])
      mep <- ga[k, , drop = FALSE] + gb[j, , drop = FALSE]
      contrp[(j - 1) * n.a + k, ] <- mdp/sum(mep)
    }
  }
  colMeans(contrp)
}

getPermuteMatrix <- function(perm, N,  strata = NULL) {
  if (length(perm) == 1) {
    perm <- how(nperm = perm)
  }

  if (!missing(strata) && !is.null(strata)) {
    if (inherits(perm, "how") && is.null(getBlocks(perm)))
      setBlocks(perm) <- strata
  }

  if (inherits(perm, "how"))
    perm <- shuffleSet(N, control = perm)

  if (is.null(attr(perm, "control")))
    attr(perm, "control") <-
    structure(list(within=list(type="supplied matrix"),
                   nperm = nrow(perm)), class = "how")
  perm
}

comm <- as.matrix(comm)
comp <- t(combn(unique(as.character(group)), 2))
outlist <- NULL
P <- ncol(comm)
nobs <- nrow(comm)
perm <- getPermuteMatrix(permutations, nobs)
if (ncol(perm) != nobs)
  stop(gettextf("'permutations' have %d columns, but data have %d rows",
                ncol(perm), nobs))
nperm <- nrow(perm)

if (nperm > 0) # TRUE
  perm.contr <- matrix(nrow = P, ncol = nperm)
if (is.null(parallel)) # TRUE
  parallel <- 1
hasClus <- inherits(parallel, "cluster")
isParal <- hasClus || parallel > 1
isMulticore <- .Platform$OS.type == "unix" && !hasClus
if (isParal && !isMulticore && !hasClus) { # FALSE
  parallel <- makeCluster(parallel)
}

i <- 1
mainCalcTimer = proc.time()

group.a <- comm[group == comp[i, 1], , drop = FALSE]
group.b <- comm[group == comp[i, 2], , drop = FALSE]
n.a <- nrow(group.a)
n.b <- nrow(group.b)
contr <- matrix(ncol = P, nrow = n.a * n.b)
for (j in seq_len(n.b)) {
  for (k in seq_len(n.a)) {
    md <- abs(group.a[k, , drop = FALSE] - group.b[j,
                                                   , drop = FALSE])
    me <- group.a[k, , drop = FALSE] + group.b[j,
                                               , drop = FALSE]
    contr[(j - 1) * n.a + k, ] <- md/sum(me)
  }
}
average <- colMeans(contr)

if (nperm > 0) {
  if (trace) # FALSE
    cat("Permuting", paste(comp[i, 1], comp[i, 2],
                           sep = "_"), "\n")

  contrp <- matrix(ncol = P, nrow = n.a * n.b)

  step1 <- floor(nperm/processors)
  step2 <- nperm - step1*(processors - 1)

  if (myrank != (processors - 1)) {
    p2 <- sapply(((myrank*step1) + 1):((myrank + 1)*step1), function(d) pfun(d, comm, comp, i, contrp))
    p.partial <- rowSums(apply(p2, 2, function(x) x >= average))
  } else {
    p2 <- sapply((nperm - step2 + 1):nperm, function(d) pfun(d, comm, comp, i, contrp))
    p.partial <- rowSums(apply(p2, 2, function(x) x >= average))
  }
} else {
  p <- NULL
}

# p1 <- gather(p2)
p.all <- gather(p.partial)

if(myrank == 0) {
#   p3 <- NULL
  p1 <- 0
  for(j in 1:processors){
#     p3 <- cbind(p3, p1[[j]])
    p1 <- p1 + p.all[[j]]
  }
  p.all <- (p1 + 1)/(nperm + 1); rm(p1)
}

comm.print(length(p.all))

comm.print("permutations", rank.print = 0)
comm.print(permutations, rank.print = 0)

overall <- sum(average)
sdi <- apply(contr, 2, sd)
ratio <- average/sdi
ava <- colMeans(group.a)
avb <- colMeans(group.b)
ord <- order(average, decreasing = TRUE)
cusum <- cumsum(average[ord]/overall)
out <- list(species = colnames(comm), average = average,
             overall = overall, sd = sdi, ratio = ratio, ava = ava,
             avb = avb, ord = ord, cusum = cusum, p = p.all)
outlist[[paste(comp[i, 1], "_", comp[i, 2], sep = "")]] <- out

if (isParal && !isMulticore && !hasClus) # FALSE#
   stopCluster(parallel)
attr(outlist, "permutations") <- nperm
attr(outlist, "control") <- attr(perm, "control")
class(outlist) <- "simper"
outlist

# Stop the clock
comm.print("Time for each processor to perform the main calculation loop",rank.source = 0)
comm.print(proc.time() - mainCalcTimer, all.rank=T)

comm.print("Full program execution time for each processor", rank.source = 0)
comm.print(proc.time() - fullProgramTimer, all.rank = T)

comm.print("Size of the final result (Mb)", rank.source = 0)
comm.print(object.size(outlist)/(1024^2), all.rank = T)

finalize()


#Sum, mean and product of a vector

x<-c(10, 20, 30)
print("Sum:")
print(sum(x))
print("Mean:")
print(mean(x))
print("Product:")
print(prod(x))


# R-defining the argument

args = commandArgs(trailingOnly=TRUE)

# Reading the dataframe using argument
Regdata <- read.csv(args[1])
x <- Regdata$x
y <- Regdata$y

print(Regdata)

# Creating a scatterplot

png('scatterplot-Script-from-R.png')
plot(x, y, main = "Regex1_scatterplot_R", col = "blue")

# creating a linearmodel

png('linearmodeling-Script-from-R.png')
plot(x, y, main = "regrex1_scatterplot_R_linermodeling", col = "blue")
abline(lm(y ~ x))


##############################
### SVM PREDICT
##############################
##############################
### FILENAME DETAILS
##############################
filename <- sprintf("%s PREDICT %s.txt", "SVM", toString(format(Sys.time(), "%Y-%m-%d %H-%M-%S")))
##############################
### PREDICTION DATAFRAME
##############################
predict.df <- #Prediction for 1/25/19
  data.frame("LR1.8" = c(5.3), # AMD LAG 1 - i.e. 1/24/19
             "LR3.8" = c(-4.86), # AMD LAG 3 - i.e. 1/22/19
             "LR1" = c(0.05), # SPY LAG 1 - i.e. 1/24/19
             "LR3" = c(-1.35), # SPY LAG 3 - i.e. 1/22/19
             "LR1.1" = c(0.65), # QQQ LAG 1 - i.e. 1/24/19
             "LR3.1" = c(-2.0), # QQQ LAG 3 - i.e. 1/22/19
             "LR1.3" = c(1.88), # QQQ LAG 1 - i.e. 1/24/19
             "LR3.3" = c(-1.29), # QQQ LAG 3 - i.e. 1/22/19
             "LR1.10" = c(-4.79), # UVXY LAG 1 - i.e. 1/24/19
             "LR3.10" = c(13.46) # UVXY LAG 3 - i.e. 1/22/19
  )
#############################
### SAVE TO FILE
#############################
models <- list(amd.svm.model, pypl.svm.model)
names(models) <- c('amd', 'pypl')
sink(filename)
lapply(models, SvmPred, predict.df)
sink()


# CTD Data Analysis ----
library(here)
library(tidyverse)
library(glue)
library(ggh4x)
library(oce)
library(ggrepel)
source("functions/functions.R")

# Meta Data ----
files <- tribble(
    ~"short", ~"deep", ~"file",
    "BAB", 150, "BAB_AB332_5th_Oct_2021",
    "ISA", 65, "ISA_AB332_6th_Oct_2021",
    "ISG", 250, "IsG_AB332_7th_Oct_21",
    "ISK", 250, "ISK_Ab332_6th_oct_2021"
)

# Loading Files -----
data <- list()
for (i in seq_len(nrow(files))) {
    row <- files[i, ]
    data[[i]] <- read_tsv(glue("data/{row$file}.txt"), skip = 3, locale = locale(encoding = "latin1")) %>%
        janitor::clean_names() %>%
        add_column(
            location = row$short,
            deep = row$deep
        )
}
data <- bind_rows(data)

# Data Wranling ----
ctd <- data %>%
    group_by(location) %>%
    mutate(
        direction = ifelse(press > lead(press, 2), "up", "down")
    ) %>%
    ungroup() %>%
    # mutate(
    #    press = round(press, 1)
    # ) %>%
    filter(direction == "down" & press >= 0.8) %>%
    glimpse() %>%
    # group_by(location, press) %>%
    # mutate(
    #    across(where(is.double), mean)
    # ) %>%
    # ungroup() %>%
    mutate(
        depth = oce::swDepth(press, latitude = 78)
    ) %>%
    arrange(press) %>%
    glimpse() %>%
    dplyr::select(sal:press, location:depth)

# Long Format Plotting all Variables
ctd_long <- ctd %>%
    dplyr::select(-direction) %>%
    pivot_longer(-c("press", "location", "deep", "depth"))

# for (i in seq_len(nrow(files))) {
#    row <- files[i, ]
#    p <- ctd_long %>%
#        filter(location == row$short) %>%
#        ggplot(aes(y = press, x = value)) +
#        geom_hline(yintercept = 0, linetype = "dashed", color = "#E69F00") +
#        geom_hline(yintercept = 15, linetype = "dashed", color = "#E69F00") +
#        geom_hline(yintercept = row$depth, linetype = "dashed", color = "#E69F00") +
#        geom_path(col = "black") +
#        scale_y_reverse(breaks = scales::breaks_pretty()) +
#        scale_x_continuous(position = "top", breaks = scales::breaks_pretty()) +
#        theme_bw() +
#        facet_wrap(~name, scales = "free_x", ncol = 4) +
#        labs(
#            title = row$short,
#            y = "Pressure (dbar)",
#            x = ""
#        )
#    fSaveImages(p, row$short, h = 8)
# }

# Plot Temp VS Salinity
## Secondary Axis
sec <- ggh4x::help_secondary(
    ctd,
    primary = sal,
    secondary = temp,
    name = "Temperature [°C]",
    method = "range",
    breaks = c(-1, 0, 1, 2, 3, 4, 5)
)
## Wide Format Plotting
p <- ctd %>%
    ggplot(aes(y = depth)) +
    geom_path(aes(x = sal, color = "Salinity"), show.legend = FALSE) +
    geom_path(aes(x = sec$proj(temp), color = "Temperature"), show.legend = FALSE) +
    geom_hline(yintercept = 0, linetype = "dashed", color = "#CC79A7") +
    geom_hline(yintercept = 15, linetype = "dashed", color = "#CC79A7") +
    geom_hline(aes(yintercept = deep), linetype = "dashed", color = "#CC79A7") +
    scale_y_reverse(breaks = scales::breaks_pretty()) +
    scale_x_continuous(
        limits = c(NA, 35),
        breaks = seq(32, 35, 0.5),
        # position = "top",
        sec.axis = sec
    ) +
    scale_color_manual(
        values = c("Temperature" = "#D55E00", "Salinity" = "#009E73"),
    ) +
    theme_bw() +
    theme(
        axis.line.x.bottom = element_line(color = "#009E73"),
        axis.ticks.x.bottom = element_line(color = "#009E73"),
        axis.text.x.bottom = element_text(color = "#009E73"),
        axis.title.x.bottom = element_text(color = "#009E73", size = 14),
        axis.line.x.top = element_line(color = "#D55E00"),
        axis.ticks.x.top = element_line(color = "#D55E00"),
        axis.text.x.top = element_text(color = "#D55E00"),
        axis.title.x.top = element_text(color = "#D55E00", size = 14),
        panel.grid = element_blank(),
        legend.position = "bottom",
        legend.title = element_blank(),
        legend.text = element_text(size = 15),
        panel.grid.major.y = element_line(linetype = "dotted", color = "gray90")
    ) +
    labs(
        y = "Depth [m]",
        x = "Practical Salinity"
    )
p_fixed <- p +
    facet_wrap(
        ~location,
        scales = "fixed",
        strip.position = "right"
    )
p_free_y <- p +
    facet_wrap(
        ~location,
        scales = "free_y",
        strip.position = "right"
    )
fSaveImages(p_fixed, "salinity_temp_fixed", h = 6)
fSaveImages(p_free_y, "salinity_temp_free", h = 6)

# Get Sample Depth Mean Values
ctd_sample <- ctd %>%
    group_by(location) %>%
    mutate(
        sample_group = case_when(
            between(depth, 0, 1.5) ~ "0",
            between(depth, 14, 16) ~ "15",
            between(depth, first(deep) - 1, first(deep) + 1) ~ "deep",
            TRUE ~ "NA"
        )
    ) %>%
    filter(sample_group != "NA") %>%
    group_by(location, sample_group) %>%
    summarise(
        across(where(is.double), function(x) {
            mean(x) %>% round(2)
        })
    ) %>%
    glimpse() # %>%
# mutate(
#    sample_group = forcats::fct_relevel(sample_group, "deep", "15", "0")
# )

p <- ctd_sample %>%
    select(sample_group, location, sal, temp, opmg_l, f_mg_l) %>%
    pivot_longer(-c("sample_group", "location")) %>%
    group_by(name) %>%
    mutate(
        error = sqrt(var(value) / length(value)),
        label = case_when(
            name == "sal" ~ "Practical Salinity",
            name == "temp" ~ "Temperature [°C]",
            name == "f_mg_l" ~ "Chlorophyll [g/ml]",
            name == "opmg_l" ~ "Oxygen Partial Pressure [g/ml]"
        )
    ) %>%
    # filter(location == "ISA") %>%
    ggplot(
        aes(y = value, x = sample_group, fill = location)
    ) +
    geom_col(position = "dodge") +
    geom_errorbar(
        aes(ymin = value - error, ymax = value + error),
        width = 0.2,
        position = position_dodge(width = 0.9)
    ) +
    theme_bw() +
    scale_fill_manual(
        values = c(
            "#E69F00", "#56B4E9", "#009E73", "#CC79A7"
        ),
        guide = guide_legend("Location")
    ) +
    scale_y_continuous(breaks = scales::pretty_breaks()) +
    labs(
        y = "",
        x = "Sample Depth [m]"
    ) +
    theme(
        panel.grid = element_blank(),
        panel.grid.major.y = element_line(linetype = "dotted", color = "gray90")
    ) +
    facet_wrap(~label, scale = "free_y")

fSaveImages(p, "sample_params", h = 6)

# Water masses
# Temp Y
# Salinity X

watermasses <- tribble(
    ~ext, ~long, ~short, ~temp_low, ~temp_high, ~salinity_low, ~salinity_high,
    "External", "Atlantic Water", "AW", 3, 5, 34.9, 35,
    "External", "Arctic Water", "ArW", -2, 0, 34.3, 34.8,
    "Local", "Surface Water", "SW", 1, 5, 32.5, 34,
    "Local", "Local Water", "LW", -2, 1, 32.5, 35,
    "Local", "Winter-Cooled Water", "WCW", -2, -0.50, 34.4, 35,
    "Mixed", "Intermediate Water", "IW", 1.0, 5, 34, 34.7,
    "Mixed", "Transformed Atlantic Water", "TAW", 1, 3, 34.7, 34.9
) %>%
    mutate(
        long = forcats::fct_relevel(long, "Arctic Water", "Atlantic Water", "Surface Water", "Local Water", "Winter-Cooled Water", "Intermediate Water", "Transformed Atlantic Water")
    )

#    sample_group = forcats::fct_relevel(sample_group, "deep", "15", "0")

p <- ggplot(ctd_sample, aes(y = temp, x = sal)) +
    geom_rect(
        data = watermasses %>% filter(ext != "External"),
        mapping = aes(ymin = temp_low, ymax = temp_high, xmin = salinity_low, xmax = salinity_high, fill = long),
        inherit.aes = FALSE,
        alpha = 1
    ) +
    geom_rect(
        data = watermasses %>% filter(ext == "External" | short %in% c("WCW", "TAW")),
        mapping = aes(ymin = temp_low, ymax = temp_high, xmin = salinity_low, xmax = salinity_high, fill = long),
        inherit.aes = FALSE,
        alpha = 1
    ) +
    geom_point(
        aes(shape = location),
        color = "black",
        size = 3
    ) +
    scale_fill_manual(
        values = colorBlindBlack8,
        name = "Water masses"
    ) +
    scale_shape_discrete(name = "Locations") +
    scale_y_continuous(breaks = c(-2:5)) +
    scale_x_continuous(breaks = c(30:35)) +
    ggrepel::geom_label_repel(
        aes(label = paste0(location, " (", sample_group, ")")),
        color = "black"
    ) +
    labs(
        x = "Salinity [psu]",
        y = "Temperature [°C]"
    )

fSaveImages(p, "water_masses", h = 7, w = 10)

# Plot Fluoresence
# f_gml = Chlorophyl based on fluoresence g/ml
p <- ctd_long %>%
    filter(name %in% c("f_mg_l")) %>%
    ggplot(aes(y = depth, x = value)) +
    geom_path() +
    facet_nested(~location, scales = "fixed") +
    geom_hline(yintercept = 0, linetype = "dashed", color = "#CC79A7") +
    geom_hline(yintercept = 15, linetype = "dashed", color = "#CC79A7") +
    geom_hline(aes(yintercept = deep), linetype = "dashed", color = "#CC79A7") +
    scale_x_continuous(
        breaks = scales::breaks_pretty(),
        sec.axis = ~.
    ) +
    scale_y_reverse(
        breaks = scales::breaks_pretty()
    ) +
    labs(
        y = "Depth [m]",
        x = "Chlorophyll [g/ml]"
    ) +
    theme_bw() +
    theme(
        strip.placement = "outside",
        axis.title.x.bottom = element_text(size = 14),
        panel.grid = element_blank(),
        legend.position = "bottom",
        legend.title = element_blank(),
        legend.text = element_text(size = 15),
        panel.grid.major.y = element_line(linetype = "dotted", color = "gray90"),
        panel.grid.major.x = element_line(linetype = "dotted", color = "gray90")
    )
fSaveImages(p, "chlorophyll", h = 4)

# Plot Oxygen
# f_gml = Chlorophyl based on fluoresence g/ml
p <- ctd_long %>%
    filter(name %in% c("opmg_l")) %>%
    ggplot(aes(y = depth, x = value)) +
    geom_path() +
    facet_nested(~location, scales = "fixed") +
    geom_hline(yintercept = 0, linetype = "dashed", color = "#CC79A7") +
    geom_hline(yintercept = 15, linetype = "dashed", color = "#CC79A7") +
    geom_hline(aes(yintercept = deep), linetype = "dashed", color = "#CC79A7") +
    scale_x_continuous(
        breaks = scales::breaks_pretty(),
        sec.axis = ~.
    ) +
    scale_y_reverse(
        breaks = scales::breaks_pretty()
    ) +
    labs(
        y = "Depth [m]",
        x = "Oxygen Partial Pressure [g/ml]"
    ) +
    theme_bw() +
    theme(
        strip.placement = "outside",
        axis.title.x.bottom = element_text(size = 14),
        panel.grid = element_blank(),
        legend.position = "bottom",
        legend.title = element_blank(),
        legend.text = element_text(size = 15),
        panel.grid.major.y = element_line(linetype = "dotted", color = "gray90"),
        panel.grid.major.x = element_line(linetype = "dotted", color = "gray90")
    )
fSaveImages(p, "oxygen", h = 4)

# If we want to play with oce package
# ctdRaw <- with(ctd[ctd$location == "ISA", ], as.ctd(
#    salinity = sal,
#    pressure = press,
#    temperature = temp,
#    # time = time
#    # deploymentType = "profile",
#    # sampleInterval = 2
# ))
#
# summary(ctdRaw)
# plotScan(ctdRaw)
#
# plotScan(ctdTrim(ctdRaw, "range",
#    parameters = list(item = "scan", from = 600, to = 800)
# ))
# ctdTrimmed <- ctdDecimate(ctdTrim(ctdRaw))
# plotScan(ctdTrimmed)
# plot(ctdTrimmed)
# plot(ctdRaw)


#' Projection test for query interval overlap.
#'
#' @param x [ivl_df]
#' @param y [ivl_df]
#' @param genome [genome_df]
#' @param by_chrom compute test per chromosome
#'
#' @template stats
#'
#' @family interval statistics
#'
#' @return
#' [ivl_df] with the following columns:
#'
#'   - `chrom` the name of chromosome tested if `by_chrom = TRUE`,
#'      otherwise has a value of `whole_genome`
#'
#'   - `p.value` p-value from a binomial test. p-values > 0.5
#'      are converted to `1 - p-value` and `lower_tail` is `FALSE`
#'
#'   - `obs_exp_ratio` ratio of observed to expected overlap frequency
#'
#'   - `lower_tail` `TRUE` indicates the observed overlaps are in the lower tail
#'     of the distribution (e.g., less overlap than expected). `FALSE` indicates
#'     that the observed overlaps are in the upper tail of the distribution (e.g.,
#'     more overlap than expected)
#'
#' @seealso
#'   \url{https://journals.plos.org/ploscompbiol/article?id=10.1371/journal.pcbi.1002529}
#'
#' @examples
#' genome <- read_genome(valr_example('hg19.chrom.sizes.gz'))
#'
#' x <- bed_random(genome, seed = 1010486)
#' y <- bed_random(genome, seed = 9203911)
#'
#' bed_projection(x, y, genome)
#'
#' bed_projection(x, y, genome, by_chrom = TRUE)
#'
#' @export
bed_projection <- function(x, y, genome, by_chrom = FALSE) {
  x <- check_interval(x)
  y <- check_interval(y)
  genome <- check_genome(genome)

  # find midpoints
  x <- mutate(
    x,
    .midpoint = round((end + start) / 2),
    start = .midpoint,
    end = .midpoint + 1
  )
  x <- select(x, -.midpoint)

  # flatten y intervals
  y <- bed_merge(y)

  # count overlaps per chromosome,
  obs_counts <- bed_intersect(x, y)

  # count overlaps
  obs_counts <- group_by(obs_counts, chrom)
  obs_counts <- summarize(obs_counts, .obs_counts = n())

  # total x intervals tested
  total_counts <- group_by(x, chrom)
  total_counts <- summarize(total_counts, .total_trials = n())
  obs_counts <- full_join(obs_counts, total_counts, by = "chrom")
  obs_counts <- mutate(
    obs_counts,
    .obs_counts = if_else(is.na(.obs_counts),
      as.integer(0),
      .obs_counts
    )
  )

  # calculate probabilty of overlap by chance
  y <- mutate(y, .length = end - start)
  y <- group_by(y, chrom)
  y <- summarize(y, .reference_coverage = sum(.length))

  # add in any missing chromosomes
  y <- full_join(y, genome, by = "chrom")

  null_dist <- mutate(y, .exp_prob = .reference_coverage / size)

  res <- inner_join(obs_counts, null_dist, by = "chrom")

  # binomial test and obs/exp
  if (by_chrom) {
    res <- group_by(res, chrom)
    res <- summarize(
      res,
      p.value = stats::pbinom(
        q = .obs_counts,
        size = .total_trials,
        prob = .exp_prob
      ),
      obs_exp_ratio = (.obs_counts / .total_trials) / .exp_prob
    )
  } else {
    res <- ungroup(res)
    res <- summarize(
      res,
      .obs_counts = sum(.obs_counts),
      .total_trials = sum(.total_trials),
      .exp_prob = sum(.reference_coverage) /
        sum(as.numeric(size))
    )

    res <- summarize(
      res,
      chrom = "whole_genome",
      p.value = stats::pbinom(
        q = .obs_counts,
        size = .total_trials,
        prob = .exp_prob
      ),
      obs_exp_ratio = (.obs_counts / .total_trials) / .exp_prob
    )
  }

  res <- mutate(
    res,
    lower_tail = if_else(p.value < .5,
      "TRUE",
      "FALSE"
    ),
    p.value = if_else(p.value < .5,
      p.value,
      1 - p.value
    )
  )
  res
}


context("model training and tuning")

test_that("confusion matrix parsing works", {
  data(confusionmatrix)

  res <- get_parsed_binary_confusion_matrix_stats(cm)

  observed <- res$kappa[1]
  expected <- 0.2946

  expect_equal(expected, observed, tolerance=0.01)
})


rm(list=ls())
getwd()
#Librerias
library(dplyr)
library(Hmisc)
library(reshape2)
library(ggplot2)
library(readr)
muestra_total <- read_csv("muestra_total.csv")
##############################Filtrando el data set por año#############
muestra_1990 <-data.frame(vuelos_ano%>% filter(Year ==1990))
muestra_2000 <-data.frame(vuelos_ano%>% filter(Year ==2000))
muestra_2005 <-data.frame(vuelos_ano%>% filter(Year ==2005))
muestra_2008 <-data.frame(vuelos_ano%>% filter(Year ==2008))

##################Funcion que crea el numero de filas aleatorio basados en la aleatoriedad sistematica (algoritmo tomado de internet) ##########
sys.sample = function(N,n){
  k = ceiling(N/n)
  r = sample(1:k, 1)
  sys.samp = seq(r, r + k*(n-1), k)
}

#el n de cada año se tomo en base a un margen de error del 10% y un nivel de confianza del 95%
############# para el 1990#######################
random_r_1990 <- (sys.sample(5270893, 812378))
seleccion_1990 <-muestra_1990 %>% slice(random_r_1990)
############# para el 2000#######################
random_r_2000 <- (sys.sample(5683047, 821561))
seleccion_2000 <- muestra_2000 %>% slice(random_r_2000)
############# para el 2005#######################
random_r_2005 <- (sys.sample(7140585, 846541))
seleccion_2005 <- muestra_2005 %>% slice(random_r_2005)
############# para el 2008#######################
random_r_2008 <- (sys.sample(7009724, 844672))
seleccion_2008 <- muestra_2008 %>% slice(random_r_2008)
################muestra total###################################
muestra_total <- rbind(seleccion_1990,seleccion_2000, seleccion_2005, seleccion_2008)
library("rio")
export(muestra_total, "muestra_total.csv")

#Parte 1- Replica Documento proyecto_final_1.0 pero con la muestra
#################################Punto 2 Ejercicio 1- Tomado de la Muestra#########################################################
#Frecuencias relativas y absolutas de 4 variables diferentes
Num_muestra_total   <-data.frame(muestra_total%>%  filter(!is.na(FlightNum)) %>%group_by(Year) %>% summarise(Unique_Elements = n_distinct(FlightNum)))
Aviones_ano  <-data.frame(muestra_total%>%  filter(!is.na(TailNum)) %>%group_by(Year) %>% summarise(Unique_Elements = n_distinct(TailNum)))
Origen_ano   <-data.frame(muestra_total%>%  filter(!is.na(Origin)) %>%group_by(Year) %>% summarise(Unique_Elements = n_distinct(Origin)))
Destino_ano  <-data.frame(muestra_total%>%  filter(!is.na(Dest)) %>%group_by(Year) %>% summarise(Unique_Elements = n_distinct(Dest)))

#Numero de vuelos por ano
Num_muestra_total$Frecuencia_Relativa <- prop.table(Num_muestra_total$Unique_Elements)
Num_muestra_total$Frecuencia_Acumulada <- cumsum(Num_muestra_total$Unique_Elements)
Num_muestra_total$Frecuencia_Relativa_Acumulada <- cumsum(Num_muestra_total$Frecuencia_Relativa)
Num_muestra_total

ggplot(Num_muestra_total, aes(x=Year, y=Unique_Elements)) + geom_bar(stat = "identity")+
  geom_text(aes(y=as.numeric(Unique_Elements), label=as.numeric(Unique_Elements), vjust=0.0,  size=4.0, fontface="bold")) +
  labs(title="Numero de vuelos distintos por año- Tomado de la Muestra") +
  xlab(label="Año")+
  theme(
    plot.title = element_text(size=16),
    plot.subtitle = element_text(size=13),
    axis.title= element_text(size=11),
    plot.caption = element_text(size=11),
    axis.text.y= element_text(size=10, color="black", face="bold"),
    axis.text.x= element_text(size=10, color="black", face="bold"))

#Numero de Aviones por Año
Avionesdist_ano$Frecuencia_Relativa <- prop.table(Aviones_ano$Unique_Elements)
Avionesdist_ano$Frecuencia_Acumulada <- cumsum(Aviones_ano$Unique_Elements)
Avionesdist_ano$Frecuencia_Relativa_Acumulada <- cumsum(Aviones_ano$Frecuencia_Relativa)
View(Avionesdis_ano)

ggplot(Aviones_ano, aes(x=Year, y=Unique_Elements)) + geom_bar(stat = "identity")+
  geom_text(aes(y=as.numeric(Unique_Elements), label=as.numeric(Unique_Elements), vjust=0.0,  size=4.0, fontface="bold")) +
  labs(title="Numero de Aviones distintos por Año- Tomado de la Muestra") +
  xlab(label="Año")+
  theme_minimal()  +
  theme(text = element_text(family = "Palatino"),
        plot.title = element_text(size=16),
        plot.subtitle = element_text(size=13),
        axis.title= element_text(size=11),
        plot.caption = element_text(size=11),
        axis.text.y= element_text(size=10, color="black", face="bold"),
        axis.text.x= element_text(size=10, color="black", face="bold"))

#Numero de ciudades de Origen por año
Origen_ano$Frecuencia_Relativa <- prop.table(Origen_ano$Unique_Elements)
Origen_ano$Frecuencia_Acumulada <- cumsum(Origen_ano$Unique_Elements)
Origen_ano$Frecuencia_Relativa_Acumulada <- cumsum(Origen_ano$Frecuencia_Relativa)
Origen_ano

ggplot(Origen_ano, aes(x=Year, y=Unique_Elements)) + geom_bar(stat = "identity")+
  geom_text(aes(y=as.numeric(Unique_Elements), label=as.numeric(Unique_Elements), vjust=0.0,  size=4.0, fontface="bold")) +
  labs(title="Ciudad de Origen distinta- Tomado de la Muestra") +
  xlab(label="Año")+
  theme_minimal()  +
  theme(text = element_text(family = "Palatino"),
        plot.title = element_text(size=16),
        plot.subtitle = element_text(size=13),
        axis.title= element_text(size=11),
        plot.caption = element_text(size=11),
        axis.text.y= element_text(size=10, color="black", face="bold"),
        axis.text.x= element_text(size=10, color="black", face="bold"))

#Numero de ciudades de Destino por año
Destino_ano$Frecuencia_Relativa <- prop.table(Destino_ano$Unique_Elements)
Destino_ano$Frecuencia_Acumulada <- cumsum(Destino_ano$Unique_Elements)
Destino_ano$Frecuencia_Relativa_Acumulada <- cumsum(Destino_ano$Frecuencia_Relativa)
Destino_ano
hist(Altura$Altura)

ggplot(Destino_ano, aes(x=Year, y=Unique_Elements)) + geom_bar(stat = "identity")+
  geom_text(aes(y=as.numeric(Unique_Elements), label=as.numeric(Unique_Elements), vjust=0.0,  size=4.0, fontface="bold")) +
  labs(title="Ciudad de Destino distinta- Tomado de la Muestra") +
  xlab(label="Año")+
  theme_minimal()  +
  theme(text = element_text(family = "Palatino"),
        plot.title = element_text(size=16),
        plot.subtitle = element_text(size=13),
        axis.title= element_text(size=11),
        plot.caption = element_text(size=11),
        axis.text.y= element_text(size=10, color="black", face="bold"),
        axis.text.x= element_text(size=10, color="black", face="bold"))

#################################Punto 2 Ejercicio 2 & 3- Tomado de la Muestra ##################################
cant_ano   <-data.frame(muestra_total%>% group_by(Year) %>% dplyr::summarize(Cantidad_Vuelos = n()))
cant_mes  <-data.frame(muestra_total%>%  group_by(Month) %>% dplyr::summarize(Cantidad_Vuelos = n()))
cant_origen <-data.frame(muestra_total%>% group_by(Origin) %>% dplyr::summarize(Cantidad_Vuelos = n()))
cant_destino <-data.frame(muestra_total%>% group_by(Dest) %>% dplyr::summarize(Cantidad_Vuelos = n()))

#Cantidad de vuelos por año
ggplot(cant_ano, aes(x=Year, y=Cantidad_Vuelos)) + geom_bar(stat = "identity", color="blue", group=1, fill="red")+
  geom_text(aes(y=as.numeric(Cantidad_Vuelos), label=prettyNum(round(Cantidad_Vuelos,digits=0),big.mark = ","), vjust=0.0,  size=4.0, fontface="bold"))+
  labs(title="Cantidad de Vuelos por Año- Tomado de la Muestra")

#Cantidad de vuelos por mes
cant_mes$Month <- as.numeric(cant_mes$Month)
mesi_order <- order(cant_mes$Month)
cant_mes <- cant_mes[mesi_order, ]
ggplot(cant_mes, aes(x=factor(Month), y=Cantidad_Vuelos)) + geom_bar(stat = "identity", color="red", group=1, fill="pink")+
  geom_text(aes(y=as.numeric(Cantidad_Vuelos), label=prettyNum(round(Cantidad_Vuelos,digits=0),big.mark = ",")), vjust=0.0,  size=4.0, fontface="bold")+
  labs(title="Cantidad de Vuelos por Mes- Tomado de la Muestra")

#Cantidad  de vuelos por destino Top 6
sumatoria<- order(cant_destino$Cantidad_Vuelos)
cant_destino <- cant_destino[sumatoria, ]
cant_destino <- tail(cant_destino)
cant_destino
ggplot(cant_destino, aes(x=factor(Dest), y=Cantidad_Vuelos)) +
  geom_bar(stat = "identity", color="black", group=1, fill="orange")+
  geom_text(aes(y=as.numeric(Cantidad_Vuelos), label=prettyNum(round(Cantidad_Vuelos,digits=0),big.mark = ",")), vjust=0.0,  size=4.0, fontface="bold")+
  labs(title="Cantidad de Vuelos por Destino (Top 6)- Tomado de la Muestra")+
  coord_flip()

#Cantidad  de vuelos por Origen Top 6
sumatoria<- order(cant_origen$Cantidad_Vuelos)
cant_origen <- cant_origen[sumatoria, ]
cant_origen <- tail(cant_origen)
cant_origen
ggplot(cant_origen, aes(x=factor(Origin), y=Cantidad_Vuelos)) +
  geom_bar(stat = "identity", color="orange", group=1, fill="purple")+
  geom_text(aes(y=as.numeric(Cantidad_Vuelos), label=prettyNum(round(Cantidad_Vuelos,digits=0),big.mark = ",")), vjust=0.0,  size=4.0, fontface="bold")+
  labs(title="Cantidad de Vuelos por Origen (Top 6) Tomado de la Muestra")+
  coord_flip()

###########################Punto 2 Ejercicio 4- Tomado de la Muestra###################################
#En que aeropuertos ocurren los mayores retrasos en el despegue
muestra_total$DepDelay[muestra_total$DepDelay == "NA"] <- "0"
datos.delay <- subset(muestra_total, as.numeric(DepDelay)>0)
# se buscan los Vuelos que se retrasarion (con el depdelay mayor a 1)

#Viendo la suma del del delay de cada aeropuerto Historico  a ver que aeropuerto historicamente tiene el mayor (de los que tienen un delay mayor a 0)
Aviones_Delay <-data.frame(datos.delay%>%  filter(!is.na(DepDelay)) %>%group_by(Origin) %>% dplyr::summarize(Suma_Retrasos = sum(as.numeric(DepDelay), na.rm=TRUE))
                           %>% arrange(desc(Suma_Retrasos)))

#Si se filtra esta tabla por ano se puede ver cual tiene el delay promedio por ano mas grande
Aviones_ano  <-data.frame(datos.delay%>%  filter(!is.na(DepDelay)) %>%group_by(Year, Origin) %>% dplyr::summarize(Retraso = sum(as.numeric(DepDelay), na.rm=TRUE))
                          %>% arrange(desc(Retraso)))

#5 Aerolineas cada ano
Aerolineas_1990 <- data.frame(Aviones_ano%>% filter(Year ==1990))
Aerolineas_2000 <- data.frame(Aviones_ano%>% filter(Year ==2000))
Aerolineas_2005 <- data.frame(Aviones_ano%>% filter(Year ==2005))
Aerolineas_2008 <- data.frame(Aviones_ano%>% filter(Year ==2008))

Aerolineas_1990_h <- head(Aerolineas_1990)
Aerolineas_2000_h <-head(Aerolineas_2000)
Aerolineas_2005_h <-head(Aerolineas_2005)
Aerolineas_2008_h <-head(Aerolineas_2008)

Aerolineas_mas_retrasadas <- rbind(Aerolineas_1990_h, Aerolineas_2000_h,Aerolineas_2005_h,Aerolineas_2008_h)
Aerolineas_mas_retrasadas
Aerolineas_mas_retrasadas$Horas <- Aerolineas_mas_retrasadas$Retraso/60000

#Grafico del Top 6 de Aerolineas mas retrasadas en el despegue
ggplot(data=Aerolineas_mas_retrasadas, aes(x=factor(Year), y=Horas, fill=factor(Origin))) +
  geom_bar(stat="identity", width=0.91, position=position_dodge()) +
  geom_text(aes(y=Horas,label=prettyNum(round(Horas,digits=0),big.mark = ",")),  vjust=0.0, color="gray18", size=4.0, fontface="bold", position=position_dodge(0.9)) +
  labs(title="Top 6 de los Aeropuertos  más retrasados en el Despegue", subtitle="Por año- Tomado de la Muestra") +
  xlab(label="Año")+
  labs(caption="Los datos originalmente vienen en minutos, se transformaron a miles de horas", fill="Aeropuerto\nde Origen")+
  ylab(label="Retraso en Miles de Horas") +
  theme(plot.title = element_text(size=16),
        plot.subtitle = element_text(size=13),
        axis.title= element_text(size=11),
        plot.caption = element_text(size=11),
        axis.text.y= element_text(size=10, color="black", face="bold"),
        axis.text.x= element_text(size=10, color="black", face="bold"))

#Parte 2- Replica Documento proyecto_final_2.0 pero con la muestra
#########Punto 2 Ejercicio 5- Tomado de la Muestra #######################
#Numero 4 del punto 1, En que Dia de la semana ocurren la menor cantidad de retrasos en el aterrizaje
muestra_total$ArrDelay[muestra_total$ArrDelay == "NA"] <- "0"
datos.arrdelay <- subset(muestra_total, as.numeric(ArrDelay)>0) #Vuelos que se retrasaron

Delay_llegada_dia  <-data.frame(datos.arrdelay%>%  filter(!is.na(ArrDelay)) %>%group_by(Year,DayOfWeek) %>% dplyr::summarize(Cantidad_Vuelos = n()))

ggplot(Delay_llegada_dia, aes(x=DayOfWeek,y=as.numeric(Cantidad_Vuelos), group=Year))+
  geom_line(aes(color=Year)) +
  labs(title="Cantidad de Vuelos retrasados en el Aterrizaje por Dia", subtitle="Patron anual- Tomado de la Muestra")

#############Punto 2 Ejercicio 6- Tomado de la Muestra-###################
#Ncuales horario ocurren los mayores retrasos en el despegue (Suma de retrasos agrupado por mes y hora)
muestra_total$DepDelay[muestra_total$DepDelay == "NA"] <- "0"
describe(muestra_total$DepDelay)
horas.delay <- subset(muestra_total, as.numeric(DepDelay)>0) #Que tengan retrasos en el despegue

#Sacando los horarios mas ocupados
horas.delay$Hour <- paste(strrep("0",(4-nchar(horas.delay$CRSDepTime))),horas.delay$CRSDepTime , sep='')
horas.delay$Hour_2 <- substring(horas.delay$Hour, 1, 2)

datos.Delay_hora <-data.frame(horas.delay %>%group_by(Month, Hour_2) %>% dplyr::summarize(Suma_Retrasos = sum(as.numeric(DepDelay), na.rm=TRUE))
                              %>% arrange(desc(Suma_Retrasos)))
ggplot(datos.Delay_hora, aes(x=Hour_2,y=as.numeric(Suma_Retrasos), group=Month))+
  geom_line(aes(color=Month)) +
  labs(title="Mayores retrasos en el Despegue por Hora Tomado de la Muestra", subtitle="Patron mensual")

#############Punto 2 Ejercicio 7- Tomado de la Muestra#################
#Numero 7 del punto, En cuales meses ocurren los mayores retrasos
muestra_total$DepDelay[muestra_total$DepDelay == "NA"] <- "0"
describe(muestra_total$DepDelay)
meses.delay <- subset(muestra_total, as.numeric(DepDelay)>0)
describe(datos.delay$DepDelay) #Vuelos que se retrasarion (con el depdelay mayor a 1)

mes_Delay <-data.frame(meses.delay%>%  filter(!is.na(DepDelay)) %>%group_by(Year, Month) %>% dplyr::summarize(Suma_Retrasos = sum(as.numeric(DepDelay), na.rm=TRUE))
                       %>% arrange(desc(Suma_Retrasos), .by_group= TRUE))
mes_Delay$Month <- as.numeric(mes_Delay$Month)
meses <- order(mes_Delay$Month)
mes_Delay[meses, ]
ggplot(mes_Delay, aes(x=as.factor(Month),y=as.numeric(Suma_Retrasos), group=Year))+
  geom_line(aes(color=Year)) +
  labs(title="Mayores retrasos en el Despegue por Mes- Tomado de la Muestra", subtitle="Patron anual")

################Punto 2 Ejercicio 8- Tomado de la Muestra###############
#Dentro de los meses con mas retrasos ver los dias que tienen mas retraso
mes_Delay_2 <-data.frame(meses.delay%>%  filter(!is.na(DepDelay)) %>%group_by(Month) %>% dplyr::summarize(Suma_Retrasos = sum(as.numeric(DepDelay), na.rm=TRUE))
                         %>% arrange(desc(Suma_Retrasos)))
#Los 5 meses con mas retraso- diciembre, julio, junio, agosto, marzo
#Descartar el 1990
meses_Delay_2 <-data.frame(meses.delay %>% filter(Month %in% c("12", "7","6", "8", "3")))
mesi_Delay_2 <-data.frame(meses_Delay_2%>%  filter(!is.na(DepDelay)) %>%group_by(Month, DayofMonth) %>% dplyr::summarize(Suma_Retrasos = sum(as.numeric(DepDelay), na.rm=TRUE))
                          %>% arrange(desc(Suma_Retrasos)))

mesi_Delay_2$DayofMonth <- as.numeric(mesi_Delay_2$DayofMonth)
dias <- order(mesi_Delay_2$DayofMonth)
mesi_Delay_2[dias, ]

ggplot(mesi_Delay_2, aes(x=as.factor(DayofMonth),y=as.numeric(Suma_Retrasos), group=Month))+
  geom_line(aes(color=Month)) +
  labs(title="Mayores retrasos en el Despegue por dia del mes\nEn los meses con mayor retraso", subtitle="Patron anual")

################Punto 2 Ejercicio 9.1- Tomado de la Muestra#####################
#Trabajando con los cancelados, de los meses mas retrasados tambien cuales son los dias con mayor retraso
cancelados <-data.frame(muestra_total %>% filter(Cancelled == 1))
meses_cancelados <-data.frame(cancelados %>% filter(Month %in% c("12", "7","6", "8", "3")))
meses_cancelados_2 <-data.frame(meses_cancelados %>% group_by(DayofMonth, CancellationCode) %>% dplyr::summarize(Cantidad_Cancelacion = n(), na.rm=TRUE))

meses_cancelados_2$DayofMonth <- as.numeric(meses_cancelados_2$DayofMonth)
dias_c <- order(meses_cancelados_2$DayofMonth)
meses_cancelados_2[dias_c, ]

ggplot(meses_cancelados_2, aes(x=as.factor(DayofMonth),y=as.numeric(Cantidad_Cancelacion), group=CancellationCode))+
  geom_line(aes(color=CancellationCode)) +
  labs(title="Cantidad de Cancelaciones por dia\nEn los meses con mayor retraso", subtitle="Patron Codigo Cancelacion- Tomado de la Muestra")

#############Punto 2 Ejercicio 9.2- Tomado de la Muestra####################
#Haciendolo por tipo de cancelacion

patron_cancelaciones <-data.frame(muestra_total %>% group_by(Year,Month, Cancelled,CancellationCode) %>% dplyr::summarize(Cantidad_Cancelacion = n(), na.rm=TRUE))
head(patron_cancelaciones)
cancelados_66 <-data.frame(patron_cancelaciones %>% filter(Cancelled == 1))

cancelados_66$Month <- as.numeric(cancelados_66$Month)
cancelados_order <- order(cancelados_66$Month)
cancelados_66[cancelados_order, ]

#En el Año 1990 por tipo de cancelacion
cancelados_1990 <-data.frame(cancelados_66%>% filter(Year ==1990))
ggplot(cancelados_1990, aes(x=as.factor(Month),y=as.numeric(Cantidad_Cancelacion), group=CancellationCode))+
  geom_line(aes(color=CancellationCode)) +
  labs(title="Cantidad de Cancelaciones por mes\nEn los meses  en el Año 1990", subtitle="Patron Codigo Cancelacion- Tomado de la Muestra")

#En el Año 1990 por tipo de cancelacion
cancelados_2000 <-data.frame(cancelados_66%>% filter(Year ==2000))
ggplot(cancelados_2000, aes(x=as.factor(Month),y=as.numeric(Cantidad_Cancelacion), group=CancellationCode))+
  geom_line(aes(color=CancellationCode)) +
  labs(title="Cantidad de Cancelaciones por mes\nEn los meses en el Año 2000", subtitle="Patron Codigo Cancelacion- Tomado de la Muestra")

#En el año 2005 por tipo de cancelacion
cancelados_2005 <-data.frame(cancelados_66%>% filter(Year ==2005))
ggplot(cancelados_2005, aes(x=as.factor(Month),y=as.numeric(Cantidad_Cancelacion), group=CancellationCode))+
  geom_line(aes(color=CancellationCode)) +
  labs(title="Cantidad de Cancelaciones por mes\nEn los meses en el Año 2005", subtitle="Patron Codigo Cancelacion- Tomado de la Muestra")

#En el año 2008 por tipo de cancelacion
cancelados_2008 <-data.frame(cancelados_66%>% filter(Year ==2008))
ggplot(cancelados_2008, aes(x=as.factor(Month),y=as.numeric(Cantidad_Cancelacion), group=CancellationCode))+
  geom_line(aes(color=CancellationCode)) +
  labs(title="Cantidad de Cancelaciones por mes\nEn los meses en el Año 2008", subtitle="Patron Codigo Cancelacion- Tomado de la Muestra")


#!/usr/local/bin/Rexec
########### set arguments list ####################
args<-commandArgs();
args_start=grep("--args",args)+1;
args<-args[args_start:length(args)];
###################################################

###################################################
## utility functions ##############################
###################################################

# plot error bars
error.bar <- function(x, y, upper, lower=upper, length=0.1,...)
{
    if( length(x) != length(y) |
       length(y) !=length(lower) |
       length(lower) != length(upper) )
    {
        stop("vectors must be same length");
    }
    arrows( x, y+upper,
           x, y-lower,
           angle=90, code=0,
           length=length, ...);

}

##R equivalent of repmat (matlab)
repmat = function(X,m,n){
    if(is.vector(X)) {
        X=t(as.matrix(X));
    }
    mx = dim(X)[1]
    nx = dim(X)[2]
    matrix(t(matrix(X,mx,nx*n)),mx*m,nx*n,byrow=T)
}

## rewriting as sparse matrix (x,y,v)
sparse = function(M) {
    rows=dim(M)[1];
    cols=dim(M)[2];

    x=cbind(ceiling(1:length(M)/cols),
            ((1:length(M))-1)%%cols+1,
            matrix(t(M),length(M),1) );
    colnames(x)=c('row','col','val')
    x[x[,3]!=0 & !is.nan(x[,3]),]
}

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

# clear graphics
graphics.off();

#load data
d<-read.table('data_all');

#set variables' names
colnames(d)=c( 'expname',
              'varnum',
              'index',
              'seed',
              'r2',
              'decay1',
              'decay2',
              'k',
              'gpp',
              'gnp',
              'gpn',
              'gnn',
              'eps',
              'esp',
              'ens',
              'esn');

# reset data as data.frame;
d=data.frame(d);

#range to find minima in each varnum group
epsilon=1e-2;

for(en in levels(d$expname)) {

    print("# experiment name: ####");
    print(en);
    print("#######################");

    ################################################
    # select data corresponding to an experiment
    tmpd=d[d$expname==en,];
    attach(tmpd);
    ################################################

    ################################################
    ### DEFINE DATA STRUCTURE ######################
    #find the minimum in varnum-x-index groups
    minima = as.matrix((t(tapply(r2,list(varnum,index),min))));
    #find the minimum in varnum groups
    column_minima = apply(minima,2,function(x){ min(x,na.rm=TRUE) })
    #find the minima in the column-minimum<->epsilon range in each column
    minima_range = minima*(minima<(repmat(column_minima,dim(minima)[1],1)+epsilon))
    #exclude 0-values from future computation
    minima_range[minima_range==0]=NA
    # write as sparse matrix
    minima_range=sparse(minima_range);
    # x,y,v names in the sprse matrix
    colnames(minima_range)=c('index','varnum','r2');
    # as a data.frame
    minima_range=data.frame(minima_range);
    # definitively exclude NA values
    minima_range=minima_range[!is.na(minima_range$r2),]
    # add seed column
    for(x in 1:dim(minima_range)[1]) {
        minima_range$seed[x]= seed[( (varnum==minima_range$varnum[x])&(index==minima_range$index[x])&r2==minima_range$r2[x])];
    }
    ################################################
    attach(minima_range);

    #collect means of minima<->epsilon of varnum groups
    means=as.matrix(t(tapply(r2,list(varnum),mean)));

    #find the index of minima in minima_range dataframe
    minsn=as.matrix(t(tapply(r2,list(varnum),function(x) { which(r2==min(x))[1] })));

    minvarnums=1:8;
    #find the  index of minima in the absolute dataframe
    minindices=index[minsn];
    #find the seed of minima in the absolute dataframe
    minseeds=seed[minsn];
    #find the r of minima in the absolute dataframe
    minr2s=r2[minsn];

    #find the absolute minimum
    minn = which(r2==min(r2))[1];
    #find the index of the absolute minimum
    minindex  = index[minn];
    #find the varnum of the absolute minimum
    minvarnum = varnum[minn];
    #find the seed  of the absolute minimum
    minseed = seed[minn];
    #find the r of the absolute minimum
    minr2=r2[minn];

    detach(minima_range);

    resname= paste('sample-',en,sep='');

    # write the absolute minimum
    data=c( 1, minvarnum[1],minindex[1],minseed[1], minr2[1] );
    write(data,append=FALSE,file=resname);

    # write the minima of the other varnum
    for(x in minvarnums[minvarnums!=minvarnum]) {
        data=(c( 2, minvarnums[x],minindices[x],minseeds[x],minr2s[x]));
        write(data,append=TRUE,file=resname);
        print(data);
    }
    # write all minima<->epsilon
    for(x in 1:length(minima_range$index)) {
        data=(c( 3, minima_range$varnum[x], minima_range$index[x], minima_range$seed[x],minima_range$r2[x]));
        write(data,append=TRUE,file=resname);
        print(data);
    }

    detach(tmpd);

}


#==============================================================================
#	Test for gam in mgcv package.
#==============================================================================

source("tests.r")
test <- glm.type.test.runner$new(
	"gam", package = "mgcv",
	families = c(
		"gaussian", "Gamma", "inverse.gaussian", "poisson", "binomial"
	)
)
test$run()
rm(test)


#!/usr/bin/env Rscript

args <- commandArgs(TRUE)

filename   <- args[1]          # data matrix file name
ofilename  <- args[2]          # output file name: normalized
factorname <- args[3]          # output file name: factor size

#options(digits=3)

##### if use deseq2, counts(dds, normalized=T)

library(DESeq)

data <- read.delim(filename, header=TRUE, row.names=1, check.names=FALSE)
conds <- factor( c(1:ncol(data)))

cds <- newCountDataSet(data, conds)
cds <- estimateSizeFactors(cds)
pData(cds)
normalizedCounts <- as.data.frame( t( t(counts(cds)) / sizeFactors(cds) ) )

write.table(normalizedCounts, ofilename, sep="\t", quote=FALSE, col.names=NA)
write.table(pData(cds), factorname, sep="\t", quote=FALSE, col.names=NA)

sessionInfo()


#spatial forecast variance decomposition: fungal functional groups.
#clear envrionment, source paths, packages and functions.
rm(list=ls())
source('paths.r')
source('NEFI_functions/dmulti_ddirch_forecast.r')

#set output paths.----
output.path <- NEON_dmulti.ddirch_var.decomposition_fg.path

#load model results.----
#mod 1 is data from maps.
#mod 2 is site-specific data, no maps.
#mod 3 is all covariates.
mod <- readRDS(ted_ITS.prior_dmulti.ddirch_fg_JAGSfit)
mod <- mod[[3]] #just the all predictor case.

#get core-level covariate means and sd.----
dat <- readRDS(hierarch_filled.path)
core_mu <- dat$core.core.mu
plot_mu <- dat$plot.plot.mu
site_mu <- dat$site.site.mu
#merge together.
plot_mu$siteID <- NULL
core.preds <- merge(core_mu   , plot_mu)
core.preds <- merge(core.preds, site_mu)
core.preds$relEM <- NULL
names(core.preds)[names(core.preds)=="b.relEM"] <- "relEM"

#get core-level SD.
core_sd <- dat$core.core.sd
plot_sd <- dat$plot.plot.sd
site_sd <- dat$site.site.sd
#merge together.
plot_sd$siteID <- NULL
core.sd <- merge(core_sd   , plot_sd)
core.sd <- merge(core.sd, site_sd)
core.sd$relEM <- NULL
names(core.sd)[names(core.sd)=="b.relEM"] <- "relEM"

#take median value core means and sd.
core_median_mu <- list()
core_median_sd <- list()
for(i in 1:ncol(core.preds)){
  if(is.numeric(core.preds[,i])){
    core_median_mu[[i]] <- median(core.preds[,i])
    core_median_sd[[i]] <- median(core.sd   [,i])
    names(core_median_mu)[[i]] <- colnames(core.preds)[i]
    names(core_median_sd)[[i]] <- colnames(core.sd   )[i]
  }
}
core_median_mu <- data.frame(t(unlist(core_median_mu)))
core_median_sd <- data.frame(t(unlist(core_median_sd)))

#get plot-level covariate means and sd.----
core_mu <- dat$core.plot.mu
plot_mu <- dat$plot.plot.mu
site_mu <- dat$site.site.mu
#merge together, .
plot_mu$siteID <- NULL
plot.preds <- merge(core_mu,plot_mu)
plot.preds <- merge(plot.preds,site_mu)
plot.preds$relEM <- NULL
names(plot.preds)[names(plot.preds)=="b.relEM"] <- "relEM"

#get plot-level SD.
core_sd <- dat$core.plot.sd
plot_sd <- dat$plot.plot.sd
site_sd <- dat$site.site.sd
#merge together
plot_sd$siteID <- NULL
plot.sd <- merge(core_sd,plot_sd)
plot.sd <- merge(plot.sd,site_sd)
plot.sd$relEM <- NULL
names(plot.sd)[names(plot.sd)=='b.relEM'] <- "relEM"

#take median value core means and sd.
plot_median_mu <- list()
plot_median_sd <- list()
for(i in 1:ncol(plot.preds)){
  if(is.numeric(plot.preds[,i])){
    plot_median_mu[[i]] <- median(plot.preds[,i])
    plot_median_sd[[i]] <- median(plot.sd   [,i])
    names(plot_median_mu)[[i]] <- colnames(plot.preds)[i]
    names(plot_median_sd)[[i]] <- colnames(plot.sd   )[i]
  }
}
plot_median_mu <- data.frame(t(unlist(plot_median_mu)))
plot_median_sd <- data.frame(t(unlist(plot_median_sd)))

#get site-level covariate means and sd.----
core_mu <- dat$core.site.mu
plot_mu <- dat$plot.site.mu
site_mu <- dat$site.site.mu
#merge together
site.preds <- merge(core_mu, plot_mu)
site.preds <- merge(site.preds,site_mu)
names(site.preds)[names(site.preds)=='b.relEM'] <- "relEM"

#get site-level SD.
core_sd <- dat$core.site.sd
plot_sd <- dat$plot.site.sd
site_sd <- dat$site.site.sd
#merge together.
site.sd <- merge(core_sd,plot_sd)
site.sd <- merge(site.sd,site_sd)
names(site.sd)[names(site.sd)=='b.relEM'] <- "relEM"

#take median value core means and sd.
site_median_mu <- list()
site_median_sd <- list()
for(i in 1:ncol(site.preds)){
  if(is.numeric(site.preds[,i])){
    site_median_mu[[i]] <- median(site.preds[,i])
    site_median_sd[[i]] <- median(site.sd   [,i])
    names(site_median_mu)[[i]] <- colnames(site.preds)[i]
    names(site_median_sd)[[i]] <- colnames(site.sd   )[i]
  }
}
site_median_mu <- data.frame(t(unlist(site_median_mu)))
site_median_sd <- data.frame(t(unlist(site_median_sd)))

#core-scale variance decomposition.----
core_ref <- dmulti_ddirch_forecast(mod = mod, cov_mu = core_median_mu, cov_sd = core_median_sd, names = 'core_scale')
core_cov <- dmulti_ddirch_forecast(mod = mod, cov_mu = core_median_mu, cov_sd = core_median_sd, names = 'core_scale', zero_process_uncertainty = T, zero_parameter_uncertainty = T)
core_par <- dmulti_ddirch_forecast(mod = mod, cov_mu = core_median_mu, cov_sd = core_median_sd, names = 'core_scale', zero_process_uncertainty = T, zero_covariate_uncertainty = T)
core_pro <- dmulti_ddirch_forecast(mod = mod, cov_mu = core_median_mu, cov_sd = core_median_sd, names = 'core_scale', zero_parameter_uncertainty = T, zero_covariate_uncertainty = T)
core_cov.par <- dmulti_ddirch_forecast(mod = mod, cov_mu = core_median_mu, cov_sd = core_median_sd, names = 'core_scale', zero_process_uncertainty = T)
core_cov.pro <- dmulti_ddirch_forecast(mod = mod, cov_mu = core_median_mu, cov_sd = core_median_sd, names = 'core_scale', zero_parameter_uncertainty = T)
core_par.pro <- dmulti_ddirch_forecast(mod = mod, cov_mu = core_median_mu, cov_sd = core_median_sd, names = 'core_scale', zero_covariate_uncertainty = T)
core_list <- list(core_ref, core_cov, core_par, core_pro, core_cov.par, core_cov.pro, core_par.pro)
decomp_names <- c('All','covariate','parameter','process','covariate + parameter','covariate + process','parameter + process')
core.decomp.list <- list()
for(i in 1:length(core_list)){
  core.decomp.list[[i]] <- core_list[[i]]$pi_0.975 - core_list[[i]]$pi_0.025
}
core.decomp.list <- do.call(rbind, core.decomp.list)
rownames(core.decomp.list) <- decomp_names
core_variance_decomp <- sweep(core.decomp.list,2, core.decomp.list[1,],'/')

#plot-scale variance decomposition.----
plot_ref <- dmulti_ddirch_forecast(mod = mod, cov_mu = plot_median_mu, cov_sd = plot_median_sd, names = 'plot_scale')
plot_cov <- dmulti_ddirch_forecast(mod = mod, cov_mu = plot_median_mu, cov_sd = plot_median_sd, names = 'plot_scale', zero_process_uncertainty = T, zero_parameter_uncertainty = T)
plot_par <- dmulti_ddirch_forecast(mod = mod, cov_mu = plot_median_mu, cov_sd = plot_median_sd, names = 'plot_scale', zero_process_uncertainty = T, zero_covariate_uncertainty = T)
plot_pro <- dmulti_ddirch_forecast(mod = mod, cov_mu = plot_median_mu, cov_sd = plot_median_sd, names = 'plot_scale', zero_parameter_uncertainty = T, zero_covariate_uncertainty = T)
plot_cov.par <- dmulti_ddirch_forecast(mod = mod, cov_mu = plot_median_mu, cov_sd = plot_median_sd, names = 'plot_scale', zero_process_uncertainty = T)
plot_cov.pro <- dmulti_ddirch_forecast(mod = mod, cov_mu = plot_median_mu, cov_sd = plot_median_sd, names = 'plot_scale', zero_parameter_uncertainty = T)
plot_par.pro <- dmulti_ddirch_forecast(mod = mod, cov_mu = plot_median_mu, cov_sd = plot_median_sd, names = 'plot_scale', zero_covariate_uncertainty = T)
plot_list <- list(plot_ref, plot_cov, plot_par, plot_pro, plot_cov.par, plot_cov.pro, plot_par.pro)
decomp_names <- c('All','covariate','parameter','process','covariate + parameter','covariate + process','parameter + process')
plot.decomp.list <- list()
for(i in 1:length(plot_list)){
  plot.decomp.list[[i]] <- plot_list[[i]]$pi_0.975 - plot_list[[i]]$pi_0.025
}
plot.decomp.list <- do.call(rbind, plot.decomp.list)
rownames(plot.decomp.list) <- decomp_names
plot_variance_decomp <- sweep(plot.decomp.list,2, plot.decomp.list[1,],'/')

#site-scale variance decomposition.----
site_ref <- dmulti_ddirch_forecast(mod = mod, cov_mu = site_median_mu, cov_sd = site_median_sd, names = 'site_scale')
site_cov <- dmulti_ddirch_forecast(mod = mod, cov_mu = site_median_mu, cov_sd = site_median_sd, names = 'site_scale', zero_process_uncertainty = T, zero_parameter_uncertainty = T)
site_par <- dmulti_ddirch_forecast(mod = mod, cov_mu = site_median_mu, cov_sd = site_median_sd, names = 'site_scale', zero_process_uncertainty = T, zero_covariate_uncertainty = T)
site_pro <- dmulti_ddirch_forecast(mod = mod, cov_mu = site_median_mu, cov_sd = site_median_sd, names = 'site_scale', zero_parameter_uncertainty = T, zero_covariate_uncertainty = T)
site_cov.par <- dmulti_ddirch_forecast(mod = mod, cov_mu = site_median_mu, cov_sd = site_median_sd, names = 'site_scale', zero_process_uncertainty = T)
site_cov.pro <- dmulti_ddirch_forecast(mod = mod, cov_mu = site_median_mu, cov_sd = site_median_sd, names = 'site_scale', zero_parameter_uncertainty = T)
site_par.pro <- dmulti_ddirch_forecast(mod = mod, cov_mu = site_median_mu, cov_sd = site_median_sd, names = 'site_scale', zero_covariate_uncertainty = T)
site_list <- list(site_ref, site_cov, site_par, site_pro, site_cov.par, site_cov.pro, site_par.pro)
decomp_names <- c('All','covariate','parameter','process','covariate + parameter','covariate + process','parameter + process')
site.decomp.list <- list()
for(i in 1:length(site_list)){
  site.decomp.list[[i]] <- site_list[[i]]$pi_0.975 - site_list[[i]]$pi_0.025
}
site.decomp.list <- do.call(rbind, site.decomp.list)
rownames(site.decomp.list) <- decomp_names
site_variance_decomp <- sweep(site.decomp.list,2, site.decomp.list[1,],'/')

#wrap output and save.----
output <- list(core_variance_decomp, plot_variance_decomp, site_variance_decomp)
names(output) <- c('core_decomp','plot_decomp','site_decomp')
saveRDS(output,output.path)

#end script.


# --------------------------
#  App Title: Longest Run
#     Author: Jimmy Doi
# --------------------------

library(shiny)
source("Coin_Flips_Runs.R")

options(shiny.error=browser)

shinyServer(function(input, output) {

  dataInput <- reactive({
    flip.gen(input$trials*(input$save>-1),input$H.prob)
    })

  # Fill in the spot we created for a plot
  output$coinPlot <- renderPlot({

    plot.flips(input$minrun,dataInput(),input$my.cex,input$checkbox)

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

    })

})


library(ape)

tr <- read.tree("njtree.nwk")

len <- median(tr$edge.length)

if (len < 0.1) {
    len <- floor(len*100)/100
} else if (len < 1) {
    len <- floor(len*10)/10
} else {
    len <- floor(len)
}

print(len)

# tr$tip.label
# tr <- root(tr, "Struthioniformes")

tiff("tree.tif", width=8, height=8, units="cm", pointsize=10, res=300, compression="lzw")

par(lend=2)

plot(tr, type="un", show.tip.label=FALSE, no.margin=TRUE)

add.scale.bar(length=len)

dev.off()


library(devtools)
devtools::load_all()

library(parallel)
RNGkind("L'Ecuyer-CMRG")
set.seed(999983)

# para setup
s_q <- 2L
ncores <- 1
s_n <- 128L
s_k <- 32L

cv_prin <- princurve_simulation(ncores, s_n, s_k, s_q,
                maxit = 1e2, thresh = 1e-5,
                s_range = 10)

save(cv_prin, file = "cv_prin.RData")


source("penGAMfuns.r")
source("NISfuns.r")

install.packages(c("zoo", "fda", "grplasso","mgcv"))

library(zoo)
library(fda)
library(grplasso)
library(mgcv)

funind = 6      ###simulation setting, see NISfuns.r for details.

fit = simuNIS(funind = funind)