##############################
## Install missing packages ##
##############################

set.seed(47269801)

required.packages <- c("dplyr", "multiwayvcov", "multcomp", "reshape2", "knitr")
packages.missing <- required.packages[!required.packages %in% installed.packages()[,"Package"]]

if(length(packages.missing) > 0) {install.packages(required.packages, repo="https://cran.cnr.berkeley.edu/")}
lapply(required.packages, library, character.only = TRUE)

######################
## Define functions ##
######################

## RegTest conducts asymptotic tests from linear model ##

RegTest <- function(equation, clustvars, hypotheses, data) {

    model <- lm(equation, data = data, na.action = na.omit)

    if (missing(clustvars)) model$vcov <- vcov(model)
    else model$vcov <- cluster.vcov(model, cluster = clustvars)

    model$test <- summary(glht(model, linfct = hypotheses, vcov = model$vcov))$test

    numhyp <- length(hypotheses)

    EST <- matrix(nrow = numhyp, ncol = 4)

    for (i in 1:numhyp) {

        EST[i, 1] <- model$test$coefficients[i]
        EST[i, 2] <- model$test$tstat[i]
        EST[i, 3] <- model$test$sigma[i]
        EST[i, 4] <- model$test$pvalues[i]

    }

    colnames(EST) <- c("Estimate", "Tstat", "SE", "P")

    return(EST)

}

## PermTest returns MC approximations of the exact p-value ##

PermTest <- function(equation, treatvars, clustvars, hypotheses, iterations, data) {

    stopifnot(length(hypotheses) <= 1)

    obsEST <- RegTest(equation, clustvars, hypotheses, data)
    obsStat <- obsEST[1, 2]

    simEST <- matrix(ncol = 4)

    for (i in 1:iterations) {

        simTreat <- data[, treatvars, drop = FALSE]
        simTreat <- simTreat[sample(nrow(simTreat)),]

        simData <- cbind(simTreat, data[, !(names(data) %in% treatvars), drop = FALSE])
        colnames(simData)[1:length(treatvars)] <- treatvars

        simEST <- rbind(simEST, RegTest(equation, clustvars, hypotheses, data = simData))

    }

    simSTAT <- simEST[2:nrow(simEST), 2]
    countSTAT <- matrix(abs(simSTAT) >= abs(obsStat), ncol = 1)

    ExactP <- colSums(countSTAT) / iterations

    EST <- cbind(obsEST, ExactP)

    colnames(EST) <- c("Estimate", "Tstat", "SE", "P", "ExactP")

    return(EST)

}

## FDR returns minimum q-values ##

FDR <- function(pvals, step) {

    if (sum(is.na(pvals) == FALSE) <= 1) {return(pvals)}
    if (missing(step)) {step <- 0.001}

    allpvals <- cbind(as.matrix(pvals), matrix(1:nrow(as.matrix(pvals)), ncol = 1))

    pvals <- na.omit(allpvals)
    nump <- nrow(pvals)

    pvals <- pvals[order(pvals[, 1]), ]
    rank <- matrix(1:nump, ncol = 1)
    pvals <- cbind(pvals, rank, matrix(0, nrow = nump, ncol = 1))

    qval <- 1

    while (qval > 0) {

        qfirst <- qval / (1 + qval)
        fdrtemp <- (qfirst * rank) / nump

        subrank <- which(fdrtemp >= as.matrix(pvals[, 1]))

        if (length(subrank) < 1) {
            numreject <- 0
        } else numreject <- max(subrank)

        qsec <- qfirst * (nump / (nump - numreject))
        fdrtemp <- (qsec * rank) / nump

        subrank <- which(fdrtemp >= as.matrix(pvals[, 1]))

        if (length(subrank) < 1) {
            numreject <- 0
        } else numreject <- max(subrank)

        pvals[which(pvals[, 3] <= numreject), 4] <- qval

        qval <- qval - step

    }

    pvals <- pvals[order(pvals[, 2]), ]

    qvals <- matrix(nrow = nrow(allpvals), ncol = 1)
    qvals[match(pvals[, 2], allpvals[, 2]), 1] <- pvals[, 4]

    return(as.matrix(qvals))

}

## Interact returns a string of interacted variables ##

Interact <- function(d, x) {

    catstring <- ""

    for (var in x) {

        catstring <- paste(catstring, " + ", d, "*", var, sep = "")

    }

    return(substr(catstring, 3, nchar(catstring)))

}

################
## Clean data ##
################

varnames <- as.vector(read.delim(file = "K1__Field_Survey_v34+35_Appended.csv", sep = ",", header = FALSE, stringsAsFactors = FALSE, na.strings = "", nrows = 1))
k1_df <- read.delim(file = "K1__Field_Survey_v34+35_Appended.csv", sep = ",", header = FALSE, stringsAsFactors = FALSE, na.strings = "", skip = 2, nrows = 600, col.names = varnames)

## Survey meta data ##

k1_df$start.time.mst <- as.POSIXct(as.character(k1_df$V3), format = "%m/%d/%y %H:%M")
k1_df$start.time.eat <- k1_df$start.time.mst + (3600 * 9)

k1_df$end.time.mst <- as.POSIXct(as.character(k1_df$V4), format = "%m/%d/%y %H:%M")
k1_df$end.time.eat <- k1_df$end.time.mst + (3600 * 9)

## Participant ID ##

k1_df$survey.id <- k1_df$V1
k1_df <- k1_df[complete.cases(k1_df$survey.id), ]

nonentry <- c("R_5ZkChbiXDIj6KsK", "R_7N8rNtLsxF5a9on", "R_97Tx2cAjy30fqMR", "R_lYnRvOAJhuax6LS", "R_8dky4iSC7rfEuNc", "R_nczo7KPxLkkKkgo", "R_5j1OiNu3wMp265N", "R_0GYX0scNN16ICfQ", "R_6PoFtAhwvSBNYzi", "R_696kAyWai9bDkFI", "R_hPaLwAaYCnY0l69", "R_oGNBAVexMWYhMml", "R_3rwTGdEULwOGH2y", "R_bhNv0SnArTa32Xe", "R_5txHVIbQY6twLIZ", "R_kaSM6nunZ9Ynatj", "R_0ppcidBVCPaEkXK", "R_oWceQFJG5NnSokN", "R_h5Cw4tvVUeDY8NI", "R_9ib4ASBi450NZPt", "R_mAlfPdxj5GQsJF5", "R_kbW6NDTS1FWXyn3", "R_b1GC7jpoQrJKrFN", "R_5YpNpbPWOxnSNWc", "R_mwLFSjScVyrgs9J", "R_1jbOtmMIrvgTgaE", "R_if5tz3h1N9MzTp2", "R_aFmo1jRrWIwsLjI", "R_2itxVUcUstO3Syp", "R_9LP4exOnWpJ1TrE", "R_cQLu9PDCtFwbn7K", "R_oFl39knSVL3SKpz", "R_11Y1KTzawxBJmvy")
k1_df <- k1_df[! k1_df$survey.id %in% nonentry, ]

## Treatment assignment ##

k1_df$treat[k1_df$condition == "poor"] <- 0
k1_df$treat[k1_df$condition == "individual"] <- 1
k1_df$treat[k1_df$condition == "community"] <- 2
k1_df$treat <- factor(k1_df$treat, labels = c("Pov", "Ind", "Com"))

k1_df$pov <- ifelse(k1_df$condition == "poor", 1, 0)
k1_df$ind <- ifelse(k1_df$condition == "individual", 1, 0)
k1_df$com <- ifelse(k1_df$condition == "community", 1, 0)

k1_df$msg1 <- recode(as.numeric(as.factor(k1_df$ORG_MESSAGE)), `2` = 0, `3` = 2)
k1_df$msg2 <- recode(as.numeric(as.factor(k1_df$ORG_MESSAGE_2)), `2` = 0)
k1_df$msg3 <- recode(as.numeric(as.factor(k1_df$ORG_MESSAGE_3)), `3` = 2)

## Self-efficacy ##

for (var in c(k1_df$sel.con, k1_df$sel.pers, k1_df$sel.com, k1_df$sel.prob, k1_df$sel.bett)) {

    var[var < 0] <- NA

}

k1_df$sel.score <- scale(k1_df$sel.con) + scale(k1_df$sel.pers) + scale(k1_df$sel.com) + scale(k1_df$sel.prob) + scale(k1_df$sel.bett)
k1_df$sel.score.z <- scale(k1_df$sel.score)

## Stigma ##

for (var in c(k1_df$jud.fam, k1_df$jud.com, k1_df$jud.judg, k1_df$jud.emb, k1_df$jud.ups)) {

    var[var < 0] <- NA

}

k1_df$sti.score <- scale(6 - k1_df$jud.fam) + scale(6 - k1_df$jud.com) + scale(k1_df$jud.judg) + scale(k1_df$jud.emb) + scale(k1_df$jud.ups)
k1_df$sti.score.z <- scale(k1_df$sti.score)

## Affect ##

for (var in c(k1_df$aff.pos, k1_df$aff.ash, k1_df$aff.pow, k1_df$aff.fina)) {

    var[var < 0] <- NA

}

k1_df$aff.score <- scale(k1_df$aff.pos) + scale(k1_df$aff.pow) + scale(7 - k1_df$aff.ash) + scale(7 - k1_df$aff.fina)
k1_df$aff.score.z <- scale(k1_df$aff.score)

## Video selection ##

k1_df$vid.imp1 <- k1_df$vid.dec1 %in% c(3, 5)
k1_df$vid.imp2 <- k1_df$vid.dec2 %in% c(3, 5)
k1_df$vid.num <- k1_df$vid.imp1 + k1_df$vid.imp2

## Intertemporal choice ##

k1_df$sav.save <- k1_df$sav.dec > 1
k1_df$sav.save[k1_df$sav.dec < 0] <- NA

k1_df$sav.amt[k1_df$sav.dec == 1] = 0
k1_df$sav.amt[k1_df$sav.dec == 2] = 100
k1_df$sav.amt[k1_df$sav.dec == 3] = 200
k1_df$sav.amt[k1_df$sav.dec < 0] <- NA

## Query theory (savings) ##

que_df <- k1_df[names(k1_df) %in% c("survey.id", "que.rat1", "que.rat2", "que.rat3", "que.rat4", "que.rat5")]

k1_df$que.nonm <- apply(que_df[, 1:5], 1, function(x) length(x[is.na(x) == FALSE]))

que_df <- melt(que_df, id = c("survey.id"))
que_df$variable <- as.numeric(que_df$variable)
que_df <- dcast(que_df[is.na(que_df$value) == FALSE & que_df$value > 0, ], survey.id ~ value, median, value.var = "variable")
names(que_df) <- c("survey.id", "que.mri", "que.mrp")
k1_df <- merge(k1_df, que_df, all.x = TRUE)

k1_df$que.smrd <- (2 * (k1_df$que.mrp - k1_df$que.mri)) / k1_df$que.nonm
k1_df$que.smrd[is.na(k1_df$que.mrp)] <- 1
k1_df$que.smrd[is.na(k1_df$que.mri)] <- -1

# dealing with missing by filling in upper/lower bounds for now

## Message of support ##

k1_df$msg.dec[k1_df$msg.dec < 0] = NA
k1_df$msg.dec <- k1_df$msg.dec - 1

k1_df$msg.emp[k1_df$msg.emp < 0] = NA

k1_df$msg.lik[k1_df$msg.lik < 0] = NA
k1_df$msg.lik <- 7 - k1_df$msg.lik

k1_df$msg.avg <- (k1_df$msg.emp + k1_df$msg.lik) / 2

## Frame evaluation ##

k1_df$eva.poor[k1_df$msg1 == 0] <- k1_df$eva.msg1[k1_df$msg1 == 0]
k1_df$eva.poor[k1_df$msg2 == 0] <- k1_df$eva.msg2[k1_df$msg2 == 0]
k1_df$eva.poor[k1_df$msg3 == 0] <- k1_df$eva.msg3[k1_df$msg3 == 0]

k1_df$eva.ind[k1_df$msg1 == 1] <- k1_df$eva.msg1[k1_df$msg1 == 1]
k1_df$eva.ind[k1_df$msg2 == 1] <- k1_df$eva.msg2[k1_df$msg2 == 1]
k1_df$eva.ind[k1_df$msg3 == 1] <- k1_df$eva.msg3[k1_df$msg3 == 1]

k1_df$eva.com[k1_df$msg1 == 2] <- k1_df$eva.msg1[k1_df$msg1 == 2]
k1_df$eva.com[k1_df$msg2 == 2] <- k1_df$eva.msg2[k1_df$msg2 == 2]
k1_df$eva.com[k1_df$msg3 == 2] <- k1_df$eva.msg3[k1_df$msg3 == 2]

k1_df$eva.vid.poor <- k1_df$eva.rank.vid_8
k1_df$eva.vid.ind <- k1_df$eva.rank.vid_9
k1_df$eva.vid.com <- k1_df$eva.rank.vid_10

k1_df$eva.conf[k1_df$eva.conf < 0] <- NA

k1_df$eva.emp.poor <- k1_df$eva.rank.emp_5
k1_df$eva.emp.ind <- k1_df$eva.rank.emp_6
k1_df$eva.emp.com <- k1_df$eva.rank.emp_7

## Ladder scales ##

k1_df$ses.lad.now[k1_df$ses.lad.now < 0] <- NA
k1_df$ses.lad.now.z <- scale(k1_df$ses.lad.now)

k1_df$ses.lad.y2[k1_df$ses.lad.y2 < 0] <- NA
k1_df$ses.lad.y2.z <- scale(k1_df$ses.lad.y2)

k1_df$ses.lad.diff <- k1_df$ses.lad.y2 - k1_df$ses.lad.now
k1_df$ses.lad.avg <- (k1_df$ses.lad.y2 + k1_df$ses.lad.now) / 2

## Sociodemographics ##

k1_df$soc.age[k1_df$soc.age < 0] <- NA
k1_df$soc.pri <- as.numeric(k1_df$soc.edu > 3)
k1_df$soc.fem <- k1_df$soc.gen - 1
k1_df$soc.chr <- k1_df$soc.rel %in% c(1, 2)
k1_df$ses.unemp <- k1_df$ses.emp %in% c(1, 2)

k1_df$soc.inc[k1_df$soc.inc < 0] <- NA
k1_df$soc.inc.wins[k1_df$soc.inc <= quantile(k1_df$soc.inc, .99)] <- k1_df$soc.inc[k1_df$soc.inc <= quantile(k1_df$soc.inc, .99)]
k1_df$soc.inc.wins.ln <- log(k1_df$soc.inc.wins + sqrt(k1_df$soc.inc.wins^2 + 1))

k1_df$soc.con[k1_df$soc.con < 0] <- NA
k1_df$soc.con.wins[k1_df$soc.con <= quantile(k1_df$soc.con, .99)] <- k1_df$soc.con[k1_df$soc.con <= quantile(k1_df$soc.con, .99)]
k1_df$soc.con.wins.ln <- log(k1_df$soc.con.wins + sqrt(k1_df$soc.con.wins^2 + 1))

k1_df$soc.sav <- k1_df$soc.sav - 1

k1_df$soc.eme.z <- scale(k1_df$soc.eme)

## Survey validity ##

k1_df$end.hear <- k1_df$end.hear - 1
k1_df$end.hear[k1_df$end.hear < 0] <- NA

attach(k1_df)

## Center covariates ##

soc.fem.c <- scale(soc.fem, scale = FALSE)
soc.pri.c <- scale(soc.pri, scale = FALSE)
soc.age.c <- scale(soc.age, scale = FALSE)
ses.unemp.c <- scale(ses.unemp, scale = FALSE)
soc.inc.wins.ln.c <- scale(soc.inc.wins.ln, scale = FALSE)
soc.con.wins.ln.c <- scale(soc.con.wins.ln, scale = FALSE)
soc.sav.c <- scale(soc.sav, scale = FALSE)

################
## Estimation ##
################

## Randomization balance checks ##

hypotheses <- c("treatInd = 0", "treatCom = 1", "treatInd - treatCom = 0")
depvars <- c("soc.fem", "soc.pri", "soc.age", "ses.unemp", "soc.inc.wins.ln", "soc.con.wins.ln", "soc.sav")

for (h in hypotheses) {

    RES <- matrix(nrow = 1, ncol = 5)

    for (depvar in depvars) {

        eqn <- paste(depvar, "~ treat", sep = " ")
        RES <- rbind(RES, PermTest(eqn, treatvars = c("treat", "pov", "ind", "com"), clustvars = k1_df$survey.id, hypotheses = c(h), iterations = 10000, data = k1_df))

    }

    RES <- RES[2:nrow(RES), 1:ncol(RES)]
    RES <- cbind(RES, FDR(RES[, 4]))

    rownames(RES) <- depvars
    colnames(RES)[6] <- "Min. Q"

    print("----------------------------------------------------------------", quote = FALSE)
    print(paste("H_0:", h), quote = FALSE)
    print(RES, quote = FALSE)

}

## Plain OLS for primary outcomes ##

hypotheses <- c("treatInd = 0", "treatCom = 1", "treatInd - treatCom = 0")
depvars <- c("vid.num", "sav.amt", "msg.dec")

for (h in hypotheses) {

    RES <- matrix(nrow = 1, ncol = 5)

    for (depvar in depvars) {

        eqn <- paste(depvar, "~ treat", sep = " ")
        RES <- rbind(RES, PermTest(eqn, treatvars = c("treat", "pov", "ind", "com"), clustvars = k1_df$survey.id, hypotheses = c(h), iterations = 10000, data = k1_df))

    }

    RES <- RES[2:nrow(RES), 1:ncol(RES)]
    RES <- cbind(RES, FDR(RES[, 4]))

    rownames(RES) <- depvars
    colnames(RES)[6] <- "Min. Q"

    print("----------------------------------------------------------------", quote = FALSE)
    print(paste("H_0:", h), quote = FALSE)
    print(RES, quote = FALSE)

}

## Plain OLS for secondary outcomes ##

hypotheses <- c("treatInd = 0", "treatCom = 1", "treatInd - treatCom = 0")
depvars <- c("sel.score.z", "sti.score.z", "aff.score.z", "msg.avg", "que.smrd", "ses.lad.now", "ses.lad.y2", "ses.lad.diff")

for (h in hypotheses) {

    RES <- matrix(nrow = 1, ncol = 5)

    for (depvar in depvars) {

        eqn <- paste(depvar, "~ treat", sep = " ")
        RES <- rbind(RES, PermTest(eqn, treatvars = c("treat", "pov", "ind", "com"), clustvars = k1_df$survey.id, hypotheses = c(h), iterations = 10000, data = k1_df))

    }

    RES <- RES[2:nrow(RES), 1:ncol(RES)]
    RES <- cbind(RES, FDR(RES[, 4]))

    rownames(RES) <- depvars
    colnames(RES)[6] <- "Min. Q"

    print("----------------------------------------------------------------", quote = FALSE)
    print(paste("H_0:", h), quote = FALSE)
    print(RES, quote = FALSE)

}

## Covariate adjustment for primary outcomes ##

hypotheses <- c("treatInd = 0", "treatCom = 1", "treatInd - treatCom = 0")
depvars <- c("vid.num", "sav.amt", "msg.dec")
covariates <- c("soc.fem.c", "soc.pri.c", "soc.age.c", "ses.unemp.c")

for (h in hypotheses) {

    RES <- matrix(nrow = 1, ncol = 5)

    for (depvar in depvars) {

        eqn <- paste(depvar, "~", Interact("treat", covariates), sep = " ")
        RES <- rbind(RES, PermTest(eqn, treatvars = c("treat", "pov", "ind", "com"), clustvars = k1_df$survey.id, hypotheses = c(h), iterations = 10000, data = k1_df))

    }

    RES <- RES[2:nrow(RES), 1:ncol(RES)]
    RES <- cbind(RES, FDR(RES[, 4]))

    rownames(RES) <- depvars
    colnames(RES)[6] <- "Min. Q"

    print("----------------------------------------------------------------", quote = FALSE)
    print(paste("H_0:", h), quote = FALSE)
    print(RES, quote = FALSE)

}

## Covariate adjustment for secondary outcomes ##

hypotheses <- c("treatInd = 0", "treatCom = 1", "treatInd - treatCom = 0")
depvars <- c("sel.score.z", "sti.score.z", "aff.score.z", "msg.avg", "que.smrd", "ses.lad.now", "ses.lad.y2", "ses.lad.diff")
covariates <- c("soc.fem.c", "soc.pri.c", "soc.age.c", "ses.unemp.c")

for (h in hypotheses) {

    RES <- matrix(nrow = 1, ncol = 5)

    for (depvar in depvars) {

        eqn <- paste(depvar, "~", Interact("treat", covariates), sep = " ")
        RES <- rbind(RES, PermTest(eqn, treatvars = c("treat", "pov", "ind", "com"), clustvars = k1_df$survey.id, hypotheses = c(h), iterations = 10000, data = k1_df))

    }

    RES <- RES[2:nrow(RES), 1:ncol(RES)]
    RES <- cbind(RES, FDR(RES[, 4]))

    rownames(RES) <- depvars
    colnames(RES)[6] <- "Min. Q"

    print("----------------------------------------------------------------", quote = FALSE)
    print(paste("H_0:", h), quote = FALSE)
    print(RES, quote = FALSE)

}

## Heterogeneous effects for primary outcomes ##

depvars <- c("vid.num", "sav.amt", "msg.dec")
hetvars <- c("soc.fem", "soc.pri")

for (hetvar in hetvars) {

    hypotheses <- c(paste("treatInd:", hetvar, " = 0", sep = ""), paste("treatCom:", hetvar, " = 0", sep = ""), paste("treatInd:", hetvar, " - ", "treatCom:", hetvar, " = 0", sep = ""))

    for (h in hypotheses) {

        RES <- matrix(nrow = 1, ncol = 5)

        for (depvar in depvars) {

            eqn <- paste(depvar, " ~ treat*", hetvar, sep = "")
            RES <- rbind(RES, PermTest(eqn, treatvars = c("treat", "pov", "ind", "com"), clustvars = k1_df$survey.id, hypotheses = c(h), iterations = 10000, data = k1_df))

        }

        RES <- RES[2:nrow(RES), 1:ncol(RES)]
        RES <- cbind(RES, FDR(RES[, 4]))

        rownames(RES) <- depvars
        colnames(RES)[6] <- "Min. Q"

        print("----------------------------------------------------------------", quote = FALSE)
        print(paste("H_0:", h), quote = FALSE)
        print(RES, quote = FALSE)

    }

}

## Heterogeneous effects for secondary outcomes ##

depvars <- c("sel.score.z", "sti.score.z", "aff.score.z", "msg.avg", "que.smrd", "ses.lad.now", "ses.lad.y2", "ses.lad.diff")
hetvars <- c("soc.fem", "soc.pri")

for (hetvar in hetvars) {

    hypotheses <- c(paste("treatInd:", hetvar, " = 0", sep = ""), paste("treatCom:", hetvar, " = 0", sep = ""), paste("treatInd:", hetvar, " - ", "treatCom:", hetvar, " = 0", sep = ""))

    for (h in hypotheses) {

        RES <- matrix(nrow = 1, ncol = 5)

        for (depvar in depvars) {

            eqn <- paste(depvar, " ~ treat*", hetvar, sep = "")
            RES <- rbind(RES, PermTest(eqn, treatvars = c("treat", "pov", "ind", "com"), clustvars = k1_df$survey.id, hypotheses = c(h), iterations = 10000, data = k1_df))

        }

        RES <- RES[2:nrow(RES), 1:ncol(RES)]
        RES <- cbind(RES, FDR(RES[, 4]))

        rownames(RES) <- depvars
        colnames(RES)[6] <- "Min. Q"

        print("----------------------------------------------------------------", quote = FALSE)
        print(paste("H_0:", h), quote = FALSE)
        print(RES, quote = FALSE)

    }

}


# For each Species, change Sepal.Length by their order in the group
library(dplyr)
library(plyr)
data(iris)
by_species <- iris %>% arrange(Species, Sepal.Length) %>% group_by(Species) %>% mutate(rank=row_number())
# Error

detach("package:plyr", unload=TRUE)
by_species <- iris %>% arrange(Species, Sepal.Length) %>% group_by(Species) %>% mutate(rank=row_number())
by_species %>% filter(rank <= 3)

# With Base R
iris <- iris[with(iris, order(Species, Sepal.Length)), ]

# RUN A ROW COUNT FOR RANK BY SPECIES GROUP
iris$rank <- sapply(1:nrow(iris),
                    function(i) sum(iris[1:i, c('Species')]==iris$Species[i]))

# FILTER DATA FRAME BY TOP 3
iris <- iris[iris$rank <= 3,]


context("compute_stack")

test_that("compute_stack works as expected", {
  dat <- data.frame(
    g1 = c("a", "a", "a", "b", "b", "c", "c", "c"),
    g2 = c(1, 2, 3, 1, 3, 1, 2, 3),
    val = 1:8
  )

  # Basic stacking: stack y value at each x
  stacked <- dat %>% compute_stack(~val, ~g1) %>% as.data.frame()
  expected <- data.frame(
    stack_lwr_ = c(0,1,3,0,4,0,6,13),
    stack_upr_ = c(1,3,6,4,9,6,13,21)
  )

  expect_equal(stacked[c("stack_lwr_", "stack_upr_")], expected)

  # With grouping
  stacked <- dat %>% group_by(g2) %>% compute_stack(~val, ~g1) %>%
    as.data.frame()
  expected <- expected[order(dat$g2), ] %>% as.data.frame()
  expected <- expected[order(dat$g2), ] %>% as.data.frame()
  expect_equal(stacked[c("stack_lwr_", "stack_upr_")], expected)
})

test_that("Zero-row inputs", {
  res <- mtcars[0,] %>% compute_stack(~wt, ~cyl)
  expect_equal(nrow(res), 0)
  expect_true(setequal(
    names(res),
    c(names(mtcars), "group__", "stack_upr_", "stack_lwr_"))
  )

  # Grouped
  res <- mtcars %>% group_by(cyl) %>% dplyr::filter(FALSE) %>% compute_stack(~wt, ~cyl)
  expect_equal(nrow(res), 0)
  expect_true(setequal(
    names(res),
    c(names(mtcars), "group__", "stack_upr_", "stack_lwr_"))
  )
})


# install necessary packages ----
library(ggplot2)
library(ggradar)
suppressPackageStartupMessages(library(dplyr))
library(scales)

#load necessary data
shooting <= read_csv('shooting.csv')

# data processing ----
shooting_radar <- shooting %>%
  #as_tibble(rownames = 'Player Name') %>%
  mutate_at(vars(-'Player Name'),function(x) x/100)%>%
  head(3)

# visualization radar plot ----
ggradar(shooting_radar) +
  ggsave("shooting_radar_plot.png")


function varargout = setdiff(varargin)
%SETDIFF Set difference.
%   C = SETDIFF(A,B) for vectors A and B, returns the values in A that
%   are not in B with no repetitions. C will be sorted.
%
%   C = SETDIFF(A,B,'rows') for matrices A and B with the same number of
%   columns, returns the rows from A that are not in B. The rows of the
%   matrix C will be in sorted order.
%
%   [C,IA] = SETDIFF(A,B) also returns an index vector IA such that
%   C = A(IA). If there are repeated values in A that are not in B, then
%   the index of the first occurrence of each repeated value is returned.
%
%   [C,IA] = SETDIFF(A,B,'rows') also returns an index vector IA such that
%   C = A(IA,:).
%
%   [C,IA] = SETDIFF(A,B,'stable') for arrays A and B, returns the values
%   of C in the order that they appear in A.
%   [C,IA] = SETDIFF(A,B,'sorted') returns the values of C in sorted order.
%   If A is a row vector, then C will be a row vector as well, otherwise C
%   will be a column vector. IA is a column vector. If there are repeated
%   values in A that are not in B, then the index of the first occurrence of
%   each repeated value is returned.
%
%   [C,IA] = SETDIFF(A,B,'rows','stable') returns the rows of C in the
%   same order that they appear in A.
%   [C,IA] = SETDIFF(A,B,'rows','sorted') returns the rows of C in sorted
%   order.
%
%   The behavior of SETDIFF has changed.  This includes:
%     -	occurrence of indices in IA switched from last to first
%     -	orientation of vector C
%     -	IA will always be a column index vector
%     -	tighter restrictions on combinations of classes
%
%   If this change in behavior has adversely affected your code, you may
%   preserve the previous behavior with:
%
%      [C,IA] = SETDIFF(A,B,'legacy')
%      [C,IA] = SETDIFF(A,B,'rows','legacy')
%
%   Examples:
%
%      a = [9 9 9 9 9 9 8 8 8 8 7 7 7 6 6 6 5 5 4 2 1]
%      b = [1 1 1 3 3 3 3 3 4 4 4 4 4 10 10 10]
%
%      [c1,ia1] = setdiff(a,b)
%      % returns
%      c1 = [2 5 6 7 8 9]
%      ia1 = [20 17 14 11 7 1]'
%
%      [c2,ia2] = setdiff(a,b,'stable')
%      % returns
%      c2 = [9 8 7 6 5 2]
%      ia2 = [1 7 11 14 17 20]'
%
%      c = setdiff([1 NaN 2 3],[3 4 NaN 1])
%      % NaNs compare as not equal, so this returns
%      c = [2 NaN]
%
%   Class support for inputs A and B, where A and B must be of the same
%   class unless stated otherwise:
%      - logical, char, all numeric classes (may combine with double arrays)
%      - cell arrays of strings (may combine with char arrays)
%      -- 'rows' option is not supported for cell arrays
%      - objects with methods SORT (SORTROWS for the 'rows' option), EQ and NE
%      -- including heterogeneous arrays derived from the same root class
%
%   See also UNIQUE, UNION, INTERSECT, SETXOR, ISMEMBER, SORT, SORTROWS.

%   Copyright 1984-2018 The MathWorks, Inc.

% Determine the number of outputs requested.
if nargout == 0
    nlhs = 1;
else
    nlhs = nargout;
end

narginchk(2,4);
% Convert string flags to char flags to dispatch to the right method
if (nargin == 3) && isstring(varargin{3})
    varargin{3} = convertFlag(varargin{3});
    [varargout{1:nlhs}] = setdiff(varargin{:});
    return;
end
if (nargin == 4) && (isstring(varargin{3}) || isstring(varargin{4}))
    if isstring(varargin{3})
        varargin{3} = convertFlag(varargin{3});
    end
    if isstring(varargin{4})
        varargin{4} = convertFlag(varargin{4});
    end
    [varargout{1:nlhs}] = setdiff(varargin{:});
    return;
end

if isstring(varargin{1}) || isstring(varargin{2})
    if ~ischar(varargin{1}) && ~iscellstr(varargin{1}) && ~isstring(varargin{1})
        firstInput = getString(message('MATLAB:string:FirstInput'));
        error(message('MATLAB:string:MustBeCharCellArrayOrString', firstInput));
    elseif ~ischar(varargin{2}) && ~iscellstr(varargin{2}) && ~isstring(varargin{2})
        secondInput = getString(message('MATLAB:string:SecondInput'));
        error(message('MATLAB:string:MustBeCharCellArrayOrString', secondInput));
    end
    varargin{1} = string(varargin{1});
    varargin{2} = string(varargin{2});
end
nrhs = nargin;
if nrhs == 2
    [varargout{1:nlhs}] = setdiffR2012a(varargin{:});
else
    % acceptable combinations, with optional inputs denoted in []
    % setdiff(A,B, ['rows'], ['legacy'/'R2012a']),
    % setdiff(A,B, ['rows'], ['sorted'/'stable']),
    % where the position of 'rows' and 'sorted'/'stable' may be reversed
    nflagvals = 5;
    flagvals = ["rows" "sorted" "stable" "legacy" "R2012a"];
    % When a flag is found, note the index into varargin where it was found
    flaginds = zeros(1,nflagvals);
    for i = 3:nrhs
        flag = varargin{i};
        assert(~isstring(flag));
        if ~ischar(flag)
            error(message('MATLAB:SETDIFF:UnknownInput'));
        end
        foundflag = startsWith(flagvals,flag,'IgnoreCase',true);
        if sum(foundflag) ~= 1
            error(message('MATLAB:SETDIFF:UnknownFlag',flag));
        end
        % Only 1 occurrence of each allowed flag value
        if flaginds(foundflag)
            error(message('MATLAB:SETDIFF:RepeatedFlag',flag));
        end
        flaginds(foundflag) = i;
    end

    % Only 1 of each of the paired flags
    if flaginds(2) && flaginds(3)
        error(message('MATLAB:SETDIFF:SetOrderConflict'))
    end
    if flaginds(4) && flaginds(5)
        error(message('MATLAB:SETDIFF:BehaviorConflict'))
    end
    % 'legacy' and 'R2012a' flags must be trailing
    if flaginds(4) && flaginds(4)~=nrhs
        error(message('MATLAB:SETDIFF:LegacyTrailing'))
    end
    if flaginds(5) && flaginds(5)~=nrhs
        error(message('MATLAB:SETDIFF:R2012aTrailing'))
    end

    if flaginds(2) || flaginds(3) % 'stable'/'sorted' specified
        if flaginds(4) || flaginds(5) % does not combine with 'legacy'/'R2012a'
            error(message('MATLAB:SETDIFF:SetOrderBehavior'))
        end
        [varargout{1:nlhs}] = setdiffR2012a(varargin{1:2},logical(flaginds(1:3)));
    elseif flaginds(5) % trailing 'R2012a' specified
        [varargout{1:nlhs}] = setdiffR2012a(varargin{1:2},logical(flaginds(1:3)));
    elseif flaginds(4) % trailing 'legacy' specified
        [varargout{1:nlhs}] = setdifflegacy(varargin{1:2},logical(flaginds(1)));
    else % 'R2012a' (default behavior)
        [varargout{1:nlhs}] = setdiffR2012a(varargin{1:2},logical(flaginds(1:3)));
    end
end
end

function [c,ia] = setdiffR2012a(a,b,options)
% 'R2012a' flag implementation

% flagvals = {'rows' 'sorted' 'stable'};
if nargin == 2
    byrow = false;
    order = 'sorted';
else
    byrow = (options(1) > 0);
    if options(3) > 0
        order = 'stable';
    else % if options(2) > 0 || sum(options(2:3)) == 0)
        order = 'sorted';
    end
end

% Check that one of A and B is double if A and B are non-homogeneous. Do a
% separate check if A is a heterogeneous object and only allow a B
% that is of the same root class.
if ~(isa(a,'handle.handle') || isa(b,'handle.handle'))
    if ~strcmpi(class(a),class(b))
        if isa(a,'matlab.mixin.Heterogeneous') && isa(b,'matlab.mixin.Heterogeneous')
            rootClassA = meta.internal.findHeterogeneousRootClass(a);
            if isempty(rootClassA) || ~isa(b,rootClassA.Name)
                error(message('MATLAB:SETDIFF:InvalidInputsDataType',class(a),class(b)));
            end
        elseif ~(strcmpi(class(a),'double') || strcmpi(class(b),'double'))
            error(message('MATLAB:SETDIFF:InvalidInputsDataType',class(a),class(b)));
        end
    end
end

% Determine if A is a row vector.
rowvec = isrow(a);

sparseA = false;

% Determine if A is sparse
if issparse(a)
    sparseA = true;
    a = full(a);
end
if issparse(b)
    b = full(b);
end

if ~byrow
    % Convert to columns.
    a = a(:);
    b = b(:);

    % Call ISMEMBER to determine list of non-matching elements of A.
    logUA = ~(ismember(a,b));
    c = a(logUA);

    % Call UNIQUE to remove duplicates from list of non-matches.
    if nargout <= 1
        c = unique(c,order);
    else
        [c,ndx] = unique(c,order);

        % Find indices by using logUA and NDX.
        indlogUA = find(logUA);
        ia = indlogUA(ndx);
    end

    % If a is a row vector, return c as a row vector.
    if rowvec
        c = c.';
    end
    % If a is sparse then c is sparse.
    if sparseA
        c = sparse(c);
    end

else    % 'rows' case
    if ~(ismatrix(a) && ismatrix(b))
        error(message('MATLAB:SETDIFF:NotAMatrix'));
    end

    [rowsA,colsA] = size(a);
    [rowsB,colsB] = size(b);

    % Automatically pad strings with spaces
    if ischar(a) && ischar(b)
        if colsA > colsB
            b = [b repmat(' ',rowsB,colsA-colsB)];
        elseif colsA < colsB
            a = [a repmat(' ',rowsA,colsB-colsA)];
            colsA = colsB;
        end
    elseif colsA ~= colsB
        error(message('MATLAB:SETDIFF:AandBColnumAgree'));
    end

    % Handle empty arrays
    if rowsA == 0
        c = zeros(rowsA,colsA);
        ia = zeros(0,1);
    elseif colsA == 0
        c = [];
        ia = zeros(0,1);
    % General handling
    else
        % Remove duplicates from A; get indices only if needed
        if nargout > 1
            [uA,ia] = unique(a,'rows',order);
        else
            uA = unique(a,'rows',order);
        end

        if needsCastingCheck(a, b)
            % Set the output to be the unique entries of the input.
            c = uA;
            % Find all rows of b that are elements of the unique rows of A.
            [~,locuA] = ismember(b, uA, 'rows');
            % Take the unique set of indices of rows of uA that were found
            % within b.
            rmidx = unique(locuA(locuA ~= 0));
            % Remove these rows from c and, if requested, ia.
            c(rmidx,:) = [];
            if nargout > 1
                ia(rmidx,:) = [];
            end
        else
            % Create sorted list of unique A and B; want non-matching entries
            [sortuAB,ndx] = sortrows([uA;b]);
            [rowsC,colsC] = size(sortuAB);

            if rowsC > 1 && colsC ~= 0
                % d indicates the location of non-matching entries
                d = sortuAB(1:rowsC-1,:) ~= sortuAB(2:rowsC,:);
            else
                d = zeros(rowsC-1,0);
            end

            d = any(d,2);
            d(rowsC,1) = 1;   % Final entry always included.
            numRowsUA = size(uA,1);
            d = d & ndx <= numRowsUA; % Now find only the ones in A.

            if strcmp(order, 'stable') % 'stable'
                d = sort(ndx(d));   % Sort ndx(d) to maintain 'stable' order
                c = uA(d,:);
            else
                c = sortuAB(d,:);
            end

            % Find IA only if needed.
            if nargout > 1
                if strcmp(order, 'stable') % 'stable'
                    ia = ia(d);
                else
                    ia = ia(ndx(d));
                end
            end
        end
    end
    % If a is sparse then c is sparse.
    if sparseA
        c = sparse(c);
    end
end
end

function flag = convertFlag(flag)
if isscalar(flag)
    flag = char(flag);
else
    error(message('MATLAB:SETDIFF:UnknownInput'));
end
end

function tf = needsCastingCheck(a, b)
    tf = ~strcmpi(class(a), class(b)) && ~(isa(a, 'handle.handle') || ...
        isa(b, 'handle.handle')) && ~isa(a, 'matlab.mixin.Heterogeneous');
end


twri.adjust <- function(xts, d2m=FALSE, dates.new=NA, twri.input=TRUE) {

    ## ADJUST DATES FOR XTS OBJECT TO CLOSEST DATES THE MARKET IS OPEN

    ## Input: xts = XTS object (does not have to be an XTS of twri values)
    ##        align = TRUE (default) aligns xts dates to closest market dates
    ##        d2m = FALSE (default) does not attempt to convert xts column values
    ##            = TRUE assumes xts object contains twri values and converts from days to months
    ##        dates.new = NA (default) option is ignored
    ##                  = vector of new, more coarse dates to align xts object to rather than months
    ##                    (d2m is ignored in this case)

    ## Output: xts object with potentially new dates and potentially new values

    ## extract dates from xts object
    xtsdates <- zoo::index(xts)

    ## determine the dates the market is open
    out <- equity.history('SPY', period='days')

    ## function to find the closest match
    closest <- function(x, findin=out$market.open.days) {
        ## market.open[findInterval(as.Date('2021-01-31'), as.Date(market.open))]
        findin[findInterval(as.Date(x), as.Date(findin))]
    }
    ## closest('2021-01-31')

    ## apply function to find closest match
    adjust <- unlist( purrr::pmap(list(x = xtsdates), function(x) closest(x)) )
    zoo::index(xts) <- as.Date(adjust, origin='1970-01-01')

    ##-----------------------------------------------------------------------------
    if (isTRUE(d2m) | !is.na(dates.new)) {
        ## convert to months or provided dates

        ## number of columns in original xts object
        xts.cols <- ncol(xts)

        ## define range of dates in input xts object
        xts.range <- paste(xtsdates[1], '/', xtsdates[length(xtsdates)], sep='')

        if (is.na(dates.new)) {
            ## create xts object from market open months for the input xts range
            xts.open <- xts.create(out$market.open.months, 1)[xts.range]
        } else {
            ## create xts object from provided dates for the input xts range
            xts.open <- xts.create(dates.new, 1)[xts.range]
            ## narrow the range of the input xts object if it is wider than for xts.open
            xts.range.open <- paste(zoo::index(xts.open[1]), '/',
                                    zoo::index(xts.open[nrow(xts.open)]), sep='')
            xts <- xts[xts.range.open]
        }

        ## combine the two xts objects
        xts.names      <- names(xts)
        xts.open.names <- names(xts.open)
        xts <- cbind(xts, xts.open)
        names(xts) <- c(xts.names, xts.open.names)

        if (isFALSE(twri.input)) {
            ## input xts object is not twri so do elmininate dates not at month ends
            ## but do not modify the values themselves
            xts <- xts[xts$xts.created == 1, 1:xts.cols]

        } else {
            ## input xts object is twri so need to adjust month end values
            ## if eliminate an intermediate twri

            ## consider time t in xts object
            xts.elim <- rep(0, xts.cols)
            for (t in 1:nrow(xts)) {

                if (is.na(xts[t, xts.cols+1])) {
                    ## need to eliminate this time and add twri to next twri for each column
                    for (h in 1:xts.cols) {
                        xts.elim[h] <- (xts.elim[h] + 1) * (xts[t, h] + 1) - 1
                    }
                    xts.elim <- as.numeric(xts.elim)
                    ## cat(t, xts[t,], xts.elim,'\n')

                } else {
                    ## calculate a new xts if needed for each holding h
                    for (h in 1:xts.cols) {
                        ## No change if prior time was not NA (i.e., xts.elim=0)
                        xts[t, h] <- (xts.elim[h] + 1) * (xts[t, h] + 1) - 1
                    }
                    ## reset xts.elim
                    xts.elim <- rep(0, xts.cols)
                    ## cat(t, xts[t,], xts.elim,'\n')
                }
            }
            xts <- xts[xts$xts.created == 1, 1:xts.cols]
        }

    }

    return(xts)

}

## # a and a.adj should be identical
## a.data <- '
## CCF     CER     CTR
## 2019-12-31  0.0258  0.0212  0.0305
## 2020-01-31 -0.0117 -0.0146 -0.0124
## 2020-02-28 -0.0738 -0.0493 -0.0566
## 2020-03-31 -0.1758 -0.1210 -0.1282
## 2020-04-30  0.1128  0.0659  0.0701
## '
## a <- xts::as.xts( readall(a.data) )
## a.adj <- twri.adjust(a, d2m=TRUE)
## a
## a.adj

## ## b has an extra, mid-month twri
## b.data <- '
##                   CCF         CER         CTR
## 2019-12-31  0.0258000  0.02120000  0.03050000
## 2020-01-31 -0.0117000 -0.01460000 -0.01240000
## 2020-02-20  0.0635000  0.01900000  0.02780000
## 2020-02-28 -0.1291020 -0.06702650 -0.08211714
## 2020-03-23 -0.2945000 -0.19400000 -0.21920000
## 2020-03-31  0.1682495  0.09057072  0.11654713
## 2020-04-30  0.1128000  0.06590000  0.07010000
## '
## b <- xts::as.xts( readall(b.data) )
## b <- twrsheet['2019-12-31/2020-04', 1:3]
## b.adj <- twri.adjust(b, d2m=TRUE)
## b.twrc     <- cumprod(b     + 1) - 1
## b.adj.twrc <- cumprod(b.adj + 1) - 1
## diff <- tail(b.adj.twrc,1) - tail(b.twrc,1)
## if (sum(abs(diff)) < 0.0001) {
##     cat('Verification checks out\n')
##     print(diff)
## } else {
##     cat('Verification error\n')
##     print(diff)
## }

## cc <- equity.twri('SPY', period='days')['2019-12/2020']
## cc.adj <- twri.adjust(cc, d2m=TRUE)
## cc.twrc     <- twrc.calc(cc    , zero.from = FALSE)
## cc.adj.twrc <- twrc.calc(cc.adj, zero.from = FALSE)
## tail(cc.twrc)
## tail(cc.adj.twrc)
## comb <- cbind(cc.twrc, cc.adj.twrc)
## plot(zoo::na.approx(comb),screens=1,auto.legend=TRUE)

## ## adjust days to some alternate set of dates (i.e., not just month ends)
## fine <- equity.twri('SPY', period='days')['2019-12/2020']
## dates.coarse <- c('2019-12-31', '2020-01-31', '2020-02-20', '2020-02-28',
##                   '2020-03-23', '2020-03-31', '2020-04-30 ')
## coarse       <- twri.adjust(fine, dates.new = dates.coarse)
## ## check that both have same twrc for same duration
## xtsrange <- paste(dates.coarse[1], '/', dates.coarse[length(dates.coarse)], sep='')
## xtsrange <- '2019-12-31/2020-01-31'
## fine[xtsrange]
## coarse[xtsrange]
## fine.twrc    <- cumprod(fine[xtsrange]   + 1) - 1
## coarse.twrc  <- cumprod(coarse[xtsrange] + 1) - 1
## diff <- tail(coarse.twrc,1) - tail(fine.twrc,1)
## if (sum(abs(diff)) < 0.0001) {
##     cat('Verification checks out\n')
##     print(diff)
## } else {
##     cat('Verification error\n')
##     print(diff)
## }


id <- c(1,2,3,4,5,6,7,8,9,10)
i <- c(1,2,3,1,0,5,7,2,1,1);length(inf)
df<-cbind.data.frame(id,i)
print(df)
dim(df)

weight<-c(1,0.90,0.6,0.1,0);length(weight)
wj = length(weight)

for (k in id){
  print(k)
  if (k + wj < dim(df)[1])   {df[paste0("col",k)] <- c(rep(0,k),df$i[k] * weight,rep(df$i[k] * weight[wj],dim(df)[1]-(k+wj)))}
  if (k + wj == dim(df)[1])  {df[paste0("col",k)] <- c(rep(0,k),df$i[k] * weight)}
  if (k + wj > dim(df)[1] & k < dim(df)[1])   {df[paste0("col",k)] <- c(rep(0,k),df$i[k] * weight[1:(dim(df)[1]-k)])}
  if (k == dim(df)[1])   {df[paste0("col",k)] <- rep(0,k)}
}

df

df<-df %>% mutate(rowSums(.[2:11]),
              i = cumsum(inf),
              r = i-a)

names(df)

#Datensatz für LK
dfplot <- df %>%
  select(id,i,a,r) %>%
  pivot_longer(-id,names_to ="status",values_to = "nsum")
  dfplot

ggplot() +
  geom_point(data = dfplot,aes(x = id,y = nsum, color = status, group = status),size = 3) +
  geom_step(data = dfplot,aes(x = id,y = nsum, color = status, group = status),size = 2) +
  scale_colour_manual(values = c("darkblue","forestgreen","orange")) +
  #geom_line(data = dffit,aes(x = datum,y = projn, group = progtyp),size = 0.8) +
  theme_minimal() +
  theme(legend.position =  "bottom") +
  theme(legend.position =  "bottom",
        axis.text = element_text(size = 12),
        axis.title = element_text(size = 16),
        legend.title = element_blank(),
        legend.text = element_text(size = 16),
        #panel.grid.minor.x = element_line(colour="blue", size=0.5),
        panel.grid.major.x = element_line(colour="red", size=0.75)) +
  #scale_y_continuous(breaks = seq(0,200,25),labels =seq(0,200,25)) +
  labs(y = "absolute Anzahl",x = "Datum") #+
  #scale_x_date(breaks = seq(mindat,maxdat,by="week"),
  #             date_labels = "%b %d", minor_breaks = "1 day") +
  #annotate("rect", xmin = mindat-1, xmax = maxdat+2, ymin = -10, ymax = -4,fill = "white") +
  #annotate("text",y=-6,x = c(seq(mindat,maxdat,"day")),
  #         label = c(rep(c("S","M","D","M","D","F","S"),poltweeks),"S"),
  #         color =c(rep(c("red",rep("blue",5),"orange"),poltweeks),"red"))


model_refreezing <- function (tavg = 0.0,
         Tmf = 0.0,
         SWrf = 0.0){
    #'- Name: Refreezing -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: snowfall accumulation  calculation
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: It simulates the depth of snow cover and recalculate weather data
    #'- inputs:
    #'            * name: tavg
    #'                          ** description : average temperature
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: Tmf
    #'                          ** description : threshold temperature for snow melting
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : degC
    #'                          ** uri :
    #'            * name: SWrf
    #'                          ** description : degree-day temperature index for refreezing
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : mmW/degC/d
    #'                          ** uri :
    #'- outputs:
    #'            * name: Mrf
    #'                          ** description : liquid water in the snow cover in the process of refreezing
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW/d
    #'                          ** uri :
    Mrf <- 0.0
    if (tavg < Tmf)
    {
        Mrf <- SWrf * (Tmf - tavg)
    }
    return (list('Mrf' = Mrf))
}


first.year<- 2000                #first year on plot, negative value means value defined by data
last.year<- 2200               #last year on plot
  op.dir<-file.path(data.path,"HCR_1_deter_noadjust_test_01_HCR1_0_Rec0__2030")

my.dev<-'screen'   # output device:  'screen', 'wmf', 'png', 'pdf'
#my.dev<-'png'

palette("default")
if (makeAllGraphs)  my.dev<-'png'
#cleanup()
file.name<-'plot_summary_N_Check'

#dev<-"dummy"
 nox<-2; noy<-2;
 noxy<-nox*noy

Init.function()

dat<-Read.summary.data(dir=op.dir,infile="op_summary.out",read.init.function=F)
dat<-subset(dat,Year<=last.year )

par(mfcol=c(nox,noy))
sp<-16
s<-subset(dat,Species.n==sp & Quarter==3,select=c(Species, Year, Quarter, Area, Species.n, Age, N,Nbar,NbarStom ) )

    par(mar=c(3,4,3,2))
    for (a in (0:3)) {
      ss<-subset(s,Age==a)
      plot(ss$Year,ss$N, main=paste(sp.names[sp],' age',a),ylim=c(0,max(ss$N)),type='l')
      lines(ss$Year,ss$Nbar,col='red')
      lines(ss$Year,ss$NbarStom,col='blue')
    }


# Function to plot

dev<-"screen"
nox<-2; noy<-2;

first.year.on.plot<-2000
last.year.on.plot<-2030
age.incl<-c(1,2,3,4,5)
age.incl<-c(0,1,2)
include.mean<-TRUE
include.std1<-FALSE      #include 1*std band
include.std2<-FALSE      #include 2*std band

include.obs<-FALSE

plot_forcast<-function(var='M2') {

a<-Read.MCMC.detailed.data()
a<-subset(a,(Year>=first.year.on.plot & Year<=last.year.on.plot & Age %in% age.incl ) ,drop=T)

#prepare annual data
comb<-list(a$Species.n,a$Repetion,a$Iteration,a$Age,a$Year)
if (var=="N") {a<-subset(a,Quarter==1,,drop=T);
                  comb<-list(a$Species.n,a$Repetion,a$Iteration,a$Age,a$Year)
                 a1<-tapply(a$N,comb,sum)/1000; y.lab<-"N 10^6)";
              }
if (var=="M2"){a1<-tapply(a$M2,comb,sum); y.lab<-"M2"; }
if (var=="F") {a1<-tapply(a$F,comb,sum); y.lab<-"F";}

if (include.mean) {
  b1<-apply(a1,c(1,4,5),mean)
  if (include.std1 || include.std2) b1.std<-apply(a1,c(1,4,5),sd)
}

species.n<-dimnames(a1)[[1]]
years<-as.numeric(dimnames(a1)[[5]])
repe<-as.numeric(dimnames(a1)[[2]])
iter<-as.numeric(dimnames(a1)[[3]])
age<-dimnames(a1)[[4]]

cleanup()
for (a in age) {
  newplot(dev,nox,noy);
  i<-0

  for (sp in species.n) {
    if (i==noxy) {newplot(dev,nox,noy); i<-0 }
    if (include.obs) {
       plot(years,a1[sp,1,1,a,],main=paste(name[as.numeric(sp)+1],a),type='l',ylab=y.lab,
           xlab='',ylim=(c(0,max(a1[sp,,,,]))))
       for (r in repe) for (ii in iter) lines(years,a1[sp,r,ii,a,],col=ii)
       i<-i+1
    }
    else if (include.mean) {
     if (include.std2) max.y<-max(b1[sp,a,]+2*b1.std[sp,a,]) else if (include.std1) max.y<-max(b1[sp,a,]+b1.std[sp,a,]) else max.y<-max(b1[sp,a,])

     plot(years,b1[sp,a,],main=paste(name[as.numeric(sp)+1],a),type='l',ylab=y.lab,xlab='',ylim=c(0,max.y))
     if (include.std1) {
       lines(years,b1[sp,a,]-b1.std[sp,a,],col=2,lty=2)
       lines(years,b1[sp,a,]+b1.std[sp,a,],col=2,lty=2)
     }
     if (include.std2) {
       lines(years,b1[sp,a,]-2*b1.std[sp,a,],col=3,lty=3)
       lines(years,b1[sp,a,]+2*b1.std[sp,a,],col=3,lty=3)
     }
     i<-i+1
    }
  }
}

}

#plot_forcast(var="M2")
#plot_forcast(var="F")
plot_forcast(var="N")


set.seed(23020306)

## Simple trial run. Initial population equally distributed between
## genotypes. Constant environment model parameters.
sim.len <- 50
init.pop <- 500
sim.out <- doSim(mParFixEf, sim.length=sim.len, init.pop.size=init.pop)
simRunSum <- summariseSimRun(sim.out)
pG <- (simRunSum$ntGG + 0.5*simRunSum$ntGT)/simRunSum$ntT
plot(pG,type="l")

## Simulation with G allele only
sim.out <- doSim(mParFixEf, sim.length=500, init.pop.size=init.pop, init.G = "GG")
simRunSum <- summariseSimRun(sim.out)
plot(simRunSum$ntT, type="l", ylim=c(0,600), main="GG")
lines(simRunSum$ntF, col="red")
lines(simRunSum$ntM, col="blue")

## Simulation with T allele only
sim.out <- doSim(mParFixEf, sim.length=500, init.pop.size=init.pop, init.G = "TT")
simRunSum <- summariseSimRun(sim.out)
plot(simRunSum$ntT, type="l", ylim=c(0,600), main="TT")
lines(simRunSum$ntF, col="red")
lines(simRunSum$ntM, col="blue")

## Repeated invasion simulation of superior into inferior genotype to see if
## results are consistent. Need to improve speed of code to make this complete
## in a sensible time.
numReps <- 1000
resG <- "TT"
mPar <- list(C=mParFixEf, S=mParStore)
invProp <- c(0.02, 0.05) # Density of invader as proportion of existing population
invRate <- list()

for (m in seq_along(mPar)) {
    for (i in invProp) {
        simTitle <- paste(switch(names(mPar)[[m]], C="Constant", S="Stochastic"),
                          "environment, proportion of invader:", i)
        print(simTitle)

        label <- paste0(i,names(mPar)[[m]])
        invRate[[label]] <- simInv(mPar[[m]], inv.prop=i, num.reps=numReps, res=resG)

        ## Mean invader log growth rate
        print(summary(invRate[[label]], na.rm=TRUE))

        ## Proportion positive vs negative growth rate
        print(paste("Invasion rate positive", sum(invRate[[label]]>0, na.rm=TRUE)/numReps*100, "%"))

        hist(invRate[[label]], breaks="scott", main=simTitle)
    }
}

save(invRate, file="ibmSimData.rda")


#' eigen
#'
#' Eigenvalue decomposition.
#'
#' @details
#' Symmetric matrices only.
#'
#' @param x
#' An fmlmat matrix.
#' @param only.values
#' Should only the eigenvalues be returned?
#' @param symmetric,EISPACK
#' Ignored.
#'
#' @name eigen
#' @rdname eigen
NULL

eigen_fml = function(x, symmetric, only.values=FALSE, EISPACK=FALSE)
{
  x_cp = DATA(x)$dupe()
  val = skeleton_vec(x_cp)

  if (isTRUE(only.values))
    fmlr::linalg_eigen_sym(x_cp, val)
  else
  {
    vec = skeleton_mat(x_cp)
    fmlr::linalg_eigen_sym(x_cp, val, vec)
  }

  ret = list()
  ret$values = wrapfml(val)
  if (!isTRUE(only.values))
    ret$vectors = wrapfml(vec)

  ret
}

#' @rdname eigen
#' @export
setMethod("eigen", signature(x="fmlmat"), eigen_fml)


score_fun_ave <-
    function(y, z, pen, n_out = min(10, max(1, 0.2 * length(z)))) {
        n_out <-
            min(n_out, length(z) - 3) # the number of allowed outliers is decided
        tmp_ave <- mean(y) # the mean is calculated
        tmp_dif <- abs(y - tmp_ave) # the difference to the mean is calculated
        names(tmp_dif) <-
            z # tmp_dif and y are named by z to decide for outliers
        names(y) <- z
        out <-
            sort(tmp_dif, decreasing = TRUE)[1] # out is is the sorted vector of
        #differences to the mean
        tmp_score <-
            sum(tmp_dif) # the sum of the differences to the mean is used as score
        tmp_mean <- tmp_ave # the mean is cached
        if (n_out >= 1) {
            # checks if more than 0 outliers are allowed
            for (i in seq_len(n_out)) {
                # the loop iterates over the number of allowed outliers
                tmp_out <- names(out) # all but the i worst are selected
                tmp_y <- y[!names(y) %in% tmp_out]
                tmp_ave_o <- mean(tmp_y) # new mean
                tmp_dif_o <- abs(tmp_y - tmp_ave_o) # new difference to mean
                out <- c(out, sort(tmp_dif_o, decreasing = TRUE)[1])
                tmp_score_o <-
                    sum(tmp_dif_o) + pen * i # new score with outliers penalty
                tmp_score <- c(tmp_score, tmp_score_o) # the score(s) are cached
                tmp_mean <- c(tmp_mean, tmp_ave_o) # the mean(s) are cached
            }
        }
        mi <-
            which(tmp_score == min(tmp_score))[1] # the lowest score is selected
        nam <- paste0(z, collapse = ",") # all names (z) are collected
        nam <- paste0(nam, "_", tmp_mean[mi]) # the mean is pasted to the name
        if (mi > 1) {
            # checks if outliers were found
            outlier <-
                paste(names(out)[seq_len(mi - 1)], collapse = ",") # pastes all
            #outliers together
            nam <- paste0(nam, "_", outlier) # pastes the outliers to the mean
        }
        res <- tmp_score[mi] # the lowest score
        names(res) <- nam # the name
        res
    }


/*
 * File: oarith.r
 *  Contents: arithmetic operators + - * / % ^.  Auxiliary routines
 *   iipow, ripow.
 *
 * The arithmetic operators all follow a canonical conversion
 * protocol encapsulated in the macro ArithOp.
 */

#ifdef DataParallel
int list_add(dptr x, dptr y, dptr z);
#endif					/* DataParallel */

#begdef ArithOp(icon_op, func_name, c_int_op, c_real_op, c_list_op)

   operator{1} icon_op func_name(x, y)
      declare {
#ifdef LargeInts
         tended struct descrip lx, ly;
#endif					/* LargeInts */
	 C_integer irslt;
         }
#ifdef DataParallel
      if is:list(x) then {
         abstract {
            return type(x) ++ type(y)
	    }
	 inline { c_list_op(&x, &y, &result); return result; }
         }
      else
#endif					/* DataParallel */
      arith_case (x, y) of {
         C_integer: {
            abstract {
               return integer
               }
            inline {
               int over_flow = 0;
               c_int_op(x,y);
               }
            }
         integer: { /* large integers only */
            abstract {
               return integer
               }
            inline {
               big_ ## c_int_op(x,y);
               }
            }
         C_double: {
            abstract {
               return real
               }
            inline {
               c_real_op(x, y);
               }
            }
         }
end

#enddef

/*
 * x / y
 */

#begdef big_Divide(x,y)
{
   if ( ( Type ( y ) == T_Integer ) && ( IntVal ( y ) == 0 ) )
      runerr(201);  /* Divide fix */

   if (bigdiv(&x,&y,&result) == RunError) /* alcbignum failed */
      runerr(0);
   return result;
}
#enddef
#begdef Divide(x,y)
{
   if (y == 0)
      runerr(201);  /* divide fix */

   irslt = div3(x,y, &over_flow);
   if (over_flow) {
#ifdef LargeInts
      MakeInt(x,&lx);
      MakeInt(y,&ly);
      if (bigdiv(&lx,&ly,&result) == RunError) /* alcbignum failed */
	 runerr(0);
      return result;
#else                                   /* LargeInts */
      runerr(203);
#endif                                  /* LargeInts */
      }
   else return C_integer irslt;
}
#enddef
#begdef RealDivide(x,y)
{
   double z;

   if (y == 0.0)
      runerr(204);

   z = x / y;
   return C_double z;
}
#enddef

ArithOp( / , divide , Divide , RealDivide, list_add /* bogus */)

/*
 * x - y
 */

#begdef big_Sub(x,y)
{
   if (bigsub(&x,&y,&result) == RunError) /* alcbignum failed */
      runerr(0);
   return result;
}
#enddef

#begdef Sub(x,y)
   irslt = sub(x,y, &over_flow);
   if (over_flow) {
#ifdef LargeInts
      MakeInt(x,&lx);
      MakeInt(y,&ly);
      if (bigsub(&lx,&ly,&result) == RunError) /* alcbignum failed */
         runerr(0);
      return result;
#else					/* LargeInts */
      runerr(203);
#endif					/* LargeInts */
      }
   else return C_integer irslt;
#enddef

#define RealSub(x,y) return C_double (x - y);

ArithOp( - , minus , Sub , RealSub, list_add /* bogus */)

/*
 * x % y
 */

#define Abs(x) ((x) > 0 ? (x) : -(x))

#begdef big_IntMod(x,y)
{
   if ( ( Type ( y ) == T_Integer ) && ( IntVal ( y ) == 0 ) ) {
      irunerr(202,0);
      errorfail;
      }
   if (bigmod(&x,&y,&result) == RunError)
      runerr(0);
   return result;
}
#enddef

#begdef IntMod(x,y)
{
   irslt = mod3(x,y, &over_flow);
   if (over_flow) {
      irunerr(202,y);
      errorfail;
      }
   return C_integer irslt;
}
#enddef

#begdef RealMod(x,y)
{
   double d;

   if (y == 0.0)
      runerr(204);

   d = fmod(x, y);
   /* d must have the same sign as x */
   if (x < 0.0) {
      if (d > 0.0) {
         d -= Abs(y);
         }
      }
   else if (d < 0.0) {
      d += Abs(y);
      }
   return C_double d;
}
#enddef

ArithOp( % , mod , IntMod , RealMod, list_add /* bogus */ )

/*
 * x * y
 */

#begdef big_Mpy(x,y)
{
   if (bigmul(&x,&y,&result) == RunError)
      runerr(0);
   return result;
}
#enddef

#begdef Mpy(x,y)
   irslt = mul(x,y,&over_flow);
   if (over_flow) {
#ifdef LargeInts
      MakeInt(x,&lx);
      MakeInt(y,&ly);
      if (bigmul(&lx,&ly,&result) == RunError) /* alcbignum failed */
         runerr(0);
      return result;
#else					/* LargeInts */
      runerr(203);
#endif					/* LargeInts */
      }
   else return C_integer irslt;
#enddef

#define RealMpy(x,y) return C_double ((long double)x * (long double)y);

ArithOp( * , mult , Mpy , RealMpy, list_add /* bogus */ )

"-x - negate x."

operator{1} - neg(x)
   if cnv:(exact)C_integer(x) then {
      abstract {
         return integer
         }
      inline {
	    C_integer i;
	    int over_flow = 0;

	    i = neg(x, &over_flow);
	    if (over_flow) {
#ifdef LargeInts
	       struct descrip tmp;
	       MakeInt(x,&tmp);
	       if (bigneg(&tmp, &result) == RunError)  /* alcbignum failed */
	          runerr(0);
               return result;
#else					/* LargeInts */
	       irunerr(203,x);
               errorfail;
#endif					/* LargeInts */
               }
         return C_integer i;
         }
      }
#ifdef LargeInts
   else if cnv:(exact) integer(x) then {
      abstract {
         return integer
         }
      inline {
	 if (bigneg(&x, &result) == RunError)  /* alcbignum failed */
	    runerr(0);
	 return result;
         }
      }
#endif					/* LargeInts */
   else {
      if !cnv:C_double(x) then
         runerr(102, x)
      abstract {
         return real
         }
      inline {
         double drslt;
	 drslt = -x;
         return C_double drslt;
         }
      }
end

"+x - convert x to a number."
/*
 *  Operational definition: generate runerr if x is not numeric.
 */
operator{1} + number(x)
   if cnv:(exact)C_integer(x) then {
       abstract {
          return integer
          }
       inline {
          return C_integer x;
          }
      }
#ifdef LargeInts
   else if cnv:(exact) integer(x) then {
       abstract {
          return integer
          }
       inline {
          return x;
          }
      }
#endif					/* LargeInts */
   else if cnv:C_double(x) then {
       abstract {
          return real
          }
       inline {
          return C_double x;
          }
      }
   else
      runerr(102, x)
end

/*
 * x + y
 */

#begdef big_Add(x,y)
{
   if (bigadd(&x,&y,&result) == RunError)
      runerr(0);
   return result;
}
#enddef

#begdef Add(x,y)
   irslt = add(x,y, &over_flow);
   if (over_flow) {
#ifdef LargeInts
      MakeInt(x,&lx);
      MakeInt(y,&ly);
      if (bigadd(&lx, &ly, &result) == RunError)  /* alcbignum failed */
	 runerr(0);
      return result;
#else					/* LargeInts */
      runerr(203);
#endif					/* LargeInts */
      }
   else return C_integer irslt;
#enddef

#define RealAdd(x,y) return C_double (x + y);

ArithOp( + , plus , Add , RealAdd, list_add )

#ifdef DataParallel

int list_add(dptr x, dptr y, dptr z)
{
   tended struct b_list *lp1;
   word size1, size2;
   word i, j, slot;

   if (is:list(*x) && is:list(*y)) {
      size1 = BlkLoc(*x)->List.size;
      size2 = BlkLoc(*y)->List.size;
      if (size1 != size2) return RunError;
#ifdef Arrays
      if ( BlkType(BlkD(*x,List)->listhead)==T_Realarray){
	 double *a, *c;

	 if ( BlkType(BlkD(*y,List)->listhead)==T_Realarray){ /*the two are real arrays*/
	    double *b;
	    if (cprealarray(x, z, (word) 1, size1 + 1) == RunError)
	       return RunError;
	    /* points to the three arrays data and copy! */
	    a = ((struct b_realarray *) BlkLoc(*x)->List.listhead )->a;
	    b = ((struct b_realarray *) BlkLoc(*y)->List.listhead )->a;
	    c = ((struct b_realarray *) BlkLoc(*z)->List.listhead)->a;

	    for(i=0; i<size1; i++)
	       c[i] = a[i] + b[i];
	    } /* two real arrays*/
	 else if ( BlkType(BlkD(*y,List)->listhead)==T_Intarray){ /*first arrays is real, second is int*/
	    word *b;

	    if (cprealarray(x, z, (word) 1, size1 + 1) == RunError)
	       return RunError;

	    a = ((struct b_realarray *) BlkLoc(*x)->List.listhead )->a;
	    b =  ((struct b_intarray *) BlkLoc(*y)->List.listhead )->a;
	    c = ((struct b_realarray *) BlkLoc(*z)->List.listhead)->a;
	    /* a is real, b is int, hopefully the c compiler knows how to do it*/
	    for(i=0; i<size1; i++)
	       c[i] = a[i] + b[i];
	    } /* two real arrays*/
	 else{
	    /* the second list is a List */
	    tended union block *ep;
	    tended struct b_realarray *apa, *apc;
	    word k=0;
	    double f;

	    if (cprealarray(x, z, (word) 1, size1 + 1) == RunError)
	       return RunError;

	    apa = (struct b_realarray *) BlkLoc(*x)->List.listhead;
	    apc = (struct b_realarray *) BlkLoc(*z)->List.listhead;

	    for (ep = BlkD(*y,List)->listhead; BlkType(ep) == T_Lelem;
	       ep = Blk(ep,Lelem)->listnext){
	       for (i = 0; i < Blk(ep,Lelem)->nused; i++) {
		  j = ep->Lelem.first + i;
		  if (j >= ep->Lelem.nslots)
		  j -= ep->Lelem.nslots;

		  if (!cnv:C_double(ep->Lelem.lslots[j], f))
		     return RunError;

		  apc->a[k] = apa->a[k] + f;
		  k++;
		  }
	       }
	    }
	 }
      else if ( BlkType(BlkD(*x,List)->listhead)==T_Intarray){
	 word *a;

	 if ( BlkType(BlkD(*y,List)->listhead)==T_Realarray){ /*first arrays is int, second is real*/
	    double *b, *c;
	    if (cprealarray(y, z, (word) 1, size1 + 1) == RunError)
	       return RunError;
	    /* points to the three arrays data and copy! */
	    a = ((struct b_intarray *) BlkLoc(*x)->List.listhead )->a;
	    b = ((struct b_realarray *) BlkLoc(*y)->List.listhead )->a;
	    c = ((struct b_realarray *) BlkLoc(*z)->List.listhead)->a;

	    for(i=0; i<size1; i++)
	       c[i] = a[i] + b[i];
	    }
	 else if ( BlkType(BlkD(*y,List)->listhead)==T_Intarray){  /*the two are int arrays*/
	    word *b, *c;

	    if (cpintarray(x, z, (word) 1, size1 + 1) == RunError)
	       return RunError;

	    a = ((struct b_intarray *) BlkLoc(*x)->List.listhead )->a;
	    b =  ((struct b_intarray *) BlkLoc(*y)->List.listhead )->a;
	    c = ((struct b_intarray *) BlkLoc(*z)->List.listhead)->a;
	    /* a is real, b is int, hopefully the c compiler knows how to do it*/
	    for(i=0; i<size1; i++)
	       c[i] = a[i] + b[i];
	    } /* two real arrays*/
	 else{
	    /* the second list is a List */
	    tended union block *ep;
	    tended struct b_intarray *apa, *apc;
	    word k=0, d;

	    if (cpintarray(x, z, (word) 1, size1 + 1) == RunError)
	       return RunError;

	    apa = (struct b_intarray *) BlkLoc(*x)->List.listhead;
	    apc = (struct b_intarray *) BlkLoc(*z)->List.listhead;

	    for (ep = BlkD(*y,List)->listhead; BlkType(ep) == T_Lelem;
	       ep = Blk(ep,Lelem)->listnext){
	       for (i = 0; i < Blk(ep,Lelem)->nused; i++) {
		  j = ep->Lelem.first + i;
		  if (j >= ep->Lelem.nslots)
		     j -= ep->Lelem.nslots;

		  /* default : The resutling array is of type int */
		  if (Type(ep->Lelem.lslots[j]) == T_Integer ){
		     if (!cnv:C_integer(ep->Lelem.lslots[j], d))
			return RunError;
		     apc->a[k] = apa->a[k] + d;
		     k++;
		     }
		  else{
		     /* we might be able to continue with real, copy the elements to
		      * a new realarray and continue
		      */
		     tended struct b_realarray *apc2;
		     double f;
		     word ii;
		     if (cpint2realarray(x, z, (word) 1, size1 + 1) == RunError)
			return RunError;

		     apc2 = (struct b_realarray *) BlkLoc(*z)->List.listhead;
		     for (ii=0; ii<k; ii++)
			apc2->a[ii] = apc->a[ii];

		     /* where we stoped in the last list lelem*/
		     ii=i;
		     /* no need to start over since elements were copied already*/
		     for (/*ep = BlkD(*y,List)->listhead*/;
			BlkType(ep) == T_Lelem; ep = Blk(ep,Lelem)->listnext){
			for (i = ii; i < Blk(ep,Lelem)->nused; i++) {
			   j = ep->Lelem.first + i;
			   if (j >= ep->Lelem.nslots)
			      j -= ep->Lelem.nslots;
			   if (!cnv:C_double(ep->Lelem.lslots[j], f))
			      return RunError;
			   apc2->a[k] = apa->a[k] + f;
			   k++;
			   }
			ii=0;
			}
		     return Succeeded;
		     }
		  } /*for i=0 */
	       } /* for ep = */
	    }
	 }
      else if ( BlkType(BlkD(*y,List)->listhead)==T_Realarray){
	 tended union block *ep;
	 tended struct b_realarray *apa, *apc;
	 word k=0;
	 double f;

	 if (cprealarray(y, z, (word) 1, size1 + 1) == RunError)
	    return RunError;

	 apa = (struct b_realarray *) BlkLoc(*y)->List.listhead;
	 apc = (struct b_realarray *) BlkLoc(*z)->List.listhead;

	 for (ep = BlkD(*x,List)->listhead; BlkType(ep) == T_Lelem;
	    ep = Blk(ep,Lelem)->listnext){
	    for (i = 0; i < Blk(ep,Lelem)->nused; i++) {
	       j = ep->Lelem.first + i;
	       if (j >= ep->Lelem.nslots)
		  j -= ep->Lelem.nslots;

	       if (!cnv:C_double(ep->Lelem.lslots[j], f))
		  return RunError;

	       apc->a[k] = apa->a[k] + f;
	       k++;
	       }
	    }
	 }
      else if ( BlkType(BlkD(*y,List)->listhead)==T_Intarray){
	 tended union block *ep;
	 tended struct b_intarray *apa, *apc;
	 word k=0, d;

	 if (cpintarray(y, z, (word) 1, size1 + 1) == RunError)
	    return RunError;

	 apa = (struct b_intarray *) BlkLoc(*y)->List.listhead;
	 apc = (struct b_intarray *) BlkLoc(*z)->List.listhead;

	 for (ep = BlkD(*x,List)->listhead; BlkType(ep) == T_Lelem;
	    ep = Blk(ep,Lelem)->listnext){
	    for (i = 0; i < Blk(ep,Lelem)->nused; i++) {
	       j = ep->Lelem.first + i;
	       if (j >= ep->Lelem.nslots)
		  j -= ep->Lelem.nslots;

	       /* default : The resutling array is of type int */
	       if (Type(ep->Lelem.lslots[j]) == T_Integer ){
		  if (!cnv:C_integer(ep->Lelem.lslots[j], d))
		     return RunError;
		  apc->a[k] = apa->a[k] + d;
		  k++;
		  }
	       else{
		  /* we might be able to continue with real, copy the elements to
		   * a new realarray and continue
		   */
		  tended struct b_realarray *apc2;
		  double f;
		  word ii;
		  if (cpint2realarray(y, z, (word) 1, size1 + 1) == RunError)
		     return RunError;

		  apc2 = (struct b_realarray *) BlkLoc(*z)->List.listhead;
		  for (ii=0; ii<k; ii++)
		     apc2->a[ii] = apc->a[ii];
		   /* where we stoped in the last list lelem*/
		  ii=i;
		  /* no need to start over since elements were copied already*/
		  for (/*ep = BlkD(*x,List)->listhead*/;
		     BlkType(ep) == T_Lelem; ep = Blk(ep,Lelem)->listnext){
		     for (i = ii; i < Blk(ep,Lelem)->nused; i++) {
			j = ep->Lelem.first + i;
			if (j >= ep->Lelem.nslots)
			   j -= ep->Lelem.nslots;
			if (!cnv:C_double(ep->Lelem.lslots[j], f))
			   return RunError;
			apc2->a[k] = apa->a[k] + f;
			k++;

			}
			ii=0;
		     }
		  return Succeeded;

		  }
	       } /*for i=0*/
	    } /* for ep */
	 }
      else{ /* the two lists are of type List  */
#endif					/* Arrays */
	 struct descrip *slotptr;
	 tended struct b_lelem *bp1;
	 if (cplist(x, z, (word)1, size1 + 1) == RunError)
	    return RunError;
	 /* add in values from y */

	 lp1 = (struct b_list *) BlkLoc(*y);
	 bp1 = (struct b_lelem *) lp1->listhead;
	 i = 1;
	 slot = 0;
	 while (size2 > 0) {
	    j = bp1->first + i - 1;
	    if (j >= bp1->nslots)
	       j -= bp1->nslots;
	    slotptr = BlkLoc(*z)->List.listhead->Lelem.lslots + slot++;
	    list_add(slotptr, bp1->lslots+j, slotptr);
	    if (++i > bp1->nused) {
	       i = 1;
	       bp1 = (struct b_lelem *) bp1->listnext;
	       }
	    size2--;
	    }
#ifdef Arrays
	 }
#endif
      }
   else if (is:list(*x)) {
      /* x a list, y a scalar */
#ifdef Arrays
      if ( BlkType(BlkD(*x,List)->listhead)==T_Realarray){
	 double *a, *c, f;
	 size1 = BlkLoc(*x)->List.size;

	 if (cprealarray(x, z, (word) 1, size1 + 1) == RunError)
	    return RunError;
	 if (!cnv:C_double(*y, f))
	    return RunError;

	 a =  ((struct b_realarray *) BlkLoc(*x)->List.listhead )->a;
	 c =  ((struct b_realarray *) BlkLoc(*z)->List.listhead )->a;

	 for(i=0; i<size1; i++)
	    c[i] = a[i] + f ;
	 }
      else if ( BlkType(BlkD(*x,List)->listhead)==T_Intarray){
	 word *a, d;
	 double f;
	 size1 = BlkLoc(*x)->List.size;
	 if ( Type ( *y ) == T_Integer ){
	    word *c;
	    if (!cnv:C_integer(*y, d))
	       return RunError;
	    if (cpintarray(x, z, (word) 1, size1 + 1) == RunError)
	       return RunError;
	    a =  ((struct b_intarray *) BlkLoc(*x)->List.listhead )->a;
	    c =  ((struct b_intarray *) BlkLoc(*z)->List.listhead )->a;
	    for(i=0; i<size1; i++)
	       c[i] = a[i] + d ;
	    }
	 else if (cnv:C_double(*y, f)){
	    double *c;
	    if (cpint2realarray(x, z, (word) 1, size1 + 1, 0 /* no need to copy elements */) == RunError)
	       return RunError;
	    a =  ((struct b_intarray *) BlkLoc(*x)->List.listhead )->a;
	    c =  ((struct b_realarray *) BlkLoc(*z)->List.listhead )->a;
	    for(i=0; i<size1; i++)
	       c[i] = a[i] + f ;
	    }
	 else
	    return RunError;
	 }
      else{
#endif					/* Arrays*/
	 struct descrip *slotptr;
	 size1 = BlkLoc(*x)->List.size;
	 if (cplist(x, z, (word)1, size1 + 1) == RunError)
	    return RunError;
	 for (i=0; i<size1; i++) {
	    slotptr = BlkLoc(*z)->List.listhead->Lelem.lslots + i;
	    list_add(slotptr, y, slotptr);
	    }
#ifdef Arrays
      }
#endif					/* Arrays */
      }
   else if (is:list(*y)) {
      /* y a list, x a scalar */
#ifdef Arrays
      if ( BlkType(BlkD(*y,List)->listhead)==T_Realarray){
	 double *a, *c, f;
	 size1 = BlkLoc(*y)->List.size;

	 if (cprealarray(y, z, (word) 1, size1 + 1) == RunError)
	    return RunError;
	 if (!cnv:C_double(*x, f))
	    return RunError;

	 a =  ((struct b_realarray *) BlkLoc(*y)->List.listhead )->a;
	 c =  ((struct b_realarray *) BlkLoc(*z)->List.listhead )->a;

	 for(i=0; i<size1; i++)
	    c[i] = a[i] + f ;
	 }
      else if ( BlkType(BlkD(*y,List)->listhead)==T_Intarray){
	 word *a, d;
	 double f;
	 size1 = BlkLoc(*y)->List.size;
	 if ( Type ( *x ) == T_Integer ){
	    word *c;
	    if (!cnv:C_integer(*x, d))
	       return RunError;
	    if (cpintarray(y, z, (word) 1, size1 + 1) == RunError)
	       return RunError;
	    a =  ((struct b_intarray *) BlkLoc(*y)->List.listhead )->a;
	    c =  ((struct b_intarray *) BlkLoc(*z)->List.listhead )->a;
	    for(i=0; i<size1; i++)
	       c[i] = a[i] + d ;
	    }
	 else if (cnv:C_double(*x, f)){
	    double *c;
	    if (cpint2realarray(y, z, (word) 1, size1 + 1, 0 /* no need to copy elements */) == RunError)
	       return RunError;
	    a =  ((struct b_intarray *) BlkLoc(*y)->List.listhead )->a;
	    c =  ((struct b_realarray *) BlkLoc(*z)->List.listhead )->a;
	    for(i=0; i<size1; i++)
	       c[i] = a[i] + f ;
	    }
	 else
	    return RunError;
	 }
      else{
#endif					/* Arrays */
	 struct descrip *slotptr;
	 size1 = BlkLoc(*y)->List.size;
	 if (cplist(y, z, (word)1, size1 + 1) == RunError)
	    return RunError;
	 for (i=0; i<size1; i++) {
	    slotptr = BlkLoc(*z)->List.listhead->Lelem.lslots + i;
	 list_add(slotptr, x, slotptr);
	 }
#ifdef Arrays
	 }
#endif					/* Arrays */
      }
   else {
      C_integer tmp, tmp2, irslt;
      double tmp3, tmp4;
#ifdef LargeInts
      tended struct descrip lx, ly;
#endif					/* LargeInts */

      /* x, y must be numeric */
      if (cnv:(exact)C_integer(*x, tmp) && cnv:(exact)C_integer(*y, tmp2)) {
         irslt = add(tmp,tmp2);
	 if (over_flow) {
#ifdef LargeInts
            MakeInt(x,&lx);
            MakeInt(y,&ly);
            if (bigadd(&lx, &ly, z) == RunError)  /* alcbignum failed */
               return RunError;
#endif					/* LargeInts */
	    }
	 else MakeInt(irslt, z);
         }
      else if (cnv:C_double(*x, tmp3) && cnv:C_double(*y, tmp4)) {
         }
      else return RunError;
      }
   return Succeeded;
}
#endif					/* DataParallel */

"x ^ y - raise x to the y power."

operator{1} ^ powr(x, y)
   if cnv:(exact)C_integer(y) then {
      if cnv:(exact)integer(x) then {
	 abstract {
	    return integer
	    }
	 inline {
#ifdef LargeInts
	    tended struct descrip ly;
	    MakeInt ( y, &ly );
	    if (bigpow(&x, &ly, &result) == RunError)  /* alcbignum failed */
	       runerr(0);
	    return result;
#else
	    int over_flow;
	    C_integer r = iipow(IntVal(x), y, &over_flow);
	    if (over_flow)
	       runerr(203);
	    return C_integer r;
#endif
	   }
	 }
      else {
	 if !cnv:C_double(x) then
	    runerr(102, x)
	 abstract {
	    return real
	    }
	 inline {
	    if (ripow( x, y, &result) ==  RunError)
	       runerr(0);
	    return result;
	    }
	 }
      }
#ifdef LargeInts
   else if cnv:(exact)integer(y) then {
      if cnv:(exact)integer(x) then {
	 abstract {
	    return integer
	    }
	 inline {
	    if (bigpow(&x, &y, &result) == RunError)  /* alcbignum failed */
	       runerr(0);
	    return result;
	    }
	 }
      else {
	 if !cnv:C_double(x) then
	    runerr(102, x)
	 abstract {
	    return real
	    }
	 inline {
	    if ( bigpowri ( x, &y, &result ) == RunError )
	       runerr(0);
	    return result;
	    }
	 }
      }
#endif					/* LargeInts */
   else {
      if !cnv:C_double(x) then
	 runerr(102, x)
      if !cnv:C_double(y) then
	 runerr(102, y)
      abstract {
	 return real
	 }
      inline {
	 if (x == 0.0 && y < 0.0)
	     runerr(204);
	 if (x < 0.0)
	    runerr(206);
	 return C_double pow(x,y);
	 }
      }
end

#if COMPILER || !(defined LargeInts)
/*
 * iipow - raise an integer to an integral power.
 */
C_integer iipow(C_integer n1, C_integer n2, int *over_flowp)
   {
   C_integer result;

   /* Handle some special cases first */
   *over_flowp = 0;
   switch ( n1 ) {
      case 1:
	 return 1;
      case -1:
	 /* Result depends on whether n2 is even or odd */
	 return ( n2 & 01 ) ? -1 : 1;
      case 0:
	 if ( n2 <= 0 )
	    *over_flowp = 1;
	 return 0;
      default:
	 if (n2 < 0)
	    return 0;
      }

   result = 1L;
   for ( ; ; ) {
      if (n2 & 01L)
	 {
	 result = mul(result, n1, over_flowp);
	 if (*over_flowp)
	    return 0;
	 }

      if ( ( n2 >>= 1 ) == 0 ) break;
      n1 = mul(n1, n1, over_flowp);
      if (*over_flowp)
	 return 0;
      }
   *over_flowp = 0;
   return result;
   }
#endif					/* COMPILER || !(defined LargeInts) */

/*
 * ripow - raise a real number to an integral power.
 */
int ripow(r, n, drslt)
double r;
C_integer n;
dptr drslt;
   {
   double retval;
   CURTSTATE();

   if (r == 0.0 && n <= 0)
      ReturnErrNum(204, RunError);
   if (n < 0) {
      /*
       * r ^ n = ( 1/r ) * ( ( 1/r ) ^ ( -1 - n ) )
       *
       * (-1) - n never overflows, even when n == MinLong.
       */
      n = (-1) - n;
      r = 1.0 / r;
      retval = r;
      }
   else
      retval = 1.0;

   /* multiply retval by r ^ n */
   while (n > 0) {
      if (n & 01L)
	 retval *= r;
      r *= r;
      n >>= 1;
      }
#ifdef DescriptorDouble
   drslt->vword.realval = retval;
#else					/* DescriptorDouble */
   Protect(BlkLoc(*drslt) = (union block *)alcreal(retval), return RunError);
#endif					/* DescriptorDouble */
   drslt->dword = D_Real;
   return Succeeded;
   }


# Modelo RF simples para a classificação de um raster a partir de informações extraidas de pontos amostrais coletados.

# instalando as bibliotecas:
install.packages("randomForest")
install.packages("sf")
install.packages("tidyverse")
install.packages("raster")
install.packages("tiff")
install.packages("magrittr")
library(magrittr)
library(randomForest)
library(sf)
library(tidyverse)
library(raster)
library(tiff)

# Carregando os dados: ----
# raster
setwd("C:/meu_diretorio/tif_wgs")
img <- stack(list.files(".", pattern = ".tif$", full.names = T))

plotRGB(img, 4, 2, 1, stretch = 'hist') #para uma imagem pleiades, blue=1, green=2, nir=3, red=4
names(img) <- paste0(rep('band', nlayers(img)), 1:nlayers(img))

# amostras
setwd("C:/meu_diretorio/shapes_wgs")
c1 <- read_sf("classe1.shp")
c2 <-read_sf("classe2.shp")
c3 <-read_sf("classe3.shp")
c4 <-read_sf("classe4.shp")
amostras<-rbind(c1, c2, c3, c4)
plot(amostras, add=T)
x <- c(1:20000)
amostras<-cbind(amostras,x)

# Amostras de treino de teste ----
teste <- amostras %>% group_by(classe) %>% sample_n(size = 1500 ) #note que "classe" é um atributo de cada entrada do conjunto de dados
#1500 amostras de teste por classe
treino <- amostras %>% filter(! x %in% (teste$x))
nrow(treino)
nrow(teste)

# Extração de dados: ----
valsTrain <- raster::extract(img,treino)
valsTest <- raster::extract(img, teste)

head(valsTrain)
head(valsTest)

valsTrain <- data.frame(valsTrain, treino$classe)
valsTest <- data.frame(valsTest, teste$classe)
head(valsTrain)
head(valsTest)
names(valsTrain)[ncol(valsTrain)] <- "class"
names(valsTest)[ncol(valsTest)] <- "class"

valsTrain$class <- as.factor(valsTrain$class)
valsTest$class <- as.factor(valsTest$class)

class(valsTrain$class)

# Criando modelo randomForest ----
rf.mdl <- randomForest(valsTrain$class ~., data = valsTrain, xtest = subset(valsTest, select = -class), ytest = valsTest$class, keep.forest = TRUE)

#confusionMatrix da fase de treinamento
setwd("C:/meu_diretorio")
rf.mdl$confusion

options(max.print = 6000)

#cálculo do kappa nos dados de teste
rf.mdl$test$predicted
write.table(rf.mdl$test$predicted, file = "testPredicted.txt", sep = "\t")

install.packages("irr",dependencies = T)
library(irr)

dadoskappa<-read.table("testPredicted.txt", header = T)
kappa2(dadoskappa)

# plot da importância das bandas
getTree(rf.mdl, k=1)
varImpPlot(rf.mdl)

# Classificação ----
rf.class <- raster::predict(img, rf.mdl, progress = "text", type = "response")

# Salvando classificação: ----
writeRaster(rf.class, "rf_ClassificationCrossValidation.tif", overwrite = TRUE)


GenderIndexPCA <- function(data) {

  pcaColumns <- imputePCA(data, method = "EM", ncp = 1)
  pca <- prcomp(pcaColumns$completeObs, scale. = T)

  genderIndex <- pca$x[, 1]

  return(genderIndex)
}


#!/usr/bin/env Rscript

library(methods)
# library(Matrix)
library(dplyr)
library(purrr)
library(MASS)
library(mvtnorm)
library(lpSolve)
library(glmnet)
library(Rmosek)
source("src/dgm.r", chdir = TRUE)
source("src/estimation.r", chdir = TRUE)
source("src/utils.r", chdir = TRUE)
source("src/trial.r", chdir = TRUE)

trial()


pdf_file<-"pdf/timeseries_daily_monthly_labels.pdf"
cairo_pdf(bg="grey98", pdf_file,width=14,height=8)

par(omi=c(0.65,0.75,0.95,0.75),mai=c(0.9,0.75,0.25,0),family="Lato Light",las=1)

# Import data and prepare chart

euro<-read.csv("myData/eurofxref-hist.csv")
euro<-euro[as.Date(euro$Date)>as.Date("2010-08-01"),]
myBeginOfMonth<-seq(as.Date("2010-08-01"),as.Date("2012-08-01"),by="1 months")
myDays<-rev(as.Date(euro$Date))
myValues<-rev(euro$USD)

# Define chart and other elements

plot(myDays,myValues,axes=F,type="n",xlab="",ylab="")
lines(myDays,myValues,col="grey")
myLColour<-rgb(255,97,0,100,maxColorValue=255)
lines(lowess(myDays,myValues,f=1/25),col=myLColour,lwd=5)
par(mgp=c(3,1.5,0))
axis(1,at=myBeginOfMonth,labels=format(myBeginOfMonth,"%b\n%Y"),cex.axis=0.75)
axis(2)
legend("bottomleft","Lowess-filter f=1/25",pch=15,col=myLColour,bty="n",cex=2)

# Titling

mtext("Exchange rate US Dollar/Euro 2010-2012",3,line=0,adj=0,cex=2.5,family="Lato Black",outer=T)
mtext("Daily values",3,line=-2,adj=0,cex=1.75,font=3,outer=T)
mtext("Source: www.ecb.stats/exchange/eurofxref/html/index/html",1,line=4,adj=1.0,cex=1.25,font=3)
dev.off()


# Functions for making cool graphs of RNA Seq data

# imports
library(ggplot2)
library("RColorBrewer")

plot_pca <- function(DESeq_object, metadata) {
    # Taken from UCSD BIOM262 2017
    # This only works if it has a condition and batch
    # One day I will code this to be more flexible
    rld <- rlog(DESeq_object)

    data <- plotPCA(rld, intgroup="condition", returnData=TRUE)
    data$batch <- as.factor(metadata$batch)

    percentVar <- round(100 * attr(data, "percentVar"))
    p <- ggplot(data, aes(PC1, PC2, color=condition, shape=batch)) +
            geom_point(size=3) +
            xlab(paste0("PC1: ",percentVar[1],"% variance")) +
            ylab(paste0("PC2: ",percentVar[2],"% variance"))

    return(p)
}

plot_sample_distances <- function(dds) {
    # Got this code from UCSD BIOM262 course 2017
    rld <- rlog(dds)
    sampleDists <- dist(t(assay(rld)))
    sampleDistMatrix <- as.matrix(sampleDists)

    rownames(sampleDistMatrix) <- paste(rld$id)

    colnames(sampleDistMatrix) <- paste(rld$id)

    colors <- colorRampPalette( rev(brewer.pal(9, "Blues")) )(255)

    plt <- heatmap(sampleDistMatrix,
            clustering_distance_rows=sampleDists,
            clustering_distance_cols=sampleDists,
            col=colors)

    return(plt)
}

plot_volcano <- function(results_table) {

}

plot_volcano_facet_gene_type <- function(results_table, gene_type_vector) {

}


DF <- data.frame(y=rnorm(21), `x 1`=-10:10., check.names = FALSE)


#' Title
#'
#' @param model
#' @param parms
#' @param over
#' @param xrange
#' @param res
#' @param ini
#' @param t_max
#' @param method
#' @param colors
#' @param new
#'
#' @return
#' @export
#'
#' @examples
#' library(rgl)
#' p <- set_parms(livestock$defparms, set = list(b = 0.9, c = 0.2, f = 0, p = 0, alpha = 0.2))
#' plot_bifurcation3D(livestock, parms = p, res = 31)
#'
plot_bifurcation3D <- function(
                      model,
                      parms = model$parms,
                      over = "b",
                      xrange = c(0,1),
                      res = 21,
                      ini = c(0.9, 0.0001),
                      t_max = 150,
                      method = "ode45",
                      colors = c("#000000","#009933"),
                      new = FALSE
                    ) {

  plot3d(NA,NA,NA,
         xlim = c(0,1), ylim = c(0,1), zlim = c(0,1),
         xlab = "pressure", ylab = "vegetation cover", zlab = "local vegetation cover",
         type = "n", box = TRUE)
  rgl.bg(fogtype = "exp2", color = "white")

  equilibria <- sim_bifurcations(model, over = over, xrange = xrange, ini = ini, t_max = t_max, res = res, parms = parms, method = method)

  rgl.points(equilibria[,over],
             equilibria$rho_1,
             q_11(ini_rho(equilibria$rho_1, equilibria$rho_11)), color = "black", size = 8)

  parms[[over]] <- seq(xrange[1],xrange[2],length = res)
  parms$rho_ini <- ini

  iterations <- expand.grid(parms)
  iterations <- cbind(ID = 1:dim(iterations)[1],iterations)

  iterations$b <- as.numeric(as.character(iterations$b))
  iterations$L <- as.numeric(as.character(iterations$L))

  foreach(iteration = iterations$ID, .packages = c("deSolve", "livestock", "foreach")) %dopar% {

    sim_trajectories(model, parms = iterations[iteration,],
                              rho_1_ini = seq(0,0.99, length = 11),
                              times = c(0,150))

    } -> trajectories

  for(iteration in seq(iterations$ID[1], tail(iterations$ID,1),2)) {

    sapply(trajectories[[iteration]], function(x){
      rgl.linestrips(rep(iterations[iteration,]$b, times = length(x$rho_1)),
                     x$rho_1,
                     q_11(x$rho_1, x$rho_11),
                     col = "black")

    }
    )

  }

}


# Aggregate the missions by location

library(plyr)

raw <- read.csv("data/paulist-chronicles/paulist-missions.geocoded.csv")

aggregated <- ddply(raw, .(city, state, year), summarize,
                    long = max(geo.lon),
                    lat =  max(geo.lat),
                    confessions = sum(confessions_total, na.rm = TRUE),
                    converts = sum(converts_total, na.rm = TRUE),
                    number_missions = length(location))

write.csv(aggregated,
          "data/paulist-chronicles/paulist-missions.aggregated.csv",
          row.names = FALSE)


.time <- list(
  unit=c("seconds", "minutes", "hours", "days", "years", "centuries"),
  factor=c(1.0, 60.0, 3600.0, 86400.0, 31557600, 3155760000)
)

convert.time <- function(time, unit.in, unit.out)
{
  ind.in <- which(.time$unit == unit.in)
  ind.out <- which(.time$unit == unit.out)

  factor <- .time$factor[ind.in] / .time$factor[ind.out]

  return( time*factor )
}

#' Print times in a readable way.
#'
#' @param time
#' A time count.
#' @param unit
#' The unit of time (e.g. "seconds").
#'
#' @examples
#' \dontrun{
#' library(memuse)
#'
#' readable.time(10000, unit="seconds")
#' readable.time(10000, unit="minutes")
#' }
#'
#' @export
readable.time <- function(time, unit="seconds")
{
  unit <- match.arg(tolower(unit), c("seconds", "minutes"))

  if (length(time) > 1L)
    return( sapply(time, readable.time) )

  ind <- which(.time$unit == unit) + 1L

  while (time > .time$factor[ind]  &&  ind <= length(.time$factor))
    ind <- ind + 1L

  ind <- ind - 1L

  unit.out <- .time$unit[ind]

  time <- convert.time(time=time, unit.in=unit, unit.out=unit.out)

#  printer <- paste(time, unit.out)

  class(time) <- "readabletime"
  attr(time, "unit") <- unit.out

  return( time )
}

#' print.readabletime
#'
#' Print readabletiem objects.
#'
#' @param x
#' An readabletime object.
#' @param ...
#' Additional arguments (ignored).
#' @param digits
#' The (max) number of digits to display.
#'
#' @name print-readabletime
#' @rdname print-readabletime
#' @method print readabletime
#' @export
print.readabletime <- function(x, ..., digits=3)
{
  time <- round(x, digits=digits)
  unit <- attributes(x)$unit

  cat(paste(time, unit, "\n"))
  invisible()
}

#' Readable Timings
#'
#' Printing timings in their "native" unit.  For example, "10000" seconds
#' becomes "2.778 hours".
#'
#' The wall-clock timer, \code{wc.time()}, is a simple wrapper around R's
#' \code{system.time()} using these readable units.
#'
#' This uses S3 methods for simplicity, though this makes some higher
#' abstractions impossible.  Future versions will likely use S4.
#'
#' @param expr
#' A valid R expression to be timed.
#' @param gcFirst
#' logical; determines if garbage collection should be called
#' before getting process memory usage.
#'
#' @return
#' Returns a \code{timing} object, which dispalys readable times.
#'
#' @keywords Methods
#'
#' @examples
#' \dontrun{
#' library(memuse)
#'
#' wc.time(rnorm(1e6))
#' }
#'
#' @export
wc.time <- function(expr, gcFirst=TRUE)
{
  time <- base::system.time(expr=expr, gcFirst=gcFirst)[3]
  attributes(time) <- NULL

  return( readable.time(time, unit="seconds") )
}


library(quantmod)

#pick the companies to pull data for
fin <- c('GOOGL','AAPL','AMZN','EBAY','CRM','FB','PG','MMM')

#function to iterate through the companies, and mark companies that returned errors with NULL
getFin_HANDLED <- function (symb) {
    return(tryCatch(getFin(symb,auto.assign = "FALSE"), error = function(e) NULL))
 }

#iterate through the vector of companies
fin.f <- lapply(fin, getFin_HANDLED)

#name companies according to the elements of the company vector
names(fin.f) <- fin

#extract companies that returned an error
fin.n <- names(fin.f[sapply(fin.f, is.null)])
#keep companies that did not return an error
fin.f <- fin.f[!sapply(fin.f, is.null)]

save(fin.f,file = "fin_f.RData")

#fin.f is arranged as [["Company"]][["Financial Statement"]][["Quarter or Annual"]][["Individual Element"]]
#Financial Statment levels: 1 = Income Statment, 2 = Balance Sheet, 3 = Cash Flow statement
#Quarterly or Annual levels: 1 = End of Quarter, 2 = Annual (maximum 4 periods prior)
#Individual Element levels: 1 = Revenue on Income Statement and so on.

#iterate through fin.f and build a list of the annual income statements
IS_list <- lapply(names(fin.f), function (x) assign(paste(x, "IS", sep = "_"), as.data.frame(fin.f[[x]][[1]][[2]]) ))
names(IS_list) <- names(fin.f)
IS_list <- lapply(IS_list, rev)

#iterate through fin.f and build a list of the annual Balance Sheets
BS_list <- lapply(names(fin.f), function (x) assign(paste(x, "BS", sep = "_"), as.data.frame(fin.f[[x]][[2]][[2]]) ))
names(BS_list) <- names(fin.f)
BS_list <- lapply(BS_list, rev)

#iterate through fin.f and build a list of the annual Cash Flow Statements
CF_list <- lapply(names(fin.f), function (x) assign(paste(x, "CF", sep = "_"), as.data.frame(fin.f[[x]][[3]][[2]]) ))
names(CF_list) <- names(fin.f)
CF_list <- lapply(CF_list, rev)

( BS_list[["AAPL"]][[1,4]] - BS_list[["AAPL"]][[1,3]])
# returns [1] 2868
( CF_list[["AAPL"]][[17,4]] )
# returns [1] -195

#Current Assets - Current Liabilities
(BS_list[["AAPL"]][[9,4]] - BS_list[["AAPL"]][[22,4]])


### This code was written by Patrick Walker and Charlie for the LMIC global report
### Edited by Ettie for European setting

# Load Required Packages and Source Functions
library(tidyverse)
library(readxl)
library(socialmixr)
library(dfoptim)

source("utils/get-ar.r")

# Loading in Population Data and Severity Parameters
demog_WPP <- readRDS('data/country-inputs.rds')
pop_columns <- grep("pop", names(demog_WPP))
severity_inputs <- readRDS('data/severity-inputs.rds')
IFRs <- severity_inputs$IFR_adj

# Set Parameters for Optimisation
R <- 3.28
guess_hom <- 0.85 # guess homogeneous attack rate
guess_modifier <- 0.7 # guess a lower bound for extent age-specific matrix alters average attack rate
reiterates <- 3
iterates <- 10000
restarts <- 10
tol <- 1e-07
init <- 1

country_data <- read.csv("data/popt_ifr.csv", stringsAsFactors = FALSE)
countries <- unique(country_data$country)

IFR <- vector(length = length(countries))
total_pop <- vector(length = length(countries))

for (i in 1:length(countries)){
  # Pick the state You want and Extract Population
  country <- countries[i]
  idx <- which(demog_WPP$Country_or_region == country)
  raw_country_pop <- unlist(demog_WPP[idx, pop_columns])
  country_pop <- c(raw_country_pop[1:15], sum(raw_country_pop[16:21])) * 1000

  # Pick the Country You want and Extract Relevant Contact Matrix
  #   Note: Only limited countries have contact matrices available.
  # Contact matrices are taken from PolyMod apart for France
  # Mossong J, Hens N, Jit M, Beutels P, Auranen K, Mikolajczyk R, Massari M, Salmaso S, Tomba GS, Wallinga J, Heijne J, Sadkowska-Todys M, Rosinska M, Edmunds WJ (2017). “POLYMOD social contact data.” doi:10.5281/zenodo.1157934 (URL: https://doi.org/10.5281/zenodo.1157934), Version 1.1.
  contact_mat_list<-readRDS("data/contact-matrices.rds")
  contact_mat <- data.matrix((contact_mat_list[[demog_WPP$Matrix[idx]]]))

  # Processing the Contact Matrix to Generate a Probability Matrix
  # (i.e. Likelihood a person in each age group mixes with people in a different age group)
  MIJ <- t(sapply(seq(country_pop),function(x){
    contact_mat[x,]*country_pop[x]
  }))
  adjust_mat<-(MIJ+t(MIJ))/2
  new_mix_mat<-t(sapply(seq(country_pop),function(x){
    adjust_mat[x,]/country_pop[x]
  }))
  c_mat<-t(sapply(seq(country_pop),function(x){
    new_mix_mat[x,]/sum(new_mix_mat[x,])
  }))

  ai <- rowSums(new_mix_mat)
  ng_eigen <- Re(eigen(new_mix_mat)$val[1])
  rmod <- R/ng_eigen*ai
  tot_pop <- sum(country_pop)
  total_pop[i] <- tot_pop

  # Running an Optimiser to Get the Number Infected by Age for Each Age Group
  x <- get_AR(R = R, rmod = rmod, c_mat = c_mat, demog = country_pop, init = init, guess_hom = guess_hom,
              guess_modifiers = guess_modifier, iterates = iterates, reiterates = reiterates,
              restarts = restarts, tol = tol)

  # Number infected and attack rate for 5 year age bands up to 75+
  number_inf_by_age <- x$par
  attack_rates_by_age <- x$par/country_pop
  #plot(attack_rates_by_age, ylim = c(0, 1))

  # Splitting up 75+ into 75-80 and 80+ to incorporate the age-specific IFRs for these two
  # groups that we have
  infs_75_80 <- number_inf_by_age[16] * raw_country_pop[16]/(sum(raw_country_pop[16:21]))
  infs_80_plus <- number_inf_by_age[16] * sum(raw_country_pop[17:21])/(sum(raw_country_pop[16:21]))
  number_inf_by_age[16] <- infs_75_80
  number_inf_by_age[17] <- infs_80_plus

  # Calculating the number of Deaths in Each Age Group
  deaths <- number_inf_by_age * IFRs
  IFR[i] <- sum(deaths)/sum(number_inf_by_age)
}

ifrs <- data.frame("country" = countries, "popt" = total_pop, "ifr" = IFR)


# Function for generating NOEC distributions for each species
# --- EXAMPLE OF A SPECIAL CASE FOR SILVER
#
# Yields a matrix with dimensions number of species * number of iterations in the simulation
#
# Arguments:   - DP : matrix of data points
#              - UFt : matrix of uncertainty factors for the exposure time
#              - UFdd : matrix of uncertainty factors for the dose-descriptor
#              - SIM : number of iterations in the simulation
#              - CV.DP : coefficient of variation for the interlaboratory variation
#              - CV.UF : coefficient of variation for the use of non-substance-specific
#                uncertainty factors
#
# Date of last modification: 03.07.2019
#
# Associated publication: Systematic consideration of parameter uncertainty and variability in
#                         probabilistic species sensitivity distributions
#
# Authors: Henning Wigger, Delphine Kawecki, Bernd Nowack and Véronique Adam
#
# Institute: Empa, Swiss Federal Laboratories for Materials Science and Technology,
#            Technology and Society Laboratory, Lerchenfeldstrasse 5, 9014 St. Gallen, Switzerland
#
# submitted to Integrated Environmental Assessment and Management in July 2019

# -------------------------------------------------------------------------------------------------

do.pSSD.Ag <- function(DP,
                       UFt,
                       UFdd,
                       SIM,
                       CV.DP,
                       CV.UF){

  # test if there is no data available for one species
  if(any(apply(DP,2,function(x) length(which(!is.na(x)))) == 0)){
    warning("No data is available for one or more species, it/they won't contribute to the PSSD calculation.")
    # find which species has no data
    ind.sp.rem <- which(apply(DP,2,function(x) length(which(!is.na(x)))) == 0)
    # remove those columns
    DP <- DP[,-ind.sp.rem]
    UFt <- UFt[,-ind.sp.rem]
    UFdd <- UFdd[,-ind.sp.rem]
  }

  # Create the step distributions (or triangular or trapezoidal) for each species
  # Create an empty matrix in which step distributions will be compiled
  NOEC_comb <- matrix(NA, ncol(DP), SIM,
                      dimnames = list(colnames(DP), NULL))

  # Fill in the matrix. If there is only one data point, NOEC stays the same. If  there are
  # 2 endpoints, a uniform distribution is produced. If  there are more than 2 endpoints, a step
  # distribution is produced. One line is for one species.
  require(trapezoid)
  require(mc2d)

  # store the corrected endpoints
  corr.endpoints <- DP/(UFdd*UFt)
  sort.endpoints <- apply(corr.endpoints,2, sort)

  for (sp in colnames(DP)){

    # store the indices of the minimal and maximal data point
    ind.min <- which.min(corr.endpoints[,sp])
    ind.max <- which.max(corr.endpoints[,sp])

    # calculate the theoretical minimum and maximum of the distribution we are looking for
    if (UFt[ind.min, sp] == 10){
      sp.min <- corr.endpoints[ind.min,sp]*(1-(sqrt((CV.DP/2.45)^2 + (CV.UF/2.45)^2)))/100
    } else {
      sp.min <- corr.endpoints[ind.min,sp]*(1-(sqrt((CV.DP/2.45)^2 + (CV.UF/2.45)^2 + (CV.UF/2.45)^2)*2.45))
    }
    if (UFt[ind.max, sp] == 10){
      sp.max <- corr.endpoints[ind.max,sp]*(1+(sqrt((CV.DP/2.45)^2) + (CV.UF/2.45)^2))/1
    } else {
      sp.max <- corr.endpoints[ind.max,sp]*(1+(sqrt((CV.DP/2.45)^2 + (CV.UF/2.45)^2 + (CV.UF/2.45)^2)*2.45))
    }

    # For species with one unique data point, NOEC stays the same:
    if(length(unique(sort.endpoints[[sp]])) == 1){
      NOEC_comb[sp,] <- rtrunc("rtriang", min = sp.min,
                               mode = sort.endpoints[[sp]][1],
                               max = sp.max,
                               n = SIM, linf = 0)

      # For species with two endpoints:
    } else if(length(sort.endpoints[[sp]]) == 2){
      # Create a trapezoidal distribution including both endpoints
      NOEC_comb[sp,] <- rtrunc("rtrapezoid", SIM,
                               mode1 = sort.endpoints[[sp]][1],
                               mode2 = sort.endpoints[[sp]][2],
                               min = sp.min, max = sp.max,
                               linf = 0)

      # For species with three endpoints or more:
    } else {

      # Sample from this step distribution for each species
      NOEC_comb[sp,] <- rmore(values = sort.endpoints[[sp]], max = sp.max, min = sp.min, N = SIM, linf = 0)

    }
  }
  # return the whole matrix
  return(NOEC_comb)

}


# customized by Xiaoqing Rong-Mullins. 2015-10-29.
# all the ', silent = FALSE' were added by xqrm

# getPar <- function(x, type = c("fit", "curve"), cp = "cpD2", eff = "sigfit", ...) # ori
# xqrm
getPar <- function(
    x, type = c("fit", "curve"), cp = "cpD2", eff = "sigfit",
    min_reliable_cyc,
    ...)
{

  # xqrm: start counting for running time
  func_name <- 'getPar'
  start_time <- proc.time()[['elapsed']]

  type <- match.arg(type)
  options(expressions = 20000)

  if (class(x)[1] == "pcrfit") x <- modlist(x)
  if (class(x)[1] != "modlist") stop("'x' must be either of class 'pcrfit' or 'modlist'!")

  ## extract unique model names
  modNAMES <- sapply(x, function(x) x$MODEL$name)
  modNAMES <- unique(modNAMES[!is.na(modNAMES)])
  if (modNAMES %in% c("mak2", "mak3", "chag", "cm3")) type <- "fit"

  ## rownames and their length
  if (type == "fit") {
    RN <- lapply(x, function(x) names(coef(x)))
    RN <- unique(unlist(RN))
    RN <- na.omit(RN)
    NR = length(RN)
  } else {

    # # ori
    # RN <- c("ct", "eff")
    # NR = 2

    # xqrm, for D1 and D2
    RN <- c("cq", "eff", "D1max", "D2max", "cpD1", "cpD2")
    NR <- 6
  }

  ## pre-allocate matrix
  RES <- matrix(nrow = NR, ncol = length(x))
  NAMES <- sapply(x, function(a) a$name)

  for (i in 1:length(x)) {
    counter(i)
    flush.console()
    tempMOD <- x[[i]]

    ## coefficients from fit
    if (type == "fit") {
      #COEF <- try(coef(tempMOD), silent = TRUE) # ori
      COEF <- try(coef(tempMOD), silent = FALSE) # xqrm
      if (inherits(COEF, "try-error")) COEF <- NA
      if (length(COEF) > 0) RES[1:length(COEF), i] <- COEF
    }

    ## efficiency and threshold cycles
    if (type == "curve") {
      outNAME <- switch(cp, "cpD2" = "cpD2", "cpD1" = "cpD1", "maxE" = "cpE", "expR" = "cpR", "Cy0" = "Cy0", "CQ" = "cpCQ", "maxRatio" = "cpMR", stop())
      # tempRES <- tryCatch(efficiency(tempMOD, plot = FALSE, type = cp, ...), # ori
                          #error = function(e) NA) # ori
      tempRES <- tryCatch(efficiency(tempMOD, plot = FALSE, type = cp, min_reliable_cyc = min_reliable_cyc, ...), # xqrm
                          error = err_NA) # xqrm
      tempCT <- tryCatch(tempRES[[outNAME]],
                         #error = function(e) NA) # ori
                         error = err_NA) # xqrm
      RES[1, i] <- tempCT
      RES[2, i] <- switch(eff,
        "sigfit" =  if (!is.na(tempRES)) tempRES$eff else NA,
        "expfit" = tryCatch(expfit(tempMOD, plot = FALSE, ...)$eff,
          #error = function(e) NA), # ori
          error = err_NA), # xqrm
        "sliwin" = tryCatch(sliwin(tempMOD, plot = FALSE, ...)$eff,
          #error = function(e) NA)) # ori
          error = err_NA)) # xqrm
      # xqrm
      RES[3, i] <- tryCatch(tempRES[["D1max"]], error = err_NA)
      RES[4, i] <- tryCatch(tempRES[["D2max"]], error = err_NA)
      RES[5, i] <- tryCatch(tempRES[["cpD1"]], error = err_NA)
      RES[6, i] <- tryCatch(tempRES[["cpD2"]], error = err_NA)
   }
  }

  colnames(RES) <- NAMES
  rownames(RES) <- RN

  cat("\n")

  # xqrm: report time cost for this function
  end_time <- proc.time()[['elapsed']]
  message('`', func_name, '` took ', round(end_time - start_time, 2), ' seconds.')

  return(RES)
}


# 사전실험설계 분할표 만들기(교차분석)

#표를만들 때 위치 설정이 중요 왼쪽에 실험군과 대조군을 놓는다(행열지정과 관련된 논의)

pre <- read.csv("0302.pre.csv",
                header = TRUE,
                na.strings = ".")

# 범주를 지정해야 함

pre$treat <- factor(pre$treat,
                    levels = c(1,2),
                    labels = c("비타민","Palcebo"))
pre$cold <- factor(pre$cold,
                   levels = c(1,2),
                   labels = c("cold","nocold"))
str(pre)

# 잘 불러와서 쉽게 작업하려면 데이터 프레임을 attch()

attach(pre) # 그리고 나서 테이블을 만든다.

# pre.n <- xtabs(~treat+cold, data=pre)

pre.n <- table(treat, cold)

pre.n

pre.p <- prop.table(pre.n)

pre.p

pre.t <- cbind(pre.n, pre.p)

pre.t

pre.a <- addmargins(pre.t) # 기본 세팅은 행열합계 3(아래로 붙이는 것)

pre.a

detach(pre)

# 교차분석용 라이브러리 이용 (수업에서는 설명하지 않음)

# install.packages("gmodels")

library(gmodels)

pre <- CrossTable(pre$treat, pre$cold)

ch03 - 기초통계/사전설계분할표.r

ch03 - 기초통계/사전설계분할표.r

ch03 - 기초통계/사전설계분할표.r