make_hsd = function(expr, score){
  function(x) score[unlist(lapply(expr, eval, envir = environment()))]
}

classify_ta = function(ta){
  ta.windows = list(
    "optimal growth" = expression(x >= 14 & x <= 18),
    "positive growth" = expression(x < 14 | (x >= 18 & x <= 21)),
    "negative/no growth" = expression(x > 21 & x <= 25),
    "unsuitable" = expression(x > 25)
  )
  ta_hsd = make_hsd(ta.windows, names(ta.windows))
  factor(sapply(ta, ta_hsd), levels = names(ta.windows))
}

classify_sa = function(sa){
  sa.windows = list(
    "freshwater" = expression(x < 10),
    "isotonic" = expression(x >= 10 & x <= 15),
    "brackish" = expression(x > 15 & x <= 28),
    "marine" = expression(x > 28)
  )
  sa_hsd = make_hsd(sa.windows, names(sa.windows))
  factor(sapply(sa, sa_hsd), levels = names(sa.windows))
}

classify_oa = function(oa){
  oa.windows = list(
    "minimal impairment" = expression(x >= 6),
    "some impairment" = expression(x >= 4 & x < 6),
    "severe impairment" = expression(x >= 3 & x < 4),
    "unsuitable" = expression(x < 3)
  )
  oa_hsd = make_hsd(oa.windows, names(oa.windows))
  factor(sapply(oa, oa_hsd), levels = names(oa.windows))
}

classify_freshwater = function(ta, sa, oa){
  hab_cat = function(xs){
    if(all(xs %in% c("optimal growth", "positive growth", "minimal impairment",
      "isotonic", "freshwater")))
      return("optimal")
    if(all(xs %in% c("negative/no growth", "minimal impairment", "freshwater",
      "isotonic")))
      return("growth limited")
    if(all(xs %in% c("optimal growth", "positive growth", "some impairment",
      "severe impairment", "isotonic", "freshwater")))
      return("impaired")
    if(all(xs %in% c("optimal growth", "positive growth", "minimal impairment",
      "brackish")))
      return("energy demanding")
    if(all(xs %in% c("negative/no growth", "some impairment",
      "severe impairment", "isotonic", "freshwater")))
      return("growth limited, impaired")
    if(all(xs %in% c("negative/no growth", "minimal impairment", "brackish")))
      return("growth limited, energy demanding")
    if(all(xs %in% c("optimal growth", "positive growth", "some impairment",
      "severe impairment", "brackish")))
      return("impaired, energy demanding")
    if(all(xs %in% c("negative/no growth", "some impairment",
      "severe impairment", "brackish")))
      return("growth limited, impaired, energy demanding")
    if(any(xs %in% c("unsuitable", "marine")))
      return("unsuitable")
    stop("no category for ", paste(c("ta", "oa", "sa"), xs, sep = " = ",
      collapse = ", "))
  }
  factor(apply(data.frame(ta, oa, sa), 1, hab_cat),
    levels = c("optimal", "growth limited", "impaired", "energy demanding",
      "growth limited, impaired", "growth limited, energy demanding",
      "impaired, energy demanding",
      "growth limited, impaired, energy demanding",
      "unsuitable"))
}

classify_saltwater = function(ta, oa, sa){
  hab_cat = function(xs){
    if(all(xs %in% c("optimal growth", "positive growth", "minimal impairment",
      "isotonic", "brackish", "freshwater")))
      return("optimal")
    if(all(xs %in% c("negative/no growth", "minimal impairment", "freshwater",
      "brackish", "isotonic")))
      return("growth limited")
    if(all(xs %in% c("optimal growth", "positive growth", "some impairment",
      "severe impairment", "isotonic", "freshwater", "brackish")))
      return("impaired")
    if(all(xs %in% c("optimal growth", "positive growth", "minimal impairment",
      "marine")))
      return("energy demanding")
    if(all(xs %in% c("negative/no growth", "some impairment",
    "severe impairment", "isotonic", "freshwater", "brackish")))
      return("growth limited, impaired")
    if(all(xs %in% c("negative/no growth", "minimal impairment", "marine")))
      return("growth limited, energy demanding")
    if(all(xs %in% c("optimal growth", "positive growth", "some impairment",
      "severe impairment", "marine")))
      return("impaired, energy demanding")
    if(all(xs %in% c("negative/no growth", "some impairment",
      "severe impairment", "marine")))
      return("growth limited, impaired, energy demanding")
    if(any(xs %in% c("unsuitable")))
      return("unsuitable")
    stop("no category for ", paste(c("ta", "oa", "sa"), xs, sep = " = ",
      collapse = ", "))
  }
  factor(apply(data.frame(ta, oa, sa), 1, hab_cat),
    levels = c("optimal", "growth limited", "impaired",
      "energy demanding", "growth limited, impaired",
      "growth limited, energy demanding", "impaired, energy demanding",
      "growth limited, impaired, energy demanding",
      "unsuitable"))
}

data(grids)
habgrids = grids
habgrids["ta.qual"] = classify_ta(habgrids$ta)
habgrids["sa.qual"] = classify_sa(habgrids$sa)
habgrids["oa.qual"] = classify_oa(habgrids$oa)
habgrids["habitat.fwa"] = classify_freshwater(habgrids$ta.qual, habgrids$sa.qual, habgrids$oa.qual)
habgrids["habitat.swa"] = classify_saltwater(habgrids$ta.qual, habgrids$sa.qual, habgrids$oa.qual)
# add closure meta data
data(closures)
habgrids["code"] = "O"
habgrids["days.since.closure"] = NA
for(d in unique(habgrids$date)){
  ind = which(d >= closures$start & d <= closures$end)
  if(length(ind) > 0){
    habgrids[habgrids$date == d, "code"] = as.character(closures[ind, "code"])
    if(as.character(closures[ind, "code"]) == "C")
      habgrids[habgrids$date == d, "days.since.closure"] =
        habgrids[habgrids$date == d, "date"] -
        closures$start[max(which(d >= closures$start))]
  }
}
habgrids["code"] = factor(habgrids$code)
# add ctd meta data
data(ctdmeta)
gridid = as.character(interaction(habgrids$date, habgrids$id))
metaid = as.character(interaction(strftime(ctdmeta$start, format = "%Y-%m-%d",
  tz = "US/Pacific"), ctdmeta$id))
for(i in seq(nrow(ctdmeta))){
  habgrids[gridid == metaid[i], "numcasts"] = ctdmeta[i, "numcasts"]
}

# usethis::use_data(habgrids, overwrite = TRUE)


args<-commandArgs(T)
{x_data}
y<-c({y_data})
fit<-lm(y~{x_expr})
summary(fit)
png(file = "{workspace}/rp%03d.png")
plot(fit)
q("no")


# Fit linear models with each column of \code{y}
# as dependent variables and the fixed and random
# effects as independent variables.
# Independent variables lacking variation are omitted.
# Returns the residual matrix.
adjust.columns <- function(y, fixed.effects=NULL, random.effects=NULL) {
    stopifnot(is.matrix(y))
    stopifnot(is.null(fixed.effects) || (is.matrix(fixed.effects) || is.data.frame(fixed.effects)) && nrow(y) == nrow(fixed.effects))
    stopifnot(is.null(random.effects) || nrow(y) == nrow(random.effects))

    remove.invariant.columns <- function(x) {
        if (is.null(x)) return(x)
        is.variable <- apply(x, 2, function(x) length(unique(x))) > 1
        var.idx <- which(is.variable)
        if (length(var.idx) == 0) NULL
        else x[,var.idx,drop=F]
    }

    fixed.effects <- remove.invariant.columns(fixed.effects)
    random.effects <- remove.invariant.columns(random.effects)

    if (is.null(fixed.effects) && is.null(random.effects)) return(y)

    if (is.null(random.effects)) {
        if (is.data.frame(fixed.effects))
            fixed.effects <- do.call(cbind, lapply(fixed.effects, simplify.variable))
        fit <- lm.fit(x=fixed.effects, y=y)
        return(residuals(fit))
    }

    data <- data.frame(random.effects, stringsAsFactors=F)
    formula <- "y ~"
    if (!is.null(fixed.effects)) {
        formula <- paste(formula, paste(colnames(fixed.effects), collapse=" + "), "+")
        data <- data.frame(data, fixed.effects, stringsAsFactors=F)
    }
    formula <- paste(formula, paste("(1 |", colnames(random.effects), ")", collapse=" + "))

    ret <- sapply(1:ncol(y), function(i) {
        data$y <- y[,i]
        tryCatch({
            residuals(lme4::lmer(formula, data=data))
            ## chose lme4 because it is faster than nlme
        }, error=function(e) {
            print(e)
            cat("For variable", i, "ignoring random effects.\n")
            tryCatch({
                residuals(lm(y ~ ., data=data))
            }, error=function(e) {
                print(e)
                cat("For variable", i, "setting all values to missing.\n")
                rep(NA, nrow(data))
            })
        })
    })
    dimnames(ret) <- dimnames(y)
    ret
}


source("_common.r")

x_ob = readLines("../runs/summit/dgemm/openblas.txt")
df_ob = process(x_ob, gpu=FALSE)

x_nl = readLines("../runs/summit/dgemm/netlib.txt")
df_nl = process(x_nl, gpu=FALSE)

df = rbind(
  cbind(subset(df_ob, nthreads==1), Backend="OpenBLAS"),
  cbind(df_nl, Backend="Netlib")
)

plotter(df, linetype=Backend) +
  labs(linetype="Backend") +
  ggtitle("Square Matrix Product", subtitle="OpenBLAS vs Netlib from R")

ggsave(last_plot(), file="netlib_vs_openblas.pdf")


# Formatting the 2011 phenotype data: NAM and F1
# Jinliang Yang
# Jan 19th, 2012

setwd("~/Documents/Heterosis_GWAS/pheno2011")

#############################################################
# Check the data completeness and correct the notes
#Notes: Two replications in Curtiss and Johnson
#Curtiss: 4651-6100
#Johnson J1251-J2350

file1 <- read.csv("data/rawdata/LL_KN_AKW_test.csv")
dim(file1)
#[1] 8284   11

nam <- subset(file1, Note.y!="Diallel" & Note.y!="NAM Filler");
dim(nam)
#[1] 5465   11 | [1] 5828    8
summary(nam)

###########################################################
### Delete duplicated input and missing data
barcode <- nam[duplicated(nam$Barcode),]$Barcode
nam[nam$Barcode%in%barcode,]
length(barcode)
# Get ride of 8 duplicated records
nam <- nam[!duplicated(nam$Barcode),]

##########################################################
### checking for outlyers
nam$KC <- as.numeric(as.character(nam$KC));
nam$TKW <- as.numeric(as.character(nam$TKW));
nam$AKW <- as.numeric(as.character(nam$AKW));

#### remove all the records with notes and KC<50
nambackup <- nam
nam <- nam[nam$KC >= 50,]
nam <- nam[nam$Note.x=="",]
hist(nam$KC)

head(nam[order(nam$KC),], 100)
tail(nam[order(nam$KC),])

dim(nam)
#[1] 4737   11
#######################################################

idx0 <- grep(" x B73", nam$Genotype)
sub1 <- nam[idx0,]
sub1$Genotype <- gsub(" x B73", "", sub1$Genotype)
sub1$Genotype <- paste("B73 x ", sub1$Genotype, sep="")

nam2011ear <- rbind(nam[-idx0,], sub1)

#######################################################
### BLUE
namkc <- BLUE(data=nam2011ear, model=KC~Genotype, random=~1|Farm, trait="KC", intercept="B73 x Z001E0002")
namkc$Genotype <- gsub("@", "", namkc$Genotype)

namtkw <- BLUE(data=nam2011ear, model=TKW~Genotype, random=~1|Farm, trait="TKW", intercept="B73 x Z001E0002")
namtkw$Genotype <- gsub("@", "", namtkw$Genotype)

namakw <- BLUE(data=nam2011ear, model=AKW~Genotype, random=~1|Farm, trait="AKW", intercept="B73 x Z001E0002")
namakw$Genotype <- gsub("@", "", namakw$Genotype)


# Creates the html output
library(lubridate)
library(markdown)

# Create a function for rendering the report
render_report <- function(money = 1000,
                         expected_return = 0.1,
                         adverse_return = -0.2) {
  # Package names
  packages <-
    c(
      "lubridate",
      "markdown",
      "tidyverse"
    )

  # Install packages not yet installed
  installed_packages <- packages %in% rownames(installed.packages())
  if (any(installed_packages == FALSE)) {
    install.packages(packages[!installed_packages])
  }

  # Packages loading
  invisible(lapply(packages, library, character.only = TRUE))

  # Render report
  rmarkdown::render(
    "report/report.Rmd",
    params = list(
      money = money,
      expected_return = expected_return,
      adverse_return = adverse_return
    ),
    output_file = paste0('report_', format(now(), '%d%m%y_%H%M%S'), '.html')
  )
}

# Use this function to render the report and assign you parameters
render_report(
  money = 1000,
  expected_return = 0.1,
  adverse_return = -0.2
)

# Please note: warnings usually signify that there are matches for which there is no offer (NAs for all
# bookmakers). It may happen that a future match has currently no betting odds, or that all
# are crossed out by the bookmakers. We are not worried by that. The values of
# `player_1_odds_max`, `player_1_odds_max`, `player_1_odds_max` and `player_1_odds_max` (in report.Rmd)
# will be then Inf/-Inf, and we filter them out.


windchill <- function(t, wind) {
    .Call('biometeoR_new_windchill', PACKAGE = 'biometeoR', t, wind)
}


a <- 42
A <- a * 2  # R is case sensitive
print(a)
cat(A, "\n") # "84" is concatenated with "\n"
if(A>a) # true, 84 > 42
{
  cat(A, ">", a, "\n")
}


################################################################################
#
# Simulation script
#
# Andrew Robinson 15-April-2015
#
################################################################################

the.seed <- 10000000

reps <- 1000
cores <- 25

MAIL <- TRUE

mail <- function(address, subject, message, attach = NULL) {
  if (MAIL)
    if (is.null(attach)) {
      system(paste("echo '", message,
                   "' | mutt -s '", subject,
                   "' ", address, sep=""))
    } else {
      system(paste("echo '", message,
                   "' | mutt -s '", subject, "'",
                   " ", address,
                   paste(" -a ", attach, collapse=" "), sep=""))
    }
}

mail.and.stop <- function() {
  mail("mensurationist@gmail.com",
       "Sims on server: ERROR.",
       "Stopped.")
  stop()
}

options(error = mail.and.stop)

library(lme4)    # For mixed-effects models

library(Amelia)  # For imputation

library(equivalence) # For data that I know

library(parallel) # Speed things up

data(ufc)

str(ufc)

ufc <- subset(ufc, !is.na(Dbh))
ufc$Species[ufc$Species %in% c("F","FG")] <- "GF"
ufc$Species <- factor(ufc$Species)
ufc$ht.measured <- is.na(ufc$Height)

ufc <- subset(ufc,
              Species %in% names(sort(-table(Species)))[1:6],
              select = c("ht.measured","Plot","Dbh.in","Species"))

## Fit a pair of models to compare using LRT

ufc.whole <- ufc

isna.1.w <- glmer(ht.measured ~ Dbh.in + Species + (1 | Plot),
                  data = ufc.whole, family = binomial)
isna.0.w <- glmer(ht.measured ~ Dbh.in + (1 | Plot),
                  data = ufc.whole, family = binomial)

anova(isna.0.w, isna.1.w)

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

imputeLRT <- function(h0, h1, imputed.data.list) {
  m <- length(imputed.data.list)
  h0.models <- lapply(imputed.data.list,
                      function (dataset) {
                        update(h0, data = dataset)
                      })
  h0.dev.funs <- lapply(imputed.data.list,
                        function (dataset) {
                          update(h0, data = dataset,
                                 devFunOnly = TRUE)
                        })
  Q.bar.0 <-
    colMeans(do.call(rbind,
                     lapply(h0.models,
                            function (fit) {
                              c(getME(fit, "theta"), fixef(fit))
                            })))
  h1.models <- lapply(imputed.data.list,
                      function (dataset) {
                        update(h1, data = dataset)
                      })
  h1.dev.funs <- lapply(imputed.data.list,
                        function (dataset) {
                          update(h1, data = dataset,
                                 devFunOnly = TRUE)
                        })
  Q.bar.1 <-
    colMeans(do.call(rbind,
                     lapply(h1.models,
                            function (fit) {
                              c(getME(fit, "theta"), fixef(fit))
                            })))
  d.prime.m.bar <- mean(unlist(lapply(1:m,
                                      function(i) {
                                        anova(h0.models[[i]],
                                              h1.models[[i]])$Chisq[2]
                                      })))
  d.L.bar <- mean(unlist(lapply(1:m,
                                function(i) {
                                  h0.dev.funs[[i]](Q.bar.0) -
                                    h1.dev.funs[[i]](Q.bar.1)
                                })))
  p0 <- length(Q.bar.0)
  p1 <- length(Q.bar.1)
  k <- p1 - p0
  rL <- (m + 1) / ((m - 1) * k) * (d.prime.m.bar - d.L.bar) # 3.8
  D.L <- d.L.bar / ((1 + rL) * k)                           # 3.7
  v <- k * (m - 1)
  w <- ifelse(v > 4,                                        # 2.7
              4 + (v - 4) * (1 + (1 - v/2) / rL)^2,
              v / 2 * (1 + 1/k) * (1 + 1/rL)^2)
  Pval <- 1 - pf(D.L, k, w)
  return(list(
    D.L = D.L,
    Pval = Pval,
    rL = rL,
    d.L.bar = d.L.bar,
    d.prime.m.bar = d.prime.m.bar,
    Q.bar.0 = Q.bar.0,
    Q.bar.1 = Q.bar.1,
    k = k,
    w = w,
    p0 = p0,
    p1 = p1,
    m = m))
}

isna.1 <- glmer(ht.measured ~ Dbh.in + Species + (1 | Plot),
                data = ufc, family = binomial)
isna.0 <- glmer(ht.measured ~ Dbh.in + (1 | Plot),
                data = ufc, family = binomial)

imputeLRT(isna.0, isna.1,
          list(ufc, ufc, ufc, ufc, ufc))

anova(isna.0, isna.1)

simulate <- function(m = 5, n = 30) {
  make.missing <- sample(1:nrow(ufc), size = n * 3, replace = FALSE)
  is.na(ufc$Species[make.missing[1:n]]) <- TRUE
  is.na(ufc$Dbh.in[make.missing[(n+1):(2*n)]]) <- TRUE
  is.na(ufc$ht.measured[make.missing[(2*n+1):(3*n)]]) <- TRUE
  isna.1 <- glmer(ht.measured ~ Dbh.in + Species + (1 | Plot),
                  data = ufc, family = binomial)
  isna.0 <- glmer(ht.measured ~ Dbh.in + (1 | Plot),
                  data = ufc, family = binomial)
  naive.p <- anova(isna.0, isna.1)[["Pr(>Chisq)"]][2]
  ## Impute datasets using Amelia
  ufc.imputes <- amelia(ufc,
                        m = m,
                        cs = "Plot",
                        noms = "Species",
                        p2s = 0)
  imputed <- imputeLRT(isna.0, isna.1, ufc.imputes$imputations)
  return(list(naive.p = naive.p, imputed.p = imputed$Pval))
}

simulate()

frame <- expand.grid(ms = c(2, 5, 10, 20, 50, 100),
                     ns = c(5, 10, 20, 30, 50, 100),
                     reps = 1:reps)

results <- mclapply(1:nrow(frame),
                    function(i)
                    simulate(frame$ms[i], frame$ns[i]),
                    mc.cores = cores)

results <- do.call(rbind, results)

experiment <- cbind(frame, results)

save(experiment, file = "mi.RData")

mail(address = "andrewpr",
     subject = "MI simulations",
     message = "All done.",
     attach = "mi.RData")


context("Margins")

vars <- list(c("a", "b", "c"), c("d", "e", "f"))
test_that("margins expanded", {
  expect_that(margins(vars, "c")[[2]], equals(c("c")))
  expect_that(margins(vars, "b")[[2]], equals(c("b", "c")))
  expect_that(margins(vars, "a")[[2]], equals(c("a", "b", "c")))

  expect_that(margins(vars, "f")[[2]], equals(c("f")))
  expect_that(margins(vars, "e")[[2]], equals(c("e", "f")))
  expect_that(margins(vars, "d")[[2]], equals(c("d", "e", "f")))
})

test_that("margins intersect", {
  expect_that(margins(vars, c("c", "f"))[-1],
    equals(list("c", "f", c("c", "f"))))

})

test_that("(all) comes after NA", {
  df <- data.frame(a = c("a", "b", NA), b = c("a", "b", NA), value = 1)

  df2 <- add_margins(df, "a")
  expect_that(levels(df2$a), equals(c("a", "b", NA, "(all)")))

  df3 <- add_margins(df, c("a", "b"))
  expect_that(levels(df3$a), equals(c("a", "b", NA, "(all)")))
  expect_that(levels(df3$b), equals(c("a", "b", NA, "(all)")))

  dc <- dcast(df, a ~ ., margins = TRUE, fun = length)
  expect_that(levels(dc$a), equals(c("a", "b", NA, "(all)")))
  expect_that(as.character(dc$a), equals(c("a", "b", NA, "(all)")))

})


read.fit<-function(file){
  #
  # Function to read a basic AD Model Builder fit.
  #
  # Use for instance by:
  #
  #   simple.fit <- read.fit('c:/admb/examples/simple')
  #
  # Then the object 'simple.fit' is a list containing sub-objects
  # 'names', 'est', 'std', 'cor', and 'cov' for all model
  # parameters and sdreport quantities.
  #
  ret<-list()
  parfile<-as.numeric(scan(file.path(data.path,paste(file,'.par', sep='')),
                      what='', n=16, quiet=TRUE)[c(6,11,16)])
  ret$nopar<-as.integer(parfile[1])
  ret$nlogl<-parfile[2]
  ret$maxgrad<-parfile[3]
  file<-file.path(data.path,paste(file,'.cor', sep=''))
  lin<-readLines(file)
  ret$npar<-length(lin)-2
  ret$logDetHess<-as.numeric(strsplit(lin[1], '=')[[1]][2])
  sublin<-lapply(strsplit(lin[1:ret$npar+2], ' '),function(x)x[x!=''])
  ret$names<-unlist(lapply(sublin,function(x)x[2]))
  ret$est<-as.numeric(unlist(lapply(sublin,function(x)x[3])))
  ret$std<-as.numeric(unlist(lapply(sublin,function(x)x[4])))
  ret$cor<-matrix(NA, ret$npar, ret$npar)
  corvec<-unlist(sapply(1:length(sublin), function(i)sublin[[i]][5:(4+i)]))
  ret$cor[upper.tri(ret$cor, diag=TRUE)]<-as.numeric(corvec)
  ret$cor[lower.tri(ret$cor)] <- t(ret$cor)[lower.tri(ret$cor)]
  ret$cov<-ret$cor*(ret$std%o%ret$std)

  dim<-as.numeric(scan(file.path(data.path,'admodel.dep'), what='', n=2, quiet=TRUE))
  ret$dep<-matrix(as.numeric(scan(file.path(data.path,'admodel.dep'), what='', n=dim[1]*dim[2]+2, quiet=TRUE))[-c(1,2)],
                  byrow=TRUE, nrow=dim[2], ncol=dim[1])
  return(ret)
}


#local h2 estimation
library('RiskPortfolios')
library('MASS')
library('Matrix')
.libPaths("~/R/rlib-3.4_new")
library('pdist')
library('corpcor')

#segment position
start_pos=45859651
stop_pos=45909024

#sample size (ascertained)
n_cases=1610
n_controls=2205

#load esimated effect size from MR results
dataset='covid_nejm'
df<-read.csv(paste0('/data/g*/z*/covid19_neanderthals/mr/result/',dataset,'_r2_0.1.csv'),header = T,stringsAsFactors = F)
df<-df[df$mrjti_sig=='sig',]
df<-df[!is.na(df$mrjti_beta_mean),]

#gene annotation
anno<-read.table('/data/coxvgi/z*/anno/gencode/37/gencode.v32.GRCh37.txt',header = T,stringsAsFactors = F)
df<-merge(df,anno,by='geneid')

#sample size
ascertained_prevalence=n_cases/(n_cases+n_controls)
N_effective = 4*ascertained_prevalence*(1-ascertained_prevalence)*(n_cases+n_controls)

i=1 #for test

for (i in 1:nrow(df)){

  print(i)

  geneid=df[i,'geneid']
  tissue=df[i,'tissue']
  alpha=df[i,'mrjti_beta_mean']
  alpha_se=df[i,'mrjti_beta_se']

  #get chr pos
  chr=as.numeric(sub('chr','',anno[which(anno$geneid == geneid),'chr']))
  left=max(anno[which(anno$geneid == geneid),'left']-1e6,1)
  right=anno[which(anno$geneid == geneid),'right']+1e6

  #extract snp using plink
  cmd<-paste0('plink --bfile /data/g*/z*/covid19_neanderthals/expression_mediated_h2/geno/geno --chr ',chr,' --from-bp ',left,' --to-bp ',right,' --recode A --out /data/g*/z*/covid19_neanderthals/expression_mediated_h2/geno/tmp/',geneid,'_1m; plink --bfile /data/g*/z*/covid19_neanderthals/expression_mediated_h2/geno/geno --chr ',chr,' --from-bp ',left,' --to-bp ',right,' --make-bed --out /data/g*/z*/covid19_neanderthals/expression_mediated_h2/geno/tmp/',geneid,'_1m')
  system(cmd,wait = T)

  #load dosage for
  dosage_raw<-try(read.table(paste0('/data/g*/z*/covid19_neanderthals/expression_mediated_h2/geno/tmp/',geneid,'_1m.raw'),header = T,stringsAsFactors = F))
  if('try-error' %in% class(dosage_raw)){next}
  dosage<-dosage_raw[,-c(1,3:6)]  #rm useless cols

  #load info
  info_raw<-read.table(paste0('/data/g*/z*/covid19_neanderthals/expression_mediated_h2/geno/tmp/',geneid,'_1m.bim'),stringsAsFactors = F)

  #rm raw file
  cmd<-paste0('rm /data/g*/z*/covid19_neanderthals/expression_mediated_h2/geno/tmp/',geneid,'_1m*'); system(cmd,wait = T)

  #info
  info_raw$counted_allele<-sapply(colnames(dosage)[-1],function(x) strsplit(x,"[_]")[[1]][2])
  info_raw$ref_allele<-ifelse(info_raw$counted_allele==info_raw$V5,info_raw$V6,info_raw$V5)
  info_raw$chr_bp<-paste0(info_raw$V1,'_',info_raw$V4)
  colnames(info_raw)[2]<-'rsid'
  snp_info<-info_raw[,c('rsid','chr_bp','ref_allele','counted_allele')]
  snp_info$pos=sapply(snp_info$chr_bp,function(x) strsplit(x,"[_]")[[1]][2])
  snp_info$in_segment<-ifelse((snp_info$pos>start_pos & snp_info$pos<stop_pos),1,0)
  in_segment_pos<-which(snp_info$in_segment==1)

  #dosage
  dosage$IID<-sub('^.....','',dosage$IID)
  colnames(dosage)<-c('sampleid',sapply(colnames(dosage)[-1],function(x) strsplit(x,"[_]")[[1]][1]))

  #post imputation imputation replace by mean
  if(ncol(dosage)>2){
    dosage[,-1]<-round(apply(dosage[,-1], 2, function(x) ifelse(is.na(x),mean(x,na.rm=T),x)),3)
  }

  #scale genotype in dosage
  dosage[,-1]<-sapply(dosage[,-1], function(x) scale(x))
  dosage<-dosage[,c('sampleid',snp_info$rsid)]

  #load expression file (residual)
  exp<-readRDS(paste0('/data/coxvgi/z*/data/gtex/exp/v8/weighted/',tissue,'/',geneid,'.rds'))
  exp<-exp[exp$tissue==tissue,]
  exp$sampleid=sub('GTEX.','',exp$sampleid)

  #estimate beta_eQTL
  eqtl_df<-merge(exp[,c('sampleid','exp')],dosage,by='sampleid')
  for (j in 1:nrow(snp_info)){
    rsid=snp_info[j,'rsid']
    ans<-summary(lm(eqtl_df[,'exp']~eqtl_df[,rsid]))
    snp_info[j,'beta_eqtl']=ans$coefficients['eqtl_df[, rsid]','Estimate']
    snp_info[j,'se_eqtl']=ans$coefficients['eqtl_df[, rsid]','Std. Error']
  }

  #---full---

  full<-snp_info

  #estimate snp-snp var-cov matrix
  full_c <- covEstimation(as.matrix(dosage[,-1]), control = list(type = 'cor'))

  #Moore-Penrose pseudoinverse
  inverse_full_c<-ginv(full_c)

  #q=rank(C)  the maximum number of linearly independent vectors in rows or columns
  q=rankMatrix(inverse_full_c)
  q=as.numeric(q)

  #pseudo gwas beta
  alpha=df[i,'mrjti_beta_mean']
  full$pseudo_gwas_beta = alpha * full$beta_eqtl

  #pseudo gwas se
  alpha_se=df[i,'mrjti_beta_se']
  full$pseudo_gwas_se = ((alpha_se)^2 * (full$se_eqtl)^2 +
                           (alpha_se)^2 * (full$beta_eqtl)^2 +
                           (alpha)^2 * (full$se_eqtl)^2)^0.5

  #n
  df[i,'full_n'] = n = N_effective
  #p
  df[i,'full_p'] = p = nrow(full)
  #h2
  df[i,'full_h2_local'] = (t(full$pseudo_gwas_beta) %*% inverse_full_c %*% full$pseudo_gwas_beta - q/n) / (n-q) *n

  #---segment---

  segment<-full[full$in_segment==1,]

  #estimate snp-snp var-cov matrix
  segment_c<-full_c[which(full$in_segment==1),which(full$in_segment==1)]

  #Moore-Penrose pseudoinverse
  inverse_segment_c<-ginv(segment_c)

  #q=rank(C)  the maximum number of linearly independent vectors in rows or columns
  q=rankMatrix(inverse_segment_c)
  q=as.numeric(q)

  #pseudo gwas beta
  alpha=df[i,'mrjti_beta_mean']
  segment$pseudo_gwas_beta = alpha * segment$beta_eqtl

  #pseudo gwas se
  alpha_se=df[i,'mrjti_beta_se']
  segment$pseudo_gwas_se = ((alpha_se)^2 * (segment$se_eqtl)^2 +
                              (alpha_se)^2 * (segment$beta_eqtl)^2 +
                              (alpha)^2 * (segment$se_eqtl)^2)^0.5

  #n
  df[i,'segment_n']=n=N_effective
  #p
  df[i,'segment_p']=p=nrow(segment)
  #h2
  df[i,'segment_h2_local']=(t(segment$pseudo_gwas_beta) %*% inverse_segment_c %*% segment$pseudo_gwas_beta - q/n) / (n-q) *n

}

df$pi_c=df$segment_h2_local/df$full_h2_local

df$concentration_ratio=df$segment_h2_local*df$full_p/df$segment_p/df$full_h2_local

write.table(df,paste0('/data/g*/z*/covid19_neanderthals/expression_mediated_h2/result/h2_segment_',dataset,'.txt'),quote = F,sep='\t',row.names = F)


  adjust.depth.for.drift = function( x, data.series="seabird" ) {

    # most of the time is spent near the surface not fishing

    # based upon empirical observation from 2012 data, near-surface values should be ~ 0.014 decibar
    # detect any drift in the initial pressure values

    ndata = length(x)
    X = data.frame( dataorder=1:ndata, X=x, fishing=1, id=NA )

    if (data.series=="seabird") {
      # error checking values to detect drift in pressure sensors at surface
      expectedValue=0.014
      PrThreshold = 0.05
    }

    threshold = quantile( X$X, probs=PrThreshold )
    if (abs (threshold - expectedValue ) > (2 * sd( X$X[ X$X <= threshold] )) ) {
      print( paste( "Adjusting depth sensors for drift: observed:", threshold, "expected: ~ 0.1 decibar" ) )
      print( paste( "mean: ", mean( x[x<=threshold] ), "sd: ", sd( x[x<=threshold] ) ) )
      print( "----------")

      if (abs(threshold) > 1) {
        print( "In fact, the deviation was > 1 decibar" )
        print( "Stopping now as there may be something wrong with the data" )

        stop()
      }

      X$X = X$X - threshold

    }

    return(X$X)

}


#################
# Helper function to fit the models presented in:
# Hertzog et al Model-based data integration
# problems can be reported by mailing:
# lionel.hertzog@thuenen.de
#############

# the functions take as inputs:
# @species, a character, the species name
# @path, a character, the path to save the files
# ..., additional parameters to pass to the fitting function

# the functions returns as files saved on disk:
# the fitted model object
# the R2 and RMSE
# the Rhat of the model parameters
# the predicted annual abundance index for the CBBS routes
# two posterior predictive checks graphs

# to run the functions assume that the following data frames
# are loaded in the environment:
# mhb, ornitho_list, ornitho_unstr, list_all and unstr_all
# see the example script for the required structure of the
# data frames

## function to fit model 1

fit_model1 <- function(species, path = ""){

  # filter mhb data
  dat_mhb <-  filter(mhb, Artname == species)
  # turn the year effect into a factor
  dat_mhb$fJahr <- factor(dat_mhb$Jahr)

  m <- trim(count ~ ROUTENCODE + Jahr, dat_mhb, overdisp = TRUE, verbose = TRUE, model = 3)
  # re-fit the model without overdisp if needed
  if(overdispersion(m) < 1.0){
    m <- trim(count ~ ROUTENCODE + Jahr, dat_mhb, overdisp = FALSE, verbose = TRUE, model = 3)
  }
  # the total breeding bird abundance over all Mhb plots
  # with 95% confidence band
  tt <- totals(m, level = 0.95) # save this

  write.table(tt, paste0(path, species, "/totals_modeltrim.csv"), sep = ",", row.names = FALSE)

  # rmse and r square for TRIM
  fitted <- results(m)
  # add the actual obs
  ff <- merge(fitted, dat_mhb, by.x = c("site", "time"), by.y = c("ROUTENCODE", "Jahr"))
  # the residuals
  ff$res <- ff$count - ff$fitted
  # the normalized root mean squared error
  rmse <- sqrt(mean(ff$res ** 2, na.rm = TRUE)) / mean(dat_mhb$count) # save this
  # R2
  r2 <- 1 - (sum(ff$res ** 2, na.rm = TRUE) / sum((ff$count - mean(ff$count)) ** 2)) # save this

  r2_rmse <- data.frame(metric = c("r2", "rmse"), value = c(r2, rmse))

  write.table(r2_rmse, paste0(path, species, "/r2_modeltrim.csv"),
              sep = ",", row.names = FALSE)

}

## function to fit model 2

fit_model2 <- function(species, path = "", ...){

  # filter Mhb data
  dat_mhb <-  filter(mhb, Artname == species)

  # set the model matrix
  dat_mhb$fJahr <- factor(dat_mhb$Jahr)
  modmat <- model.matrix(~fJahr, dat_mhb, contrasts.arg = list(fJahr = "contr.sum"))
  route_id <- as.numeric(factor(dat_mhb$ROUTENCODE))

  # priors
  intercept <- student(3, 0, 10)
  yr_eff <- normal(0, 1, dim = ncol(modmat) - 1)
  sd_route <- exp(student(3, 0, 10))
  alpha <- normal(0, 1, dim= max(route_id))
  route_avg <- intercept + alpha * sd_route
  sd_res <- gamma(0.01, 0.01)

  # linear predictor
  mu <- exp(modmat[,-1] %*% yr_eff + route_avg[route_id])
  # the response
  prob <- sd_res / (sd_res + mu)

  count <- as_data(dat_mhb$count)
  distribution(count) <- negative_binomial(size = sd_res, prob = prob)

  # set the model
  m_1 <- model(yr_eff, sd_route, sd_res, intercept)

  # run the model
  t1_1 <- Sys.time()
  d_1 <- mcmc(m_1, ...)
  t1_2 <- Sys.time()

  # save the model (save other stuff for later use?)
  saveRDS(d_1, paste0(path, "", species, "/fit_model1.rds"))
  cat(paste0("Fitting time for ", species,
             ": ", round(as.numeric(difftime(t1_2, t1_1, units = "min")), 3),
             " min\n"))

  # compute rhat
  tmp <- as.data.frame(coda::gelman.diag(d_1)$psrf)
  tmp$species <- species
  names(tmp)[1:2] <- c("point", "upper")
  tmp$param <- rownames(tmp)
  rownames(tmp) <- NULL
  tmp$ESS <- coda::effectiveSize(d_1)
  write.table(tmp, paste0(path,  species, "/rhat_model1.csv"),
              sep = ",", row.names = FALSE)

  cat(paste0("Maximum rhat value is: ", tmp[which.max(tmp$point),"point"], "\n"))

  ## r2 and rmse computation
  r2 <- greta.checks::bayes_R2(count, mu, d_1)
  error <- greta.checks::rmse(count, mu, d_1, norm = TRUE)
  # put the two together
  r2_error <- as.data.frame(rbind(r2, error))
  r2_error$metric <- c("r2", "rmse")

  write.table(r2_error, paste0(path,  species, "/rmse_model1.csv"),
              sep = ",", row.names = FALSE)

  # now get se from the predictions between 2012 and 2017
  # in a manner similar to TRIM, we compute the totals

  # new data frame to compute
  newdat <- expand.grid(fJahr = factor(2005:2018, levels = 2005:2018),
                        route_id = unique(route_id))
  # predicted model matrix
  modmat_pred <- model.matrix(~ fJahr,
                              newdat,
                              contrasts.arg = list(fJahr = "contr.sum"))
  mu_pred <- exp(modmat_pred[,-1] %*% yr_eff + route_avg[newdat$route_id])
  # calculate expectations
  d_pred <- t(as.matrix(calculate(mu_pred, values = d_1)))
  # some data wraggling
  d_df <- as.data.frame(d_pred)
  d_df$Jahr <- newdat$fJahr

  tt <- gather(d_df, key = "iteration", value = "val", -Jahr)

  tt %>%
    group_by(Jahr, iteration) %>%
    summarise(S = sum(val)) %>%
    ungroup() %>%
    group_by(Jahr) %>%
    summarise(M = mean(S), SD = sd(S),
              lo = quantile(S, probs = 0.025),
              hi = quantile(S, probs = 0.975)) -> tt_d

  write.table(tt_d, paste0(path,  species, "/totals_model1.csv"),
              sep = ",", row.names = FALSE)
  # get posterior predictive checks
  pp1 <- greta.checks::pp_check(d_1, count, nsim = 50, type = "dens_overlay")
  pp2 <- greta.checks::pp_check(d_1, count, nsim = 50, type = "error_scatter_avg")

  ggsave(paste0(path,  species, "/pp1_model1.png"), pp1)
  ggsave(paste0(path,  species, "/pp2_model1.png"), pp2)

}

## function to fit model 3

fit_model3 <- function(species,path="", ...){

  # filter Mhb data
  dat_mhb <-  filter(mhb, Artname == species)

  ## ornitho list
  dat_ornitho_list <- subset(ornitho_list, SPECIES_NAME == species)

  ## set the model matrices
  dat_mhb$fJahr2 <- factor(dat_mhb$Jahr, levels = 2005:2019)
  dat_ornitho_list$fyear <- factor(dat_ornitho_list$year, levels = 2005:2019)

  yr_eff_mhb <- model.matrix(~fJahr2, dat_mhb,
                             contrasts.arg = list(fJahr2 = "contr.sum"))
  yr_eff_list <- model.matrix(~fyear, dat_ornitho_list,
                              contrasts.arg = list(fyear = "contr.sum"))

  # prior for common year effect
  yr_eff <- normal(0, 1, dim = ncol(yr_eff_mhb) - 1)

  ## model for mhb
  # index for routes
  route_id <- as.numeric(factor(dat_mhb$ROUTENCODE))

  # priors
  intercept_mhb <- student(3, 0, 10)
  sd_route <- exp(student(3, 0, 10))
  alpha_route <- normal(0, 1, dim = max(route_id))
  route_avg <- intercept_mhb + alpha_route * sd_route
  sd_res_mhb <- gamma(0.01, 0.01)

  # linear predictor
  mu_mhb <- exp(yr_eff_mhb[,-1] %*% yr_eff + route_avg[route_id])

  # re-param for negative binomial
  prob_mhb <- sd_res_mhb / (mu_mhb + sd_res_mhb)

  ## model for ornitho lists
  # index for locality
  locality_id <- as.numeric(factor(dat_ornitho_list$ID_PLACE))
  # prior fixed effect
  intercept_list <- student(3, 0, 10)

  # prior for random effect
  sd_locality <- exp(student(3, 0, 10))
  alpha_locality <- normal(0, 1, dim = max(locality_id))
  locality_avg <- intercept_list + alpha_locality * sd_locality

  # prior for zero-inflation
  theta <- beta(1, 1) # uniform between 0 and 1

  mu_list <- dat_ornitho_list$effort_h * exp(yr_eff_list[,-1] %*% yr_eff + locality_avg[locality_id])

  # the response
  y_mhb <- as_data(dat_mhb$count)
  y_ornitho <- as_data(dat_ornitho_list$count)

  distribution(y_mhb) <- negative_binomial(size = sd_res_mhb,
                                           prob = prob_mhb)
  distribution(y_ornitho) <- greta.multivariate::zero_inflated_poisson(theta,
                                                                       mu_list,
                                                                       dim = length(y_ornitho))

  m_2 <- model(intercept_mhb, intercept_list,
               yr_eff, sd_route, sd_locality,
               sd_res_mhb, theta)

  cat("Starting fitting model 2")

  t2_1 <- Sys.time()
  d_2 <- mcmc(m_2, ...)
  t2_2 <- Sys.time()

  #cat(paste0("Model 2: ", t2 - t1))

  # save the model
  saveRDS(d_2, paste0(path,species,"/fit_model2.rds"))
  cat(paste0("Fitting time for ", species,
             ": ", round(as.numeric(difftime(t2_2, t2_1, units = "min")), 3),
             " min"))
  # compute rhat
  tmp <- as.data.frame(coda::gelman.diag(d_2)$psrf)
  tmp$species <- species
  names(tmp)[1:2] <- c("point", "upper")
  tmp$param <- rownames(tmp)
  tmp$ESS <- coda::effectiveSize(d_2)
  rownames(tmp) <- NULL
  write.table(tmp, paste0(path, species, "/rhat_model2.csv"),
              sep = ",", row.names = FALSE)

  cat(paste0("Maximum rhat value is: ", tmp[which.max(tmp$point),"point"], "\n"))

  # compute the r2 and rmse
  r2 <- greta.checks::bayes_R2(y_mhb, mu_mhb, d_2)
  error <- greta.checks::rmse(y_mhb, mu_mhb, d_2, norm = TRUE)

  # put the two together
  r2_error <- as.data.frame(rbind(r2, error))
  r2_error$metric <- c("r2", "rmse")

  write.table(r2_error, paste0(path, species, "/rmse_model2.csv"),
              sep = ",", row.names = FALSE)

  # get the totals over Mhb plots
  newdat <- expand.grid(fJahr = factor(2005:2019, levels = 2005:2019),
                        route_id = unique(route_id))
  # predicted model matrix
  modmat_pred <- model.matrix(~ fJahr,
                              newdat,
                              contrasts.arg = list(fJahr = "contr.sum"))
  mu_pred <- exp(modmat_pred[,-1] %*% yr_eff + route_avg[newdat$route_id])
  # calculate expectations
  d_pred <- t(as.matrix(calculate(mu_pred, values = d_2)))
  # some data wraggling
  d_df <- as.data.frame(d_pred)
  d_df$Jahr <- newdat$fJahr

  tt <- gather(d_df, key = "iteration", value = "val", -Jahr)

  tt %>%
    group_by(Jahr, iteration) %>%
    summarise(S = sum(val)) %>%
    ungroup() %>%
    group_by(Jahr) %>%
    summarise(M = mean(S), SD = sd(S),
              lo = quantile(S, probs = 0.025),
              hi = quantile(S, probs = 0.975)) -> tt_d

  write.table(tt_d, paste0(path, species, "/totals_model2.csv"),
              sep = ",", row.names = FALSE)

}

## function to fit model 4
fit_model4 <- function(species, path = "", ...){

  # filter Mhb data
  dat_mhb <-  filter(mhb, Artname == species)

  ## ornitho list
  dat_ornitho_list <- subset(ornitho_list, SPECIES_NAME == species)

  # ornitho unstr
  dat_ornitho_unstr <- subset(ornitho_unstr, SPECIES_NAME == species)
  # std the effort
  dat_ornitho_unstr$effort2 <- scale(dat_ornitho_unstr$effort2)

  dat_mhb$fJahr2 <- factor(dat_mhb$Jahr, levels = 2005:2019)
  dat_ornitho_list$fyear <- factor(dat_ornitho_list$year,
                                   levels = 2005:2019)

  dat_ornitho_unstr$fyear <- factor(dat_ornitho_unstr$year,
                                    levels = 2005:2019)

  # the common year effect
  yr_eff_mhb <- model.matrix(~fJahr2, dat_mhb,
                             contrasts.arg = list(fJahr2 = "contr.sum"))
  yr_eff_list <- model.matrix(~fyear, dat_ornitho_list,
                              contrasts.arg = list(fyear = "contr.sum"))
  yr_eff_unstr <- model.matrix(~fyear, dat_ornitho_unstr,
                               contrasts.arg = list(fyear = "contr.sum"))

  # prior for common year effect
  yr_eff <- normal(0, 1, dim = ncol(yr_eff_mhb) - 1)

  ## model for mhb
  # index for routes
  route_id <- as.numeric(factor(dat_mhb$ROUTENCODE))

  # priors
  intercept_mhb <- student(3, 0, 10)
  sd_route <- exp(student(3, 0, 10))
  alpha_route <- normal(0, 1, dim = max(route_id))
  route_avg <- intercept_mhb + sd_route * alpha_route
  sd_res_mhb <- gamma(0.01, 0.01)

  # linear predictor
  mu_mhb <- exp(yr_eff_mhb[,-1] %*% yr_eff + route_avg[route_id])

  # re-param for negative binomial
  prob_mhb <- sd_res_mhb / (mu_mhb + sd_res_mhb)

  ## model for ornitho lists
  # index for locality
  locality_id <- as.numeric(factor(dat_ornitho_list$ID_PLACE))
  # prior fixed effect
  intercept_list <- student(3, 0, 10)
  #dens_eff_list <- normal(0, 1)

  # prior for random effect
  sd_locality <- exp(student(3, 0, 10))
  alpha_locality <- normal(0, 1, dim = max(locality_id))
  locality_avg <- intercept_list + alpha_locality * sd_locality
  #zero inflation
  theta <- beta(1, 1)

  mu_list <- dat_ornitho_list$effort_h * exp(yr_eff_list[,-1] %*% yr_eff +
                                               locality_avg[locality_id])

  ## model for ornitho unstr
  # index for raster cell
  raster_id <- as.numeric(factor(dat_ornitho_unstr$ID_PLACE))
  # prior fixed effect
  intercept_unstr <- greta::student(3, 0, 10)
  slp <- normal(0, 1)
  #dens_eff_unstr <- normal(0, 1)

  # prior for random effect
  sd_raster <- exp(greta::student(3, 0, 10))
  alpha_raster <- normal(0, 1, dim = max(raster_id))
  raster_avg <- intercept_unstr + alpha_raster * sd_raster
  #sd_res_unstr <- gamma(0.01, 0.01)

  mu_unstr <- exp(slp * dat_ornitho_unstr$effort2 +
                    yr_eff_unstr[,-1] %*% yr_eff + raster_avg[raster_id])

  # the response
  y_mhb <- as_data(dat_mhb$count)
  y_list <- as_data(dat_ornitho_list$count)
  y_unstr <- as_data(dat_ornitho_unstr$count)

  distribution(y_mhb) <- negative_binomial(prob = prob_mhb, size = sd_res_mhb)
  distribution(y_list) <- zero_inflated_poisson(theta = theta, lambda = mu_list, dim = length(y_list))
  distribution(y_unstr) <- poisson(mu_unstr)

  m_3 <- model(intercept_mhb, intercept_list, intercept_unstr, slp,
               yr_eff, sd_res_mhb, theta,
               sd_route, sd_locality, sd_raster)

  cat("Starting fitting model 3")
  t3_1 <- Sys.time()
  d_3 <- mcmc(m_3, ...)
  t3_2 <- Sys.time()

  #cat(paste0("Model 3: ", t2 - t1))

  # save the model
  saveRDS(d_3, paste0(path,species,"/fit_model3.rds"))
  cat(paste0("Fitting time for ", species,
             ": ", round(as.numeric(difftime(t3_2, t3_1, units = "min")), 3),
             " min"))

  # compute rhat
  tmp <- as.data.frame(coda::gelman.diag(d_3)$psrf)
  tmp$species <- species
  names(tmp)[1:2] <- c("point", "upper")
  tmp$param <- rownames(tmp)
  rownames(tmp) <- NULL
  tmp$ESS <- coda::effectiveSize(d_3)
  write.table(tmp, paste0(path,  species, "/rhat_model3.csv"),
              sep = ",", row.names = FALSE)

  cat(paste0("Maximum rhat value is: ", tmp[which.max(tmp$point),"point"], "\n"))

  # do some standard pp_check and bayes_R2 computation
  r2 <- greta.checks::bayes_R2(y_mhb, mu_mhb, d_3)
  error <- greta.checks::rmse(y_mhb, mu_mhb, d_3, norm = TRUE)
  # put the two together
  r2_error <- as.data.frame(rbind(r2, error))
  r2_error$metric <- c("r2", "rmse")
  write.table(r2_error, paste0(path,  species, "/rmse_model3.csv"),
              sep = ",", row.names = FALSE)

  ## compute breeding totals
  newdat <- expand.grid(fJahr = factor(2005:2019, levels = 2005:2019),
                        route_id = unique(route_id))
  # predicted model matrix
  modmat_pred <- model.matrix(~ fJahr,
                              newdat,
                              contrasts.arg = list(fJahr = "contr.sum"))
  mu_pred <- exp(modmat_pred[,-1] %*% yr_eff + route_avg[newdat$route_id])
  # calculate expectations
  d_pred <- t(as.matrix(calculate(mu_pred, values = d_3)))
  # some data wraggling
  d_df <- as.data.frame(d_pred)
  d_df$Jahr <- newdat$fJahr

  tt <- gather(d_df, key = "iteration", value = "val", -Jahr)

  tt %>%
    group_by(Jahr, iteration) %>%
    summarise(S = sum(val)) %>%
    ungroup() %>%
    group_by(Jahr) %>%
    summarise(M = mean(S), SD = sd(S),
              lo = quantile(S, probs = 0.025),
              hi = quantile(S, probs = 0.975)) -> tt_d

  write.table(tt_d, paste0(path,  species, "/totals_model3.csv"),
              sep = ",", row.names = FALSE)

}

## function to fit model 5

fit_model5 <- function(species, path = "", ...){
  # filter Mhb data
  dat_mhb <-  filter(mhb, Artname == species)

  ## complete list (eBird and ornitho)
  dat_list_all <- subset(list_all, SPECIES_NAME == species)

  dat_mhb$fJahr2 <- factor(dat_mhb$Jahr, levels = 2005:2019)
  dat_list_all$fyear <- factor(dat_list_all$year,
                               levels = 2005:2019)

  # the common year effect
  yr_eff_mhb <- model.matrix(~fJahr2, dat_mhb,
                             contrasts.arg = list(fJahr2 = "contr.sum"))
  yr_eff_list <- model.matrix(~fyear, dat_list_all,
                              contrasts.arg = list(fyear = "contr.sum"))

  # prior for common year effect
  yr_eff <- normal(0, 1, dim = ncol(yr_eff_mhb) - 1)

  ## model for mhb
  # index for routes
  route_id <- as.numeric(factor(dat_mhb$ROUTENCODE))

  # priors
  intercept_mhb <- student(3, 0, 10)
  sd_route <- exp(student(3, 0, 10))
  alpha_route <- normal(0, 1, dim = max(route_id))
  route_avg <- intercept_mhb + sd_route * alpha_route
  sd_res_mhb <- gamma(0.01, 0.01)

  # linear predictor
  mu_mhb <- exp(yr_eff_mhb[,-1] %*% yr_eff + route_avg[route_id])

  # re-param for negative binomial
  prob_mhb <- sd_res_mhb / (mu_mhb + sd_res_mhb)

  ## model for ornitho lists
  # index for locality
  locality_id <- as.numeric(factor(dat_list_all$ID_PLACE))
  # prior fixed effect
  intercept_list <- student(3, 0, 10)
  #dens_eff_list <- normal(0, 1)

  # prior for random effect
  sd_locality <- exp(student(3, 0, 10))
  alpha_locality <- normal(0, 1, dim = max(locality_id))
  locality_avg <- intercept_list + sd_locality * alpha_locality

  # prior for zero-inflation
  theta <- beta(1, 1)

  mu_list <- dat_list_all$effort_h * exp(yr_eff_list[,-1] %*% yr_eff +
                                           locality_avg[locality_id])

  # the response
  y_mhb <- as_data(dat_mhb$count)
  y_list <- as_data(dat_list_all$count)

  distribution(y_mhb) <- negative_binomial(prob = prob_mhb, size = sd_res_mhb)
  distribution(y_list) <- greta.multivariate::zero_inflated_poisson(theta,
                                                                    mu_list,
                                                                    dim = length(y_list))

  m_4 <- model(intercept_mhb, intercept_list,
               yr_eff, sd_res_mhb, theta,
               sd_route, sd_locality)

  cat("Starting fitting model 4")
  t4_1 <- Sys.time()
  d_4 <- mcmc(m_4, ...)
  t4_2 <- Sys.time()

  #cat(paste0("Model 3: ", t2 - t1))

  # save the model
  saveRDS(d_4, paste0(path,species,"/fit_model4.rds"))
  cat(paste0("Fitting time for ", species,
             ": ", round(as.numeric(difftime(t4_2, t4_1, units = "min")), 3),
             " min\n"))
  # compute rhat
  tmp <- as.data.frame(coda::gelman.diag(d_4)$psrf)
  tmp$species <- species
  names(tmp)[1:2] <- c("point", "upper")
  tmp$param <- rownames(tmp)
  rownames(tmp) <- NULL
  tmp$ESS <- coda::effectiveSize(d_4)
  write.table(tmp, paste0(path, species, "/rhat_model4.csv"),
              sep = ",", row.names = FALSE)

  cat(paste0("Maximum rhat value is: ", tmp[which.max(tmp$point),"point"], "\n"))

  # do some standard pp_check and bayes_R2 computation
  r2 <- greta.checks::bayes_R2(y_mhb, mu_mhb, d_4)
  error <- greta.checks::rmse(y_mhb, mu_mhb, d_4, norm = TRUE)

  # put the two together
  r2_error <- as.data.frame(rbind(r2, error))
  r2_error$metric <- c("r2", "rmse")

  write.table(r2_error, paste0(path, species, "/rmse_model4.csv"),
              sep = ",", row.names = FALSE)

  ## compute breeding totals
  newdat <- expand.grid(fJahr = factor(2005:2019, levels = 2005:2019),
                        route_id = unique(route_id))
  # predicted model matrix
  modmat_pred <- model.matrix(~ fJahr,
                              newdat,
                              contrasts.arg = list(fJahr = "contr.sum"))
  mu_pred <- exp(modmat_pred[,-1] %*% yr_eff + route_avg[newdat$route_id])
  # calculate expectations
  d_pred <- t(as.matrix(calculate(mu_pred, values = d_4)))
  # some data wraggling
  d_df <- as.data.frame(d_pred)
  d_df$Jahr <- newdat$fJahr

  tt <- gather(d_df, key = "iteration", value = "val", -Jahr)

  tt %>%
    group_by(Jahr, iteration) %>%
    summarise(S = sum(val)) %>%
    ungroup() %>%
    group_by(Jahr) %>%
    summarise(M = mean(S), SD = sd(S),
              lo = quantile(S, probs = 0.025),
              hi = quantile(S, probs = 0.975)) -> tt_d

  write.table(tt_d, paste0(path, species, "/totals_model4.csv"),
              sep = ",", row.names = FALSE)

}

## function to fit model 6
fit_model6 <- function(species, path = "", ...){

  # filter Mhb data
  dat_mhb <-  filter(mhb, Artname == species)

  ## ornitho list
  dat_list_all <- subset(list_all, SPECIES_NAME == species)

  # ornitho unstr
  dat_unstr_all <- subset(unstr_all, SPECIES_NAME == species)
  dat_unstr_all$effort2 <- scale(dat_unstr_all$effort2) # std effort

  dat_mhb$fJahr2 <- factor(dat_mhb$Jahr, levels = 2005:2019)
  dat_list_all$fyear <- factor(dat_list_all$year,
                               levels = 2005:2019)

  dat_unstr_all$fyear <- factor(dat_unstr_all$year,
                                levels = 2005:2019)

  # the common year effect
  yr_eff_mhb <- model.matrix(~fJahr2, dat_mhb,
                             contrasts.arg = list(fJahr2 = "contr.sum"))
  yr_eff_list <- model.matrix(~fyear, dat_list_all,
                              contrasts.arg = list(fyear = "contr.sum"))
  yr_eff_unstr <- model.matrix(~fyear, dat_unstr_all,
                               contrasts.arg = list(fyear = "contr.sum"))

  # prior for common year effect
  yr_eff <- normal(0, 1, dim = ncol(yr_eff_mhb) - 1)

  ## model for mhb
  # index for routes
  route_id <- as.numeric(factor(dat_mhb$ROUTENCODE))

  # priors
  intercept_mhb <- student(3, 1.6, 2.5)
  sd_route <- exp(student(3, 0, 2.5))
  alpha_route <- normal(0, 1, dim = max(route_id))
  route_avg <- intercept_mhb + sd_route * alpha_route
  sd_res_mhb <- gamma(0.01, 0.01)

  # linear predictor
  mu_mhb <- exp(yr_eff_mhb[,-1] %*% yr_eff + route_avg[route_id])

  # re-param for negative binomial
  prob_mhb <- sd_res_mhb / (mu_mhb + sd_res_mhb)

  ## model for ornitho lists
  # index for locality
  locality_id <- as.numeric(factor(dat_list_all$ID_PLACE))
  # prior fixed effect
  intercept_list <- student(3, 0, 3.4)
  #dens_eff_list <- normal(0, 1)

  # prior for random effect
  sd_locality <- exp(student(3, 0, 3.4))
  alpha_locality <- normal(0, 1, dim = max(locality_id))
  locality_avg <- intercept_list + alpha_locality * sd_locality
  # zero inflation
  theta <- beta(1, 1)

  mu_list <- dat_list_all$effort_h * exp(yr_eff_list[,-1] %*% yr_eff +
                                           locality_avg[locality_id])

  ## model for ornitho unstr
  # index for raster cell

  raster_id <- as.numeric(factor(dat_unstr_all$ID_PLACE))
  # prior fixed effect
  intercept_unstr <- student(3, 1.6, 2.5)
  slp <- normal(0, 1)

  # prior for random effect
  sd_raster <- exp(student(3, 0, 2.5))
  alpha_raster <- normal(0, 1, dim = max(raster_id))
  raster_avg <- intercept_unstr + alpha_raster * sd_raster

  mu_unstr <- exp(slp * dat_unstr_all$effort2 +
                    yr_eff_unstr[,-1] %*% yr_eff + raster_avg[raster_id])

  # the response
  y_mhb <- as_data(dat_mhb$count)
  y_list <- as_data(dat_list_all$count)
  y_unstr <- as_data(dat_unstr_all$count)

  distribution(y_mhb) <- negative_binomial(prob = prob_mhb, size = sd_res_mhb)
  distribution(y_list) <- zero_inflated_poisson(theta = theta, lambda = mu_list, dim = length(y_list))
  distribution(y_unstr) <- poisson(mu_unstr)

  m_5 <- model(intercept_mhb, intercept_list, intercept_unstr,
               yr_eff, sd_res_mhb, theta, slp,
               sd_route, sd_locality, sd_raster)

  cat("Starting fitting model 5")
  t5_1 <- Sys.time()
  d_5 <- mcmc(m_5, ...)
  t5_2 <- Sys.time()

  #cat(paste0("Model 3: ", t2 - t1))

  # save the model
  saveRDS(d_5, paste0(path,  species,"/fit_model5.rds"))
  cat(paste0("Fitting time for ", species,
             ": ", round(as.numeric(difftime(t5_2, t5_1, units = "min")), 3),
             " min"))

  # compute rhat
  tmp <- as.data.frame(coda::gelman.diag(d_5)$psrf)
  tmp$species <- species
  names(tmp)[1:2] <- c("point", "upper")
  tmp$param <- rownames(tmp)
  rownames(tmp) <- NULL
  tmp$ESS <- coda::effectiveSize(d_5)
  write.table(tmp, paste0(path,  species, "/rhat_model5.csv"),
              sep = ",", row.names = FALSE)

  cat(paste0("Maximum rhat value is: ", tmp[which.max(tmp$point),"point"], "\n"))

  # compute R2 and normalized RMSE
  r2 <- greta.checks::bayes_R2(y_mhb, mu_mhb, d_5)
  error <- greta.checks::rmse(y_mhb, mu_mhb, d_5, norm = TRUE)

  # put the two together
  r2_error <- as.data.frame(rbind(r2, error))
  r2_error$metric <- c("r2", "rmse")

  write.table(r2_error, paste0(path,  species, "/rmse_model5.csv"),
              sep = ",", row.names = FALSE)

  ## compute breeding totals
  newdat <- expand.grid(fJahr = factor(2005:2019, levels = 2005:2019),
                        route_id = unique(route_id))
  # predicted model matrix
  modmat_pred <- model.matrix(~ fJahr,
                              newdat,
                              contrasts.arg = list(fJahr = "contr.sum"))
  mu_pred <- exp(modmat_pred[,-1] %*% yr_eff + route_avg[newdat$route_id])
  # calculate expectations
  d_pred <- t(as.matrix(calculate(mu_pred, values = d_5)))
  # some data wraggling
  d_df <- as.data.frame(d_pred)
  d_df$Jahr <- newdat$fJahr

  tt <- gather(d_df, key = "iteration", value = "val", -Jahr)

  tt %>%
    group_by(Jahr, iteration) %>%
    summarise(S = sum(val)) %>%
    ungroup() %>%
    group_by(Jahr) %>%
    summarise(M = mean(S), SD = sd(S),
              lo = quantile(S, probs = 0.025),
              hi = quantile(S, probs = 0.975)) -> tt_d

  write.table(tt_d, paste0(path,  species, "/totals_model5.csv"),
              sep = ",", row.names = FALSE)

}


# Make a full-raster prediction using Random Forest

library(ranger)
library(tools)
library(raster)
source("utils/set-temp-path.r")
source("utils/load-data.r")

if (!exists("Cores"))
    Cores = 31
if (!exists("TempDir"))
    TempDir = "../../userdata/temp/"
if (!exists("OutputDir"))
    OutputDir = "../../userdata/predictions/"

if (!exists("Extent"))
    Extent = NULL
if (!exists("Exclude"))
    Exclude = c("osavi", "aspect", "is.water", "height")
if (exists("CovariateDir"))
{
    TrainingRasters = LoadTrainingRasters(extent=Extent, basedir=CovariateDir)
} else {
    TrainingRasters = LoadTrainingRasters(extent=Extent)
}
if (!exists("ClassesToPredict"))
{
    ClassesToPredict = GetValidationNames()
}
if (!exists("Alpha"))
    Alpha = 0.9
if (!exists("MinProp"))
    MinProp = 0.11

TrainingNames = GetTrainingNames(exclude=Exclude)
alldata = LoadClassificationData()

RP = function(...)
{
    psnice(value = min(Cores - 1, 19))
    rp = predict(...)
    return(rp$predictions)
}

FullFormula = paste0("~", paste(TrainingNames, collapse = "+"))
AllPredictions = stack()
print("Starting prediction phase 1...")
for (Class in ClassesToPredict)
{
    print(Class)
    Formula = update.formula(FullFormula, paste0(Class, " ~ ."))
    if (exists("GetVariableImportance") && GetVariableImportance)
    {
        rfmodel = ranger(Formula, alldata@data, splitrule="maxstat", alpha=Alpha, minprop=MinProp, importance="permutation", seed=0xbadcafe)
        print(rfmodel$prediction.error)
        print(importance(rfmodel))
        barplot(importance(rfmodel), main=Class)
    } else {
        rfmodel = ranger(Formula, alldata@data, splitrule="maxstat", alpha=Alpha, minprop=MinProp, seed=0xbadcafe)
    }

    print(system.time(predicted <- predict(TrainingRasters, rfmodel, fun=RP, num.threads=Cores,
        filename=paste0(TempDir, Class, ".grd"), progress="text", overwrite=TRUE, seed=0xbadcafe)))

    AllPredictions = stack(AllPredictions, predicted)
}

# Only scale the predictions to 100% if we have all classes
if (length(ClassesToPredict) >= 9)
{
    print("Starting prediction phase 2...")
    RasterScaling = function(x)
    {
        return(round(x / sum(x) * 100))
    }
    system.time(ScaledPredictions <- calc(AllPredictions, RasterScaling, progress="text"))
    names(ScaledPredictions) = GetValidationNames()
    print("Writing...")
    ScaledPredictions = writeRaster(ScaledPredictions, filename = paste0(OutputDir, "randomforest.tif"),
        datatype="INT1U", options=c("COMPRESS=DEFLATE", "ZLEVEL=9", "NUMTHREADS=4"), overwrite=TRUE)
    hdr(ScaledPredictions, "VRT")
} else {
    writeRaster(AllPredictions, filename = paste0(OutputDir, "randomforest.tif"),
        datatype="INT1U", options=c("COMPRESS=DEFLATE", "ZLEVEL=9", "NUMTHREADS=4"), overwrite=TRUE)
}


#' tglob_sphere
#'
#' Calculate the globe temperature in degC.
#' The code is based on the work James C. Liljegren Decision and Information Sciences Division Argonne National Laboratory.
#'
#'
#' @param t numeric        Air temperature in degC.
#' @param rh numeric       Relative humidity in percentage.
#' @param wind numeric     Mean Wind speed in meter per second.
#' @param solar  numeric   Global solar radiation in Watt on mq.
#' @param zenith numeric   Zenith angle in decimal degrees.
#' @param pair numeric     Air pressure in millibar or hPa. Default 1010 hPa.
#' @param alb_sfc numeric  Mean albedo of surroundings. Default is 0.4.
#' @param fdir numeric     Ratio of directed solar respect to the diffuse.Default is 0.8.
#' @param diam numeric     Diameter in meter of globometer. Default is 0.05.
#' @param maxair numeric   Upper bound of search range referred to air temperature in degC. Default is 10
#' @param minair numeric   Lower bound of search range referred to air temperature in degC. Default is 10
#' @param prec numeric      Precision of outcomes.Default is 0.01
#' @return globe temperature in degC
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @references Liljegren J, Carhart R, Lawday P, Tschopp S, Sharp R,2008, "Modeling Wet Bulb Globe Temperature using Standard Meteorological Measurements" Journal of Occupational and Environmental Hygiene 5, 645-655.
#' @keywords   Globometric temperature.
#'
#' @export
#'
#'

tglob_sphere=function(t,rh,wind,solar,zenith=0,pair=1010,alb_sfc=0.4,fdir=0.8,diam=0.05,maxair=10,minair=2,prec=0.01) {

                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$assign("speed", as.array(wind))
                         ct$assign("solar", as.array(solar))
                         ct$assign("pair", as.array(pair))
                         ct$assign("fdir", as.array(fdir))
                         ct$assign("zenith", as.array(zenith))
                         ct$assign("diam", as.array(diam))
                         ct$assign("alb_sfc", as.array(alb_sfc))
                         ct$assign("maxair", as.array(maxair))
                         ct$assign("minair", as.array(minair))
                         ct$assign("prec", as.array(prec))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=tglob_sphere(t[i],rh[i],speed[i],solar[i],zenith[i],pair[0],alb_sfc[0],fdir[0],diam[0],maxair[0],minair[0],prec[0])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


  landings.decomposed = function( p, sex, REGION) {

    # observer data
    odb = observer.db("odb")

    sizes = mean.weights.by.category( p )  # use the previously saved file

    catch.odb = observer.get.counts.by.class( p, odb[polygon_inside(odb,aegis.polygons::polygon_internal_code( REGION )) ,] )
    cl = make.classes(sex)

    # obtain landings
    fishery.stats = get.fishery.stats.by.region( Reg=REGION, y=p$fisheryyears )

    fishing = array( data=0, dim=c(length(cl$yclass), length(cl$cats), length(p$fisheryyears)),
                    dimnames=list(cl$yclass, cl$cats, p$fisheryyears) )

    for (jj in p$fisheryyears) {
      kk = which(catch.odb$yr==jj)
      if ( length(kk) == 0 ) next()
      catch.odb.yr = catch.odb[kk, ]
      catch.N = convert.to.vector(catch.odb.yr, p$nodes, type="observer.data" )
      catch.bio.est = estimate.biomass (catch.N, catch.N*0.01, sizes, y=jj, r=REGION)
      catch.B = catch.bio.est$x
      total.observed.biomass =  sum(catch.B, na.rm=T)

      catch.rescaled =  catch.B /total.observed.biomass

      catch.total =  catch.rescaled * fishery.stats$landings[ which(fishery.stats$yr==jj) ] * 1000 # 1000 is to convert kg to tons
      FM.N = estimate.number( catch.total, catch.bio.est$error, sizes, y=jj, r=REGION)
      fishing[,,as.character(jj)] = nodes2matrix (FM.N$x, cl)
    }

    return (fishing)
  }


library(shiny)
library(ggplot2)

options(warn=-1)

ui <- fluidPage(
  #shinythemes::themeSelector(),
  titlePanel("S3 Cost Calculator"),

  p("This cost calculator is intended to be used to estimate and compare the costs of storage, upload, and data retrieval for each of the S3 storage classes. The page tabs represent each of the S3 storage classes currently available in AWS."),
  p("To begin, click one of the storage class tabs and input the information listed."),

  tabsetPanel(type="tab",

              tabPanel("Standard",br(),
                       p("Standard is the default storage class which is designed for frequently accessed data."),
                       sidebarLayout(

                         sidebarPanel(

                           fluidRow(column(12, h4("Total Amount of Storage") )),
                           fluidRow(
                             column(5,
                                    textInput("stdStorage", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("stdUnit1", NULL,
                                                choices = c("GB","TB","PB"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(12, h4("Total Number of Objects") )),
                           fluidRow(
                             column(5,
                                    textInput("stdObj", NULL, width="225px",value=0)
                             )
                           ),
                           fluidRow(column(12, h4("Data Retrieval Amount") )),
                           fluidRow(
                             column(5,
                                    textInput("stdRetrieval", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("stdUnit2", NULL,
                                                choices = c("GB","TB","PB","%"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(12, h4("Storage Growth") )),
                           fluidRow(
                             column(5,
                                    textInput("stdGrowth", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("stdUnit3", NULL,
                                                choices = c("GB","TB","PB","%"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(8,align="center",h4("Months to View") )),
                           fluidRow(
                             column(8,align="center",
                                    sliderInput('stdMonths',NULL,min=3,max=36,value=3)
                             )
                           ),
                           fluidRow(column(12, h4("Copy Inputs Into:") )),
                           fluidRow(
                             column(5, selectInput("copySelect1", NULL,
                                                   choices = c("All","Infrequent Access","One Zone-IA","Glacier","Glacier-Deep Archive"),width="225px")
                             ),
                             column(6, actionButton("copy1","Copy",width="65px")
                             )

                           ),
                           actionButton("clr1","Clear")
                         ),
                         mainPanel(
                           plotOutput("stdPlot",width="80%"),br(),
                           tableOutput("stdTable")
                         )
                       )
              ),

              tabPanel("Infrequent Access",br(),
                       p("Infrequent Access is designed for data that is accessed less frequently, but requires rapid access when needed."),
                       sidebarLayout(

                         sidebarPanel(

                           fluidRow(column(12, h4("Total Amount of Storage") )),
                           fluidRow(
                             column(5,
                                    textInput("IAStorage", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("IAUnit1", NULL,
                                                choices = c("GB","TB","PB"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(12, h4("Total Number of Objects") )),
                           fluidRow(
                             column(5,
                                    textInput("IAObj", NULL, width="225px",value=0)
                             )
                           ),
                           fluidRow(column(12, h4("Data Retrieval Amount") )),
                           fluidRow(
                             column(5,
                                    textInput("IARetrieval", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("IAUnit2", NULL,
                                                choices = c("GB","TB","PB","%"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(12, h4("Storage Growth") )),
                           fluidRow(
                             column(5,
                                    textInput("IAGrowth", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("IAUnit3", NULL,
                                                choices = c("GB","TB","PB","%"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(8,align="center",h4("Months to View") )),
                           fluidRow(
                             column(8,align="center",
                                    sliderInput('IAMonths',NULL,min=3,max=36,value=3)
                             )
                           ),
                           fluidRow(column(12, h4("Copy Inputs Into:") )),
                           fluidRow(
                             column(5, selectInput("copySelect2", NULL,
                                                   choices = c("All","Standard","One Zone-IA","Glacier","Glacier-Deep Archive"),width="225px")
                             ),
                             column(6, actionButton("copy2","Copy",width="65px")
                             )

                           ),
                           actionButton("clr2","Clear")
                         ),
                         mainPanel(
                           plotOutput("IAPlot",width="80%"),br(),
                           tableOutput("IATable")
                         )
                       )
              ),
              tabPanel("One Zone-IA",br(),
                       p("One Zone-Infrequent Access is designed similarly to Infrequent Access, but unlike other storage class which store data in a minimum of three Availability Zones, One Zone-IA stores data in a single Availability Zone."),
                       sidebarLayout(

                         sidebarPanel(

                           fluidRow(column(12, h4("Total Amount of Storage") )),
                           fluidRow(
                             column(5,
                                    textInput("OIAStorage", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("OIAUnit1", NULL,
                                                choices = c("GB","TB","PB"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(12, h4("Total Number of Objects") )),
                           fluidRow(
                             column(5,
                                    textInput("OIAObj", NULL, width="225px",value=0)
                             )
                           ),
                           fluidRow(column(12, h4("Data Retrieval Amount") )),
                           fluidRow(
                             column(5,
                                    textInput("OIARetrieval", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("OIAUnit2", NULL,
                                                choices = c("GB","TB","PB","%"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(12, h4("Storage Growth") )),
                           fluidRow(
                             column(5,
                                    textInput("OIAGrowth", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("OIAUnit3", NULL,
                                                choices = c("GB","TB","PB","%"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(8,align="center",h4("Months to View") )),
                           fluidRow(
                             column(8,align="center",
                                    sliderInput('OIAMonths',NULL,min=3,max=36,value=3)
                             )
                           ),
                           fluidRow(column(12, h4("Copy Inputs Into:") )),
                           fluidRow(
                             column(5, selectInput("copySelect3", NULL,
                                                   choices = c("All","Standard","Infrequent Access","Glacier","Glacier-Deep Archive"),width="225px")
                             ),
                             column(6, actionButton("copy3","Copy",width="65px")
                             )

                           ),
                           actionButton("clr3","Clear")
                         ),
                         mainPanel(
                           plotOutput("OIAPlot",width="80%"),br(),
                           tableOutput("OIATable")
                         )
                       )
              ),
              tabPanel("Glacier",br(),
                       p("Glacier is a low-cost data archiving solution and provides three retrieval options of varying speed."),
                       sidebarLayout(

                         sidebarPanel(

                           fluidRow(column(12, h4("Total Amount of Storage") )),
                           fluidRow(
                             column(5,
                                    textInput("glacierStorage", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("glacierUnit1", NULL,
                                                choices = c("GB","TB","PB"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(12, h4("Total Number of Objects") )),
                           fluidRow(
                             column(5,
                                    textInput("glacierObj", NULL, width="225px",value=0)
                             )
                           ),
                           fluidRow(column(12, h4("Data Retrieval Amount") )),
                           fluidRow(
                             column(5,
                                    textInput("glacierRetrieval", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("glacierUnit2", NULL,
                                                choices = c("GB","TB","PB","%"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(12, h4("Retrieval Speed") )),
                           fluidRow(
                             column(7,
                                    selectInput("glacierSpeed", NULL,
                                                choices = c("Expedited","Standard","Bulk"), selected = "Standard",width="225px")
                             )
                           ),
                           fluidRow(column(12, h4("Storage Growth") )),
                           fluidRow(
                             column(5,
                                    textInput("glacierGrowth", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("glacierUnit3", NULL,
                                                choices = c("GB","TB","PB","%"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(8,align="center",h4("Months to View") )),
                           fluidRow(
                             column(8,align="center",
                                    sliderInput('glacierMonths',NULL,min=3,max=36,value=3)
                             )
                           ),
                           fluidRow(column(12, h4("Copy Inputs Into:") )),
                           fluidRow(
                             column(5, selectInput("copySelect4", NULL,
                                                   choices = c("All","Standard","Infrequent Access","One Zone-IA","Glacier-Deep Archive"),width="225px")
                             ),
                             column(6, actionButton("copy4","Copy",width="65px")
                             )

                           ),
                           actionButton("clr4","Clear")
                         ),
                         mainPanel(
                           plotOutput("glacierPlot",width="80%"),br(),
                           tableOutput("glacierTable")
                         )
                       )
              ),
              tabPanel("Glacier-Deep Archive",br(),
                       p("Glacier-Deep Archive is designed for long-term data storage that is accessed once or twice in a year with two retrieval speeds to choose from."),
                       sidebarLayout(

                         sidebarPanel(

                           fluidRow(column(12, h4("Total Amount of Storage") )),
                           fluidRow(
                             column(5,
                                    textInput("DAStorage", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("DAUnit1", NULL,
                                                choices = c("GB","TB","PB"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(12, h4("Total Number of Objects") )),
                           fluidRow(
                             column(5,
                                    textInput("DAObj", NULL, width="225px",value=0)
                             )
                           ),
                           fluidRow(column(12, h4("Data Retrieval Amount") )),
                           fluidRow(
                             column(5,
                                    textInput("DARetrieval", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("DAUnit2", NULL,
                                                choices = c("GB","TB","PB","%"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(12, h4("Retrieval Speed") )),
                           fluidRow(
                             column(7,
                                    selectInput("DASpeed", NULL,
                                                choices = c("Standard","Bulk"), selected = "Standard",width="225px")
                             )
                           ),
                           fluidRow(column(12, h4("Storage Growth") )),
                           fluidRow(
                             column(5,
                                    textInput("DAGrowth", NULL,width="225px",value=0)
                             ),
                             column(6,
                                    selectInput("DAUnit3", NULL,
                                                choices = c("GB","TB","PB","%"), selected = "GB",width="65px")
                             )
                           ),
                           fluidRow(column(8,align="center",h4("Months to View") )),
                           fluidRow(
                             column(8,align="center",
                                    sliderInput('DAMonths',NULL,min=3,max=36,value=3)
                             )
                           ),
                           fluidRow(column(12, h4("Copy Inputs Into:") )),
                           fluidRow(
                             column(5, selectInput("copySelect5", NULL,
                                                   choices = c("All","Standard","Infrequent Access","One Zone-IA","Glacier"),width="225px")
                             ),
                             column(6, actionButton("copy5","Copy",width="65px")
                             )

                           ),
                           actionButton("clr5","Clear")
                         ),
                         mainPanel(
                           plotOutput("DAPlot",width="80%"),br(),
                           tableOutput("DATable")
                         )
                       )
              ),
              tabPanel("Storage Class Comparison",br(),
                       p("Easily compare the storage, upload, data retrieval, and total cumulative costs of the different storage classes based on the inputs provided."),
                       sidebarLayout(

                         sidebarPanel(

                           fluidRow(column(8,align="center",h4("Months to View") )),
                           fluidRow(
                             column(8,
                                    sliderInput('compMonths',NULL,min=3,max=36,value=3)
                             )
                           )
                         ),
                         mainPanel(
                           tabsetPanel(type = "tab",
                                       tabPanel("Totals",br(),plotOutput("compPlotTotals",width="80%"),br(),tableOutput("compTableTotals")),
                                       tabPanel("Storage",br(),plotOutput("compPlotStorage",width="80%"),br(),tableOutput("compTableStorage")),
                                       tabPanel("Upload",br(),plotOutput("compPlotUpload",width="80%"),br(),tableOutput("compTableUpload")),
                                       tabPanel("Data Retrieval",br(),plotOutput("compPlotDataRetrieval",width="80%"),br(),tableOutput("compTableDataRetrieval"))

                           )
                         )
                       )
                     ),

              tabPanel("Instructions",br(),

                       p("The following instructions explain how to use the cost calculator in further detail."),
                       h4("Total Amount of Storage"),
                       tags$li("Input the total amount of storage being uploaded into S3"),
                       tags$li("Select the storage unit (GB, TB, or PB)"),
                       h4("Total Number of Objects"),
                       tags$li("Input the total number of objects/files that make up the amount of storage inputted"),
                       h4("Data Retrieval Amount"),
                       tags$li("Input the estimated amount of monthly data retrieval"),
                       tags$li("Select the storage unit (GB, TB, PB, or %)"),
                       tags$li("Selecting % will calculate the monthly data retrieval amount as a percentage of the total amount of storage"),
                       h4("Storage Growth"),
                       tags$li("Input the estimated amount of monthly storage growth"),
                       tags$li("Select the storage unit (GB, TB, PB, or %)"),
                       tags$li("Selecting % will calculate the monthly growth amount as a percentage of the total amount of storage"),
                       h4("Months to View"),
                       tags$li("Use the slider to indicate how many months to show on the plots and tables"),
                       tags$li("Choose between 3 and 36 months"),
                       h4("Copy Inputs"),
                       tags$li("Once all the inputs are entered for a given storage class, the inputs can be copied over to other storage classes"),
                       tags$li("Select which storage classes the inputs should be copied to then click the Copy button"),
                       tags$li("Selecting All will copy the inputs to all other storage classes"),
                       h4("Retrieval Speed (Glacier & Glacier-Deep Archive Only)"),
                       tags$li("Select the retrieval speed interested in using for data retrievals"),
                       tags$li("Defaults to Standard"),
                       h4("Storage Class Comparison Tab"),
                       tags$li("Use this tab to easily compare each of the storage classes separated by storage, upload, data retrieval, and cumulative costs")
              )
  )
)


#' t
#'
#' Transpose a shaq or tshaq distributed matrix.
#'
#' @section Communication:
#' The operation is completely local.
#'
#' @param x
#' A shaq or tshaq.
#'
#' @return
#' A tshaq or shaq (opposite of what was input).
#'
#' @examples
#' \dontrun{
#' library(kazaam)
#' x = ranshaq(runif, 10, 3)
#'
#' t(x)
#'
#' finalize()
#' }
#'
#' @name t
#' @rdname t
NULL

#' @rdname t
#' @method t shaq
#' @export
t.shaq = function(x)
{
  data = t(DATA(x))
  tshaq(data, ncol(x), nrow(x), checks=FALSE)
}

#' @rdname t
#' @method t tshaq
#' @export
t.tshaq = function(x)
{
  data = t(DATA(x))
  shaq(data, ncol(x), nrow(x), checks=FALSE)
}


# !/usr/bin/Rscript

#' Utility function to plot multiple ROC curves against each other. Wraps the
#' *roc* method of the pROC package.
#'
#'   - Comparison helps determine which models favour more TPs or less FPs
#'   - Curves are shown overlaid in the same panel upto a max threshold, upon
#'     when a new panel will be created.
#'   - Refer to pROC#roc method documentation for further information on the
#'     *res*, *predictor*, and *cv* parameters.
#'
#' @param models    {List}   - List of model objects (models expected to have
#'                             been trained with the ROC performance metric).
#' @param res       {String} - The response variable to predict.
#' @param cv        {Data}   - Dataset containing variables in the formula.
#' @param labels    {List}   - *Optional*; List of labels for each model
#' @param colors    {List}   - *Optional*; List of colors for each model
#' @param maxCurves {Number} - *Optional*; # curves per panel, defaults to 3.
#' @export
#' @examples
#' plotROC(
#'   models    = list(glmFit, rfFit)
#'   res       = "Foo",
#'   cv        = validDf,
#'   colors    = c("black", "orange")
#' )

library(pROC)

plotROC <- function(models, res, cv, colors, labels, maxCurves = 3) {

  len    <- length(models)
  scores <- list()
  panels <- max(c(ceiling(len/maxCurves), 1))
  par(mfrow=c(1, panels))

  for (i in 1:len) {
    model <- models[[i]]
    label <- if (length(labels) < i) model$method else labels[[i]]
    auc   <- round(max(model$result$ROC), digits=4)
    color <- if (length(colors) < i) rainbow(i) else colors[[i]]

    # track panels
    isLimit <- i > maxCurves & maxCurves %% (i-1) == 0
    isFirst <- i == 1
    isLast  <- i == len

    # predict and generate curve
    predProb <- as.numeric(predict(model, cv, type="prob"))

    curve <- roc(
      response  = cv[[res]],
      predictor = predProb[[res]],
      levels    = levels(cv[[res]])
    )

    # create labels
    scores[[length(scores)+1]] <- paste(label, auc, sep=" - ")

    if (isLimit) {
      a <- i - maxCurves
      b <- i - 1

      legend("bottomright",
        legend=scores[a:b],
        lwd=c(2,2),
        col=colors[a:b]
      )
    }

    # draw curve and manage partitions
    if (isFirst | isLimit) {
      plot(curve, type="S", col=color, ylim=c(0,1))
    } else {
      plot(curve, add=TRUE, col=color)
    }

    if (isLast) {
      a <- i - ((i - (maxCurves * (panels-1))) - 1)
      b <- i

      legend("bottomright",
        legend=scores[a:b],
        lwd=c(2,2),
        col=colors[a:b]
      )
    }
  }
}