# Author: Justin Abraham
# R Version: R-3.6.2
# RStudio Version: 1.2.5033

###############################
## Install required packages ##
###############################

set.seed(47269801)

if (!require("pacman")) {
    install.packages("pacman", repos='https://cloud.r-project.org/')
    library("pacman")
}

p_load("here", "tidyr", "dplyr", "lmtest", "multiwayvcov", "multcomp", "reshape2", "knitr", "flextable", "officer", "forestplot", "cowplot", "ggplot2", "matrixStats", "ggthemes", "ggsignif", "rstudioapi", "iptools")

source(here("r", "Funs.r"), echo = TRUE)

load(here("data", "USData.RData"))

attach(u1_df)

############################
## Initialize results doc ##
############################

appendix <- read_docx()

WriteHeading(appendix , "Data analysis for US donor experiment (study 3)")

########################
## Summary statistics ##
########################

SumTable <- SumStats(varlist = c("priordonor", "age", "gen.fem", "income", "hhsize", "edu.self.ba", "edu.par.ba", "race.minor", "religiosity", "is.chr", "is.dem"), labels = c("Prior donor", "Age", "Female", "Annual income (USD)", "HH size", "College educated", "Social class", "Racial minority", "Religiosity", "Christian", "Democrat"), data = u1_df)

## Print table to doc ##

LineBreak(appendix)
WriteTitle(appendix, "Summary of sample sociodemographic characteristics for study 3")

big_border <- fp_border(width = 2)
std_border <- fp_border(width = 1)

note <- "Note: \"Prior donor\" is an indicator variable for having made charitable contributions in the past. \"Age\" is the self-reported age of the respondent. \"Female\" is an indicator for identifying as a woman. \"Annual income (USD)\" is the self-reported annual income of the respondent. \"HH size\" is household size including the respondent. \"College educated\" is an indicator for having received a college education. \"Social class\" is an indicator for having at least one parent receive a college education. \"Racial minority\" is an indicator variable for identifying as Asian, Black, Hispanic, Native American, or Other. \"Religiosity\" measures strength of religious belief on a 5-point scale. \"Christian\" is an indicator for identifying as a Christian. \"Democrat\" is an indicator for affiliating with the Democratic Party."

flextable <- regulartable(as.data.frame(SumTable)) %>%
    align(align = "center") %>%
    align(j = 1, part = "body", align = "left") %>%
    border_remove() %>%
    hline_top(part = "all", border = big_border) %>%
    hline_top(part = "body", border = big_border) %>%
    hline_bottom(part = "body", border = big_border) %>%
    add_footer(Outcome = note) %>%
    merge_at(j = 1:7, part = "footer") %>%
    flextable::font(fontname = "Times New Roman", part = "all") %>%
    italic(part = "footer") %>%
    fontsize(size = 10, part = "all") %>%
    autofit()

appendix <- body_add_flextable(appendix, value = flextable)

##################################
## Randomization balance checks ##
##################################

hypotheses <- c("treatInd = 0", "treatCom = 0", "treatInd - treatCom = 0")
htitle <- c("Individual - Poverty", "Community - Poverty", "Individual - Community")
depvars <- c("priordonor", "age", "gen.fem", "income", "hhsize", "edu.self.ba", "edu.par.ba", "race.minor", "religiosity", "is.chr", "is.dem")
depvarnames <- c("Prior donor", "Age", "Female", "Annual income (USD)", "HH size", "College educated", "Social class", "Racial minority", "Religiosity", "Christian", "Democrat")

RES.print <- matrix(nrow = 1, ncol = 9)

for (i in 1:3) {

    RES.bal <- matrix(nrow = 1, ncol = 6)

    for (depvar in depvars) {

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

    }

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

    if (hypotheses[i] == "treatInd - treatCom = 0") {
        RES.bal <- cbind(RES.bal, colMeans(u1_df[which(u1_df$com == 1), depvars], na.rm = TRUE))
    } else RES.bal <- cbind(RES.bal, colMeans(u1_df[which(u1_df$pov == 1), depvars], na.rm = TRUE))

    RES.bal[, 5] <- round(RES.bal[, 5], 0)
    RES.bal[, -5] <- format(round(RES.bal[, -5], 3), nsmall = 3)

    RES.bal <- cbind(depvarnames, RES.bal)

    colnames(RES.bal)[1] <- "Outcome"
    colnames(RES.bal)[8] <- "Min. q-value"
    colnames(RES.bal)[9] <- "Reference mean"

    print("----------------------------------------------------------------", quote = FALSE)
    print(paste("H_0:", htitle[i]), quote = FALSE)
    print(RES.bal, quote = FALSE)

    RES.bal <- rbind(c(htitle[i], "", "", "", "", "", "", "", ""), RES.bal)
    RES.print <- rbind(RES.print, RES.bal)

}

RES.print[, c(1:9)] <- RES.print[, c(1, 2, 3, 4, 5, 7, 8, 9, 6)]
colnames(RES.print)[c(1:9)] <- colnames(RES.print)[c(1, 2, 3, 4, 5, 7, 8, 9, 6)]

## Print table to doc ##

LineBreak(appendix)
WriteTitle(appendix, "Balance checks on subject demographic characteristics for study 3")

appendix <- body_add_flextable(appendix, value = FTable(RES.print[2:nrow(RES.print), c(1:2,4:9)], note = "Note: Each panel corresponds to a single hypothesis for the group of outcome variables. The first column reports the mean difference between groups. The second column reports robust standard errors. The third column reports standard p-values. The fourth column reports exact p-values from randomization inference. The fifth column reports the minimum q-values. FDR correction is applied over all outcomes within a hypothesis. The reference mean column lists the mean of the poverty alleviation condition for the first two panels and the mean of the community empowerment condition for the third panel."))

####################################
## Plain OLS for primary outcomes ##
####################################

hypotheses <- c("treatInd = 0", "treatCom = 0", "treatInd - treatCom = 0")
htitle <- c("Individual - Poverty", "Community - Poverty", "Individual - Community")
depvars <- c("donation_org")
depvarnames <- c("Donation amount (USD)")

RES.print <- matrix(nrow = 1, ncol = 8)

for (i in 1:3) {

    RES.pri <- matrix(nrow = 1, ncol = 6)

    for (depvar in depvars) {

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

    }

    RES.pri <- RES.pri[2:nrow(RES.pri), 1:ncol(RES.pri)]
    dim(RES.pri) <- c(1, 6)

    if (hypotheses[i] == "treatInd - treatCom = 0") {
        RES.pri <- cbind(RES.pri, mean(u1_df[which(u1_df$com == 1), depvars]))
    } else RES.pri <- cbind(RES.pri, mean(u1_df[which(u1_df$pov == 1), depvars]))

    RES.pri[5] <- round(RES.pri[5], 0)
    RES.pri[-5] <- format(round(RES.pri[-5], 3), nsmall = 3)

    RES.pri <- cbind(depvarnames, RES.pri)
    colnames(RES.pri) <- c("Outcome", "Coefficient", "t-stat", "Std. error", "p-value", "Obs.", "Exact p-value", "Reference mean")

    print("----------------------------------------------------------------", quote = FALSE)
    print(paste("H_0:", htitle[i]), quote = FALSE)
    print(RES.pri, quote = FALSE)

    RES.pri <- rbind(c(htitle[i], "", "", "", "", "", "", ""), RES.pri)
    RES.print <- rbind(RES.print, RES.pri)

}

RES.print[, c(1:8)] <- RES.print[, c(1, 2, 3, 4, 5, 7, 8, 6)]
colnames(RES.print)[c(1:8)] <- colnames(RES.print)[c(1, 2, 3, 4, 5, 7, 8, 6)]

## Print table to doc ##

LineBreak(appendix)
WriteTitle(appendix, "Treatment effects on donation amount for study 3")

appendix <- body_add_flextable(appendix, value = FTable(RES.print[2:nrow(RES.print), c(1:2,4:8)], note = "Note: Each panel corresponds to a single hypothesis comparing the treatment conditions for the group of outcome variables. The first column reports the mean difference between groups. The second column reports robust standard errors. The third column reports standard p-values. The fourth column reports exact p-values from randomization inference. The reference mean column lists the mean of the poverty alleviation condition for the first two panels and the mean of the community empowerment condition for the third panel."))

######################################
## Plain OLS for secondary outcomes ##
######################################

hypotheses <- c("treatInd = 0", "treatCom = 0", "treatInd - treatCom = 0")
htitle <- c("Individual - Poverty", "Community - Poverty", "Individual - Community")
depvars <- c("donated", "encourage", "donor_status")
depvarnames <- c("Made donation", "Encourage donation", "Donor status (ladder)")

RES.print <- matrix(nrow = 1, ncol = 9)

for (i in 1:3) {

    RES.sec <- matrix(nrow = 1, ncol = 6)

    for (depvar in depvars) {

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

    }

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

    if (hypotheses[i] == "treatInd - treatCom = 0") {
        RES.sec <- cbind(RES.sec, colMeans(u1_df[which(u1_df$com == 1), depvars], na.rm = TRUE))
    } else RES.sec <- cbind(RES.sec, colMeans(u1_df[which(u1_df$pov == 1), depvars], na.rm = TRUE))

    RES.sec[, 5] <- round(RES.sec[, 5], 0)
    RES.sec[, -5] <- format(round(RES.sec[, -5], 3), nsmall = 3)

    RES.sec <- cbind(depvarnames, RES.sec)

    colnames(RES.sec)[1] <- "Outcome"
    colnames(RES.sec)[8] <- "Min. q-value"
    colnames(RES.sec)[9] <- "Reference mean"

    print("----------------------------------------------------------------", quote = FALSE)
    print(paste("H_0:", htitle[i]), quote = FALSE)
    print(RES.sec, quote = FALSE)

    RES.sec <- rbind(c(htitle[i], "", "", "", "", "", "", "", ""), RES.sec)
    RES.print <- rbind(RES.print, RES.sec)

}

RES.print[, c(1:9)] <- RES.print[, c(1, 2, 3, 4, 5, 7, 8, 9, 6)]
colnames(RES.print)[c(1:9)] <- colnames(RES.print)[c(1, 2, 3, 4, 5, 7, 8, 9, 6)]

## Print table to doc ##

LineBreak(appendix)
WriteTitle(appendix, "Treatment effects on secondary outcomes for study 3")

appendix <- body_add_flextable(appendix, value = FTable(RES.print[2:nrow(RES.print), c(1:2,4:9)], note = "Note: Each panel corresponds to a single hypothesis comparing the treatment conditions for the group of outcome variables. The first column reports the mean difference between groups. The second column reports robust standard errors. The third column reports standard p-values. The fourth column reports exact p-values from randomization inference. The fifth column reports the minimum q-values. FDR correction is applied over all outcomes within a hypothesis. The reference mean column lists the mean of the poverty alleviation condition for the first two panels and the mean of the community empowerment condition for the third panel."))

###############################################
## Covariate adjustment for primary outcomes ##
###############################################

hypotheses <- c("treatInd = 0", "treatCom = 0", "treatInd - treatCom = 0")
htitle <- c("Individual - Poverty", "Community - Poverty", "Individual - Community")
depvars <- c("donation_org")
depvarnames <- c("Donation amount (USD)")
covariates <- c("priordonor.c", "gen.fem.c", "hi.income.hh.c", "edu.self.ba.c", "race.minor.c", "is.chr.c", "is.religi.c", "is.dem.c")

RES.print <- matrix(nrow = 1, ncol = 8)

for (i in 1:3) {

    RES.pri.cov <- matrix(nrow = 1, ncol = 6)

    for (depvar in depvars) {

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

    }

    RES.pri.cov <- RES.pri.cov[2:nrow(RES.pri.cov), 1:ncol(RES.pri.cov)]
    dim(RES.pri.cov) <- c(1, 6)

    if (hypotheses[i] == "treatInd - treatCom = 0") {
        RES.pri.cov <- cbind(RES.pri.cov, mean(u1_df[which(u1_df$com == 1), depvars]))
    } else RES.pri.cov <- cbind(RES.pri.cov, mean(u1_df[which(u1_df$pov == 1), depvars]))

    RES.pri.cov[5] <- round(RES.pri.cov[5], 0)
    RES.pri.cov[-5] <- format(round(RES.pri.cov[-5], 3), nsmall = 3)

    RES.pri.cov <- cbind(depvarnames, RES.pri.cov)
    colnames(RES.pri.cov) <- c("Outcome", "Coefficient", "t-stat", "Std. error", "p-value", "Obs.", "Exact p-value", "Reference mean")

    print("----------------------------------------------------------------", quote = FALSE)
    print(paste("H_0:", htitle[i]), quote = FALSE)
    print(RES.pri.cov, quote = FALSE)

    RES.pri.cov <- rbind(c(htitle[i], "", "", "", "", "", "", ""), RES.pri.cov)
    RES.print <- rbind(RES.print, RES.pri.cov)

}

RES.print[, c(1:8)] <- RES.print[, c(1, 2, 3, 4, 5, 7, 8, 6)]
colnames(RES.print)[c(1:8)] <- colnames(RES.print)[c(1, 2, 3, 4, 5, 7, 8, 6)]

## Print table to doc ##

LineBreak(appendix)
WriteTitle(appendix, "Treatment effects on donation amount with covariate adjustment for study 3")

appendix <- body_add_flextable(appendix, value = FTable(RES.print[2:nrow(RES.print), c(1:2,4:8)], note = "Note: We include as control variables indicators for being a prior donor, being female, high income, education level, being a racial minority, religious affiliation, religiosity, and political affiliation. Each panel corresponds to a single hypothesis comparing the treatment conditions for the group of outcome variables. The first column reports the mean difference between groups. The second column reports robust standard errors. The third column reports standard p-values. The fourth column reports exact p-values from randomization inference. The reference mean column lists the mean of the poverty alleviation condition for the first two panels and the mean of the community empowerment condition for the third panel."))

#################################################
## Covariate adjustment for secondary outcomes ##
#################################################

hypotheses <- c("treatInd = 0", "treatCom = 0", "treatInd - treatCom = 0")
htitle <- c("Individual - Poverty", "Community - Poverty", "Individual - Community")
depvars <- c("donated", "encourage", "donor_status")
depvarnames <- c("Made donation", "Encourage donation", "Donor status (ladder)")
covariates <- c("priordonor.c", "gen.fem.c", "hi.income.hh.c", "edu.self.ba.c", "race.minor.c", "is.chr.c", "is.religi.c", "is.dem.c")

RES.print <- matrix(nrow = 1, ncol = 9)

for (i in 1:3) {

    RES.sec.cov <- matrix(nrow = 1, ncol = 6)

    for (depvar in depvars) {

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

    }

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

    if (hypotheses[i] == "treatInd - treatCom = 0") {
        RES.sec.cov <- cbind(RES.sec.cov, colMeans(u1_df[which(u1_df$com == 1), depvars], na.rm = TRUE))
    } else RES.sec.cov <- cbind(RES.sec.cov, colMeans(u1_df[which(u1_df$pov == 1), depvars], na.rm = TRUE))

    RES.sec.cov[, 5] <- round(RES.sec.cov[, 5], 0)
    RES.sec.cov[, -5] <- format(round(RES.sec.cov[, -5], 3), nsmall = 3)

    RES.sec.cov <- cbind(depvarnames, RES.sec.cov)

    colnames(RES.sec.cov)[1] <- "Outcome"
    colnames(RES.sec.cov)[8] <- "Min. q-value"
    colnames(RES.sec.cov)[9] <- "Reference mean"

    print("----------------------------------------------------------------", quote = FALSE)
    print(paste("H_0:", htitle[i]), quote = FALSE)
    print(RES.sec.cov, quote = FALSE)

    RES.sec.cov <- rbind(c(htitle[i], "", "", "", "", "", "", "", ""), RES.sec.cov)
    RES.print <- rbind(RES.print, RES.sec.cov)

}

RES.print[, c(1:9)] <- RES.print[, c(1, 2, 3, 4, 5, 7, 8, 9, 6)]
colnames(RES.print)[c(1:9)] <- colnames(RES.print)[c(1, 2, 3, 4, 5, 7, 8, 9, 6)]

## Print table to doc ##

LineBreak(appendix)
WriteTitle(appendix, "Treatment effects on secondary outcomes with covariate adjustment for study 3")

appendix <- body_add_flextable(appendix, value = FTable(RES.print[2:nrow(RES.print), c(1:2,4:9)], note = "Note: We include as control variables indicators for being a prior donor, being female, high income, education level, being a racial minority, religious affiliation, religiosity, and political affiliation. Each panel corresponds to a single hypothesis comparing the treatment conditions for the group of outcome variables. The first column reports the mean difference between groups. The second column reports robust standard errors. The third column reports standard p-values. The fourth column reports exact p-values from randomization inference. The fifth column reports the minimum q-values. FDR correction is applied over all outcomes within a hypothesis. The reference mean column lists the mean of the poverty alleviation condition for the first two panels and the mean of the community empowerment condition for the third panel."))

################################################
## Heterogeneous effects for primary outcomes ##
################################################

depvars <- c("donation_org")
depvarnames <- c("Donation amount (USD)")
hetvars <- c("priordonor", "gen.fem", "hi.income.hh", "edu.par.ba", "is.religi", "is.dem")
hetvarnames <- c("prior donor status (have made a prior donation)", "gender (female)", "income (above $31,305)", "social class (parents are college-educated)", "religiosity (some religiosity or greater)", "political affiliation (Democrat)")

for (i in 1:6) {

    hypotheses <- c(paste("treatInd:", hetvars[i], " = 0", sep = ""), paste("treatCom:", hetvars[i], " = 0", sep = ""), paste("treatInd:", hetvars[i], " - ", "treatCom:", hetvars[i], " = 0", sep = ""))
    htitle <- c("Individual - Poverty", "Community - Poverty", "Individual - Community")

    appendix <- body_add_par(appendix , " ", style = "Normal")

    RES.print <- matrix(nrow = 1, ncol = 7)

    for (j in 1:3) {

        RES.pri.het <- matrix(nrow = 1, ncol = 6)

        for (depvar in depvars) {

            eqn <- paste(depvar, " ~ treat*", hetvars[i], sep = "")
            RES.pri.het <- rbind(RES.pri.het, PermTest(eqn, treatvars = c("treat", "pov", "ind", "com"), clustvars = u1_df$survey.id, hypotheses = hypotheses[j], iterations = 10000, data = u1_df))

        }

        RES.pri.het <- RES.pri.het[2:nrow(RES.pri.het), 1:ncol(RES.pri.het)]

        RES.pri.het[5] <- round(RES.pri.het[5], 0)
        RES.pri.het[-5] <- format(round(RES.pri.het[-5], 3), nsmall = 3)

        dim(RES.pri.het) <- c(1, 6)
        RES.pri.het <- cbind(depvarnames, RES.pri.het)
        colnames(RES.pri.het) <- c("Outcome", "Coefficient", "t-stat", "Std. error", "p-value", "Obs.", "Exact p-value")

        print("----------------------------------------------------------------", quote = FALSE)
        print(paste("H_0:", htitle[j]), quote = FALSE)
        print(RES.pri.het, quote = FALSE)

        RES.pri.het <- rbind(c(htitle[j], "", "", "", "", "", ""), RES.pri.het)
        RES.print <- rbind(RES.print, RES.pri.het)

    }

    RES.print[, c(1:7)] <- RES.print[, c(1, 2, 3, 4, 5, 7, 6)]
    colnames(RES.print)[c(1:7)] <- colnames(RES.print)[c(1, 2, 3, 4, 5, 7, 6)]

    ## Print table to doc ##

    LineBreak(appendix)
    WriteTitle(appendix, paste("Heterogeneous treatment effects on donation amount by", hetvarnames[i], "for study 3"))

    appendix <- body_add_flextable(appendix, value = FTable(RES.print[2:nrow(RES.print), c(1:2,4:7)], note = "Note: This table reports coefficient estimates on each experimental comparison interacted with a baseline variable. Each panel corresponds to a single hypothesis comparing the treatment conditions for the group of outcome variables. The first column reports the mean difference between groups. The second column reports robust standard errors. The third column reports standard p-values. The fourth column reports exact p-values from randomization inference."))

}

##################################################
## Heterogeneous effects for secondary outcomes ##
##################################################

depvars <- c("donated", "encourage", "donor_status")
depvarnames <- c("Made donation", "Encourage donation", "Donor status (ladder)")
hetvars <- c("priordonor", "gen.fem", "hi.income.hh", "edu.par.ba", "is.religi", "is.dem")
hetvarnames <- c("prior donor status (have made a prior donation)", "gender (female)", "income (above $31,305)", "social class (parents are college-educated)", "religiosity (some religiosity or greater)", "political affiliation (Democrat)")

for (i in 1:6) {

    hypotheses <- c(paste("treatInd:", hetvars[i], " = 0", sep = ""), paste("treatCom:", hetvars[i], " = 0", sep = ""), paste("treatInd:", hetvars[i], " - ", "treatCom:", hetvars[i], " = 0", sep = ""))
    htitle <- c("Individual - Poverty", "Community - Poverty", "Individual - Community")

    appendix <- body_add_par(appendix , " ", style = "Normal")

    RES.print <- matrix(nrow = 1, ncol = 8)

    for (j in 1:3) {

        RES.sec.het <- matrix(nrow = 1, ncol = 6)

        for (depvar in depvars) {

            eqn <- paste(depvar, " ~ treat*", hetvars[i], sep = "")
            RES.sec.het <- rbind(RES.sec.het, PermTest(eqn, treatvars = c("treat", "pov", "ind", "com"), clustvars = u1_df$survey.id, hypotheses = hypotheses[j], iterations = 10000, data = u1_df))

        }

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

        RES.sec.het[, 5] <- round(RES.sec.het[, 5], 0)
        RES.sec.het[, -5] <- format(round(RES.sec.het[, -5], 3), nsmall = 3)

        RES.sec.het <- cbind(depvarnames, RES.sec.het)

        colnames(RES.sec.het)[1] <- "Outcome"
        colnames(RES.sec.het)[8] <- "Min. q-value"

        print("----------------------------------------------------------------", quote = FALSE)
        print(paste("H_0:", htitle[j]), quote = FALSE)
        print(RES.sec.het, quote = FALSE)

        RES.sec.het <- rbind(c(htitle[j], "", "", "", "", "", "", ""), RES.sec.het)
        RES.print <- rbind(RES.print, RES.sec.het)

    }

    RES.print[, c(1:8)] <- RES.print[, c(1, 2, 3, 4, 5, 7, 8, 6)]
    colnames(RES.print)[c(1:8)] <- colnames(RES.print)[c(1, 2, 3, 4, 5, 7, 8, 6)]

    ## Print table to doc ##

    LineBreak(appendix)
    WriteTitle(appendix, paste("Heterogeneous treatment effects on secondary outcomes by", hetvarnames[i], "for study 3"))

    appendix <- body_add_flextable(appendix, value = FTable(RES.print[2:nrow(RES.print), c(1:2,4:8)], note = "Note: This table reports coefficient estimates on each experimental comparison interacted with a baseline variable. Each panel corresponds to a single hypothesis comparing the treatment conditions for the group of outcome variables. The first column reports the mean difference between groups. The second column reports robust standard errors. The third column reports standard p-values. The fourth column reports exact p-values from randomization inference. The fifth column reports the minimum q-values. FDR correction is applied over all outcomes within a hypothesis."))

}

# Print results appendix #

print(appendix, target = here("doc", "S3_appendix.docx"))

##################################
## Bar graphs for main findings ##
##################################

treat <- factor(u1_df$treat, labels = c("Poverty\nAlleviation", "Individual\nEmpowerment", "Community\nEmpowerment"))

amount.graph <- BarChart(depvar = u1_df$donation_org, groupvar = treat, ytitle = "Dollars donated (USD)", title = "A", xtitle = "", fillcolor = c('#c6c6c7', '#7ca6c0', '#c05746'), bounds = c(0, 100), tick = 20)

donate.graph <- BarChart(depvar = u1_df$donated, groupvar = treat, ytitle = "Proportion who donated any amount", title = "B", xtitle = "", fillcolor = c('#c6c6c7', '#7ca6c0', '#c05746'), bounds = c(0, 1), tick = 0.2)

encourage.graph <- BarChart(depvar = u1_df$encourage, groupvar = treat, ytitle = "Level (1-5)", title = "C) Encourage others to donate", xtitle = "", fillcolor = c('#c6c6c7', '#7ca6c0', '#c05746'), bounds = c(0, 5), tick = 1)

status.graph <- BarChart(depvar = u1_df$donor_status, groupvar = treat, ytitle = "Ladder score (1-10)", title = "D) Donor status", xtitle = "", fillcolor = c('#c6c6c7', '#7ca6c0', '#c05746'), bounds = c(0, 10), tick = 2)

# Annotate with significance levels #

amount.graph <- amount.graph +
    geom_signif(comparisons=list(c("Individual\nEmpowerment", "Community\nEmpowerment")), annotations= "†", textsize = 3, y_position = 50, vjust = -0.2, tip_length = 0.1)

donate.graph <- donate.graph +
    geom_signif(comparisons=list(c("Individual\nEmpowerment", "Community\nEmpowerment")), annotations = "*", textsize = 5, y_position = 0.925, vjust = 0.3, tip_length = 0.1)

# Arrange figures in grid #

pdf(here("graphics", "FigureS3.pdf"), width = 7, height = 4, encoding = "MacRoman")
plot_grid(amount.graph, donate.graph, nrow = 1, ncol = 2, labels = c("", ""), hjust = 0.5, label_size = 12, scale = 0.85)
dev.off()


# 3. faza: Vizualizacija podatkov

require(ggplot2)
require(dplyr)
library(stringr)
library(tmap)

#PLAČA GLEDE NA REGIJO IN SPOL
visina.place <- povp_starost %>% filter(leto=="2018") %>% select(-leto)
visina.place$regija[visina.place$regija == "Posavska"] <- "Spodnjeposavska"
visina.place$regija[visina.place$regija == "Primorsko-notranjska"] <- "Notranjsko-kraska"

zemljevid.place <- zemljevid_slovenije %>% left_join(visina.place, by=c("NAME_1"="regija"))

map <- ggplot(zemljevid.place, aes(x=long, y=lat, fill=placa, label=paste0(NAME_1, "\n", placa))) +
  geom_polygon(aes(group=group)) +
  geom_text(data=zemljevid.place %>% group_by(NAME_1, placa)  %>%
              summarise(long=mean(long), lat=mean(lat)), size=3, colour="black") +
  theme(axis.line=element_blank(),
        axis.text.x=element_blank(),
        axis.text.y=element_blank(),
        axis.ticks=element_blank(),
        axis.title.x=element_blank(),
        axis.title.y=element_blank(),
        panel.background=element_blank(),
        panel.border=element_blank(),
        panel.grid.major=element_blank(),
        panel.grid.minor=element_blank(),
        plot.background=element_blank()) +
  labs(fill="Plača(€)", title ="Višina povp. bruto plače po regijah Slovenije")

#ANALIZA PLAČE GLEDE NA JAVNI IN ZASEBNI SEKTOR
javnisektor_osmanj_moski <- javnisektor %>%
  filter(izobrazba == "Osnovnošolska ali manj", spol== "Moški",
         sektor== "11 Javni sektor - SKUPAJ")
javnisektor_osmanj_zenske <- javnisektor %>%
  filter(izobrazba == "Osnovnošolska ali manj", spol== "Ženske",
         sektor== "11 Javni sektor - SKUPAJ")
javnisektor_sr_moski <- javnisektor %>%
  filter(izobrazba == "Srednješolska", spol== "Moški",
         sektor== "11 Javni sektor - SKUPAJ")
javnisektor_sr_zenske <- javnisektor %>%
  filter(izobrazba == "Srednješolska", spol== "Ženske",
         sektor== "11 Javni sektor - SKUPAJ")
javnisektor_vs_moski <- javnisektor %>%
  filter(izobrazba == "Višješolska, visokošolska", spol== "Moški",
         sektor== "11 Javni sektor - SKUPAJ")
javnisektor_vs_zenske <- javnisektor %>%
  filter(izobrazba == "Višješolska, visokošolska", spol== "Ženske",
         sektor== "11 Javni sektor - SKUPAJ")
zasebnisektor_osmanj_moski <- javnisektor %>%
  filter(izobrazba == "Osnovnošolska ali manj", spol=="Moški",
         sektor== "12 Zasebni sektor - SKUPAJ")
zasebnisektor_osmanj_zenske <- javnisektor %>%
  filter(izobrazba == "Osnovnošolska ali manj", spol=="Ženske",
         sektor== "12 Zasebni sektor - SKUPAJ")
zasebnisektor_sr_moski <- javnisektor %>%
  filter(izobrazba == "Srednješolska", spol=="Moški",
         sektor== "12 Zasebni sektor - SKUPAJ")
zasebnisektor_sr_zenske <- javnisektor %>%
  filter(izobrazba == "Srednješolska", spol=="Ženske",
         sektor== "12 Zasebni sektor - SKUPAJ")
zasebnisektor_vs_moski <- javnisektor %>%
  filter(izobrazba == "Višješolska, visokošolska", spol=="Moški",
         sektor== "12 Zasebni sektor - SKUPAJ")
zasebnisektor_vs_zenske <-  javnisektor %>%
  filter(izobrazba == "Višješolska, visokošolska", spol=="Ženske",
         sektor== "12 Zasebni sektor - SKUPAJ")

#Graf-javni sektor
ggplot(javnisektor_osmanj_moski, aes(x=leto, y=placa)) +
  geom_point(color="blue", size=2) +
  geom_point(data=javnisektor_osmanj_zenske, aes(x=leto, y=placa),color="light blue", size=2) +
  geom_point(data=javnisektor_sr_moski, aes(x=leto, y=placa),color="red", size=2) +
  geom_point(data=javnisektor_sr_zenske, aes(x=leto, y=placa),color="pink", size=2) +
  geom_point(data=javnisektor_vs_moski, aes(x=leto, y=placa),color="green", size=2) +
  geom_point(data=javnisektor_vs_zenske, aes(x=leto, y=placa),color="dark green", size=2) +
  labs(title="Primerjava plače v javnem sektorju glede na izobrazbo in spol") +
  ylab("Višina plače(€)") +
  xlab("Leto")

#Graf-zasebni sektor
ggplot(zasebnisektor_osmanj_moski, aes(x=leto, y=placa)) +
  geom_point(color="blue", size=2) +
  geom_point(data=zasebnisektor_osmanj_zenske, aes(x=leto, y=placa),color="light blue", size=2) +
  geom_point(data=zasebnisektor_sr_moski, aes(x=leto, y=placa),color="red", size=2) +
  geom_point(data=zasebnisektor_sr_zenske, aes(x=leto, y=placa),color="pink", size=2) +
  geom_point(data=zasebnisektor_vs_moski, aes(x=leto, y=placa),color="green", size=2) +
  geom_point(data=zasebnisektor_vs_zenske, aes(x=leto, y=placa),color="dark green", size=2) +
  labs(title="Primerjava plače v zasebnem sektorju glede na izobrazbo in spol") +
  ylab("Višina plače(€)") +
  xlab("Leto")

#Graf-analiza povprečne plače po letih v javnem in zasebnem sektorju
graf2 <- ggplot(javnisektor ,aes(x=leto, y=placa, fill=factor(sektor))) +
  geom_col(position="dodge")  +
  coord_flip() +
  guides(fill=guide_legend("Sektor")) +
  xlab("Leto") +
  ylab("Višina plače(€)")+
  ggtitle("Primerjava plače v javnem in zasebnem sektorju")

javnisektor_izobrazba <- javnisektor %>%
  filter(sektor=="11 Javni sektor - SKUPAJ")
zasebnisektor_izobrazba <- javnisektor %>%
  filter(sektor=="12 Zasebni sektor - SKUPAJ")

graf3 <- ggplot(javnisektor_izobrazba ,aes(x=leto, y=placa, fill=factor(izobrazba))) +
  geom_col(position="dodge")  +
  coord_flip() +
  guides(fill=guide_legend("Izobrazba")) +
  xlab("Leto") +
  ylab("Višina plače(€)")+
  ggtitle("Primerjava plače v zasebnem sektorju glede na izobrazbo")

graf4 <- ggplot(zasebnisektor_izobrazba ,aes(x=leto, y=placa, fill=factor(izobrazba))) +
  geom_col(position="dodge")  +
  coord_flip() +
  guides(fill=guide_legend("Izobrazba")) +
  xlab("Leto") +
  ylab("Višina plače(€)")+
  ggtitle("Primerjava plače v javnem sektorju glede na izobrazbo")

#Minimalna in maksimalna placa glede na izobrazbo
maksimum <- data.frame(javnisektor %>%
                       group_by(sektor, izobrazba, spol) %>%
                       summarise(maksimum = max(placa)))
minimum <- data.frame(javnisektor %>%
                      group_by(sektor, izobrazba, spol) %>%
                      summarise(minimum = min(placa)))
max_min <- merge(maksimum,minimum,by=c("spol", "izobrazba", "sektor"))

placa_javnisektor_moski <- max_min %>%
  filter(sektor=="11 Javni sektor - SKUPAJ", spol== "Moški")
placa_zasebnisektor_moski <- max_min %>%
  filter(sektor=="12 Zasebni sektor - SKUPAJ", spol== "Moški")
placa_javnisektor_zenske <- max_min %>%
  filter(sektor=="11 Javni sektor - SKUPAJ", spol== "Ženske")
placa_zasebnisektor_zenske <- max_min %>%
  filter(sektor=="12 Zasebni sektor - SKUPAJ", spol== "Ženske")

#ANALIZA PLAČE GLEDE NA GOSPODARSKO DEJAVNOST
#Sprememba plače od leta 2010 do 2018
#sprememba place v % = ((placa 2018 - placa 2010)/ placa 2010) * 100
gd_2010_m <- gospodarskadejavnost2 %>%
  filter(leto == "2010", spol == "Moški")
gd_2018_m <- gospodarskadejavnost2 %>%
  filter(leto == "2018", spol == "Moški")
gd_moski <- merge(gd_2010_m, gd_2018_m, by=c("gospodarska.dejavnost","izobrazba", "spol"))
sprememba <- round(((gd_moski$placa.y - gd_moski$placa.x)/gd_moski$placa.x) * 100, digits=2)
gd_moski$sprememba <- sprememba

gd_2010_z <- gospodarskadejavnost2 %>%
  filter(leto == "2010", spol == "Ženske")
gd_2018_z <- gospodarskadejavnost2 %>%
  filter(leto == "2018", spol == "Ženske")
gd_zenske <- merge(gd_2010_z, gd_2018_z, by=c("gospodarska.dejavnost","izobrazba", "spol"))
sprememba <- round(((gd_zenske$placa.y - gd_zenske$placa.x)/gd_zenske$placa.x) * 100, digits=2)
gd_zenske$sprememba <- sprememba

gd_sprememba <- rbind(gd_moski, gd_zenske)

graf1 <- ggplot(gd_sprememba ,aes(x=str_wrap(gospodarska.dejavnost,45), y=sprememba, fill=factor(spol))) +
  geom_col(position="dodge")  +
  coord_flip() +
  guides(fill=guide_legend("Spol")) +
  xlab("Gospodarska dejavnost") +
  ylab("Sprememba(%)")+
  ggtitle("Sprememba plače(gospodarska dejavnost)")

#Najvišja in najnižja plača v vsaki panogi glede na izobrazbo in spol
maksimum <- data.frame(gospodarskadejavnost %>%
                         group_by(dejavnost, izobrazba, spol) %>%
                         summarise(maksimum = max(placa)))
minimum <- data.frame(gospodarskadejavnost %>%
                        group_by(dejavnost, izobrazba, spol) %>%
                        summarise(minimum = min(placa)))
max_min <- merge(maksimum,minimum,by=c("spol", "izobrazba", "dejavnost"))

#ANALIZA PLAČE LETA 2008 IN LETA 2020, TER PRIMERJAVA OBEH LET
kriza_2008 <- kriza %>%
  filter(leto=="2008")
kriza_2020 <- kriza %>%
  filter(leto=="2020")
kriza_08_20 <- rbind(kriza_2008, kriza_2020)

graf5 <- ggplot(kriza_08_20 ,aes(x=placa, y=mesec, fill=factor(leto))) +
  geom_col(position="dodge")  +
  coord_flip() +
  guides(fill=guide_legend("Leto")) +
  xlab("Višina plače(€)") +
  ylab("Mesec")+
  ggtitle("Primerjava plače v letu 2008 z letom 2020")

#Sprememba plače iz leta 2008 do leta 2020: 33,3%
#Sprememba plače v letu 2008: 9,9%
#Sprememba plače v letu 2020: 0,8%
#Sprememba plače v letu 2007: 7,4%


#  James Rekow

source("universality_functions.r")

DOCProcedure = function(abdList, intIx = NULL){

  #  ARGS:  abdList - list of integrated abundances from a cohort
  #
  #  RETURNS:  doc - a list of the form list(overlap, dissimilarity) containing
  #            two numerical vectors

  M = length(abdList)

  #  if abdList is empty, return NULL
  if(M == 0){
    return(NULL)
  } #  end if

  #  list the indices of all pairs of samples and count the number of such pairs
  pairs = combn(1:M, 2)
  numPairs = choose(M, 2)

  #  preallocate list
  doc = list(x = numeric(numPairs), y = numeric(numPairs))

  #compute the overlap and dissimilarity of the samples in the cohort
  for(i in 1:numPairs){

    x = abdList[[pairs[, i][1]]]
    y = abdList[[pairs[, i][2]]]

    doc[[1]][i] = overlap(x, y)
    doc[[2]][i] = DrJSD(x, y)

  } #  end for

  if(!is.null(intIx)){

    #  stores the numerical truth value corresponding to whether or not a sample is interacting
    isIntSmpl = numeric(M)
    isIntSmpl[intIx] = 1

    intSmpls = apply(pairs, 2, function(x) sum(isIntSmpl[x]))

    doc = c(list(intSmpls = intSmpls), doc)

  } #  end if

  return(doc)

} #  end DOCProcedure function


# This code assumes you've downloaded and unzipped the file
#   exdata-data-NEI_data.zip in your working directory.  If you haven't it's
#   easy enough to write the code to check using file.exists etc

## This first line will likely take a few seconds. Be patient!
NEI <- readRDS("summarySCC_PM25.rds")
SCC <- readRDS("Source_Classification_Code.rds")

# Plot 2
Balt <- NEI[NEI$fips == "24510",]
BaltTotal <- aggregate(formula = Emissions ~ year,
                       data = Balt,
                       FUN = sum)

png(filename = "plot2.png",
    width = 480,
    height = 480)

barplot(height = BaltTotal$Emissions/10^3,
        names.arg=BaltTotal$year,
        col = "lightblue",
        xlab = "Year",
        ylab = "Emissions (thousand tons)",
        main = "Plot 2: Total PM2.5 Emissions From Baltimore",
        ylim = c(0,4))

dev.off()


### Read in nexus formatted output from splitstree.
read_splitstree_nexus = function(fname) {
    section = 'none'
    subsection = 'none'
    nexus_file_string = scan(fname, 'rb', sep='\n', what='character')
    i = 0
    line = ''
    while(i < length(nexus_file_string)) {
        i = i + 1
        line = trimws(nexus_file_string[i], 'both')
        if(length(line) == 0) {
            next
        } else if(grepl('^END;', line)) {
            section = 'none'
            next
        } else if(grepl('^BEGIN', line)) {
            section = gsub('BEGIN (.+);$', '\\1', line)
            next
        }
        if(section == 'Taxa') {
            if(grepl('^DIMENSIONS', line)) {
                taxa = character(as.numeric(gsub('.+ntax=(.+);', '\\1', line)))
            } else if(grepl('^TAXLABELS|;$', line)) {
                next
            } else {
                t_number = as.numeric(gsub('\\[([0-9]+)\\].+', '\\1', line))
                t_name = gsub("^'|'$", '', gsub('\\[[0-9]+\\] ', '', line))
                taxa[t_number] = t_name
            }
        } else if(section == 'Distances') {
            ## Don't do anything with this for now
            next
        } else if(section == 'Splits') {
            ## Don't do anything with this for now
            next
        } else if(section == 'Network') {
            if(grepl('^DIMENSIONS', line)) {
                n_taxa_plot = as.numeric(gsub('.+ntax=([0-9]+).+', '\\1', line))
                n_vertex = as.numeric(gsub('.+nvertices=([0-9]+).+', '\\1', line))
                n_edge = as.numeric(gsub('.+nedges=([0-9]+).+', '\\1', line))
                edges = data.frame('number'=numeric(n_edge),
                    'v1'=numeric(n_edge),
                    'v2'=numeric(n_edge),
                    'w'=numeric(n_edge),
                    stringsAsFactors=FALSE)
                vertices = data.frame(label=character(n_vertex),
                    number=numeric(n_vertex),
                    leaf=logical(n_vertex),
                    stringsAsFactors=FALSE)
                vertex_data = data.frame(number=numeric(n_vertex),
                    x=numeric(n_vertex),
                    y=numeric(n_vertex))
                subsection = 'none'
            } else if(line == ';') {
                subsection = 'none'
                next
            } else {
                if(line == 'TRANSLATE') {
                    subsection = 'translate'
                    next
                } else if(line == 'EDGES') {
                    subsection = 'edges'
                    next
                } else if(line == 'VERTICES') {
                    subsection = 'vertices'
                    next
                }
                if(subsection == 'translate') {
                    v_number = as.numeric(unlist(strsplit(line, ' '))[1])
                    vertices[v_number, 'label'] = gsub("',$", '', gsub("[0-9]+ '", '', line))
                } else if(subsection == 'edges') {
                    edge_data = unlist(strsplit(line, ' '))
                    e_number = as.numeric(edge_data[1])
                    v1 = as.numeric(edge_data[2])
                    v2 = as.numeric(edge_data[3])
                    w = as.numeric(gsub('w=', '',
                        edge_data[grepl('^w=', edge_data)]))
                    edges[e_number, ] = c(e_number, v1, v2, w)
                } else if(subsection == 'vertices') {
                    v_data = unlist(strsplit(line, ' '))
                    v_number = as.numeric(v_data[1])
                    vertex_data[v_number, 'x'] = as.numeric(v_data[2])
                    vertex_data[v_number, 'y'] = as.numeric(v_data[3])
                    vertices[v_number, 'number'] = v_number
                    vertex_data[v_number, 'number'] = v_number
                }
            }
        }
    }

    #parents = unique(edges[, 1])
    #children = unique(edges[, 2])
    #leaves = children[!children %in% parents]
    tab = table(c(edges$v1, edges$v2))
    leaves = names(tab[tab == 1])
    vertices$leaf[vertices$number %in% leaves] = TRUE
    list('vertices'=vertices, 'edges'=edges, 'vertex_data'=vertex_data)
}

add_vertex_data = function(net_obj, dat, match_label=FALSE) {
    numbers = net_obj[['vertices']][, 'number']
    labels = net_obj[['vertices']][, 'label']
    if(!match_label) {
        stopifnot('number' %in% names(dat))
        mcol = 'number'
        m = numbers
    } else {
        stopifnot('label' %in% names(dat))
        mcol = 'label'
        m = labels
    }

    old_data = net_obj[['vertex_data']]
    old_data = old_data[match(numbers, old_data[, 'number']), ]
    old_names = names(old_data)
    old_names = old_names[old_names != 'number']
    new_names = names(dat)
    new_names = new_names[!(new_names %in% c('number', 'label'))]
    all_names = unique(c(old_names, new_names))
    new_data = structure(vector('list', length=length(all_names)+1),
                         names=c('number', all_names))

    new_data[['number']] = numbers
    for(nm in old_names) {
        new_data[[nm]] = old_data[[nm]]
    }
    for(nm in new_names) {
        new_data[[nm]] = dat[match(m, dat[, mcol]), nm]
    }

    net_obj[['vertex_data']] = do.call(data.frame,
                                       c(new_data,
                                         stringsAsFactors=FALSE,
                                         check.names=FALSE))
    net_obj
}

## Works!
plot_network = function(net_obj,
    label=NULL,
    pts=NULL,
    pts_lvs_only=TRUE,
    symbol=NULL,
    symbol_lvs_only=TRUE,
    col.lab='black',
    cex.lab=0.3,
    font.lab=1,
    adj.lab=NULL,
    pos.lab=NULL,
    offset.lab=0.5,
    vfont.lab=NULL,
    col.edge=par('fg'),
    lwd.edge=1,
    lty.edge=1,
    ...) {

    vertices = net_obj$vertices
    vdata = net_obj$vertex_data
    stopifnot(all(vdata$number == vertices$number))
    edges = net_obj$edges
    x = vdata$x
    y = vdata$y

    plot(0, 0, xlim=c(min(x), max(x)),
         ylim=c(min(y), max(y)),
         type='n', bty='n', xaxt='n', yaxt='n', mar=c(0, 0, 0, 0),
         xlab='', ylab='', ...)

    for(i in 1:nrow(edges)) {
        v1 = edges[i, 'v1']
        v2 = edges[i, 'v2']
        x1 = x[vertices$number == v1]
        y1 = y[vertices$number == v1]
        x2 = x[vertices$number == v2]
        y2 = y[vertices$number == v2]
        segments(x1, y1, x2, y2,
                 lwd=lwd.edge, lty=lty.edge, col=col.edge)
    }

    if(!is.null(label)) {
        if(is.character(label)) {
            labs = label
        } else {
            labs = vertices[, 'label']
        }
        text(vdata[, 'x'], vdata[, 'y'],
             labs, cex=cex.lab, col=col.lab,
             font=font.lab, adj=adj.lab, pos=pos.lab,
             offset=offset.lab, vfont=vfont.lab)
    }

    if(!is.null(pts)) {
        xx = x
        yy = y
        if(pts_lvs_only) {
            xx = x[vertices[, 'leaf']]
            yy = y[vertices[, 'leaf']]
        }
        do.call(points, c(list('x'=xx, 'y'=yy), pts))
    }

    if(!is.null(symbol)) {
        xx = x
        yy = y
        if(symbol_lvs_only) {
            xx = x[vertices[, 'leaf']]
            yy = y[vertices[, 'leaf']]
        }
        do.call(symbols, c(list('x'=xx, 'y'=yy, add=TRUE), symbol))
    }

}


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

PruneFeatures <- function(dataset) {
	# Prunes features that have less than 918/2 nonzeros or non NAs
	#
	# Args:
	#	dataset: dataset to be pruned
	#
	# Returns:
	#	dataset with features that have at least 918/2 nonzeros or non NAs
	#
	# Example usage:
	# 	train.data<-PruneFeatures(train.data)

	dataset<-dataset[,colSums(is.na(dataset)|dataset==0)<=nrow(dataset)/2]

	# # drop.features<-c("Symptom-Speech","Symptom-WEAKNESS","Symptom-OTHER","Symptom-Swallowing",
	   # "Symptom-GAIT_CHANGES","Symptom-Atrophy","Symptom-Cramps","Symptom-Fasciculations",
	   # "Symptom-SENSORY_CHANGES","Symptom-Stiffness","Symptom-.","Race - Asian",
	   # "Race - Black/African American","Race - Caucasian","Race - Other","Age","Sex-Female",
 		# "Sex-Male","Aunt","Aunt (Maternal)","Cousin","Father","Grandfather (Maternal)",
 		# "Grandmother", "Grandmother (Maternal)","Mother","Uncle","Uncle (Maternal)",
 		# "Uncle (Paternal)","Son","Daughter","Sister","Brother","Neurological Disease-OTHER",
 		# "Neurological Disease-STROKE-NOS","Neurological Disease-DEMENTIA-NOS",
 		# "Neurological Disease-PARKINSON'S DISEASE","Neurological Disease-DAT",
 		# "Neurological Disease-ALS", "Neurological Disease-BRAIN TUMOR",
 		# "Neurological Disease-STROKE-ISCHEMIC","Neurological Disease-STROKE-HEMORRHAGIC",
 		# "Study Arm-PLACEBO", "Study Arm-ACTIVE","min.height","last.height","mean.height",
		# "num.height.visits","sum.height","first.height.date","last.height.date",
		# "meansquares.height","sd.height","height.slope")

	# dataset<-dataset[,!(colnames(dataset) %in% drop.features)]

	return(dataset)

}


# 4. Write a function in R or Python that takes in a dataset (.csv file)
#    and a number of days forward, and generates predictions for hourly
#    order volume.

forecast_volume <- function(data_file = "data/hourly_volume.csv",
                            days_forward = 7){

  # load data

  # ...

  # (for illustration purposes) format your data output in this way

  data_out <- data.frame(order_hour = NULL,
                         pred_num_orders = NULL)

  # return predictions

  return(data_out)

}


# Exploratory data analysis for grouped classification data
# Experiment:  Classification
# Mark E. Madsen
# (c) 2013 - see file LICENSE for license terms

library(ggplot2)

qplot(theta, mean_class_richness, data=class.grouped, facets = classification_type ~ classification_coarseness, geom=c("point", "smooth"))

# select three theta levels, since there are so many above 1.0.
grouped.theta_subset <- subset(class.grouped, class.grouped$theta_factor == c("0.2", "1", "10"))

qplot(total_num_classes, mean_class_richness, data=grouped.theta_subset, facets = theta_factor ~ ., geom=c("point"))


# user options

#weigting factor for bias (or other chosen w factor), start with default value
#w.fac<-c(1.0,3.0, 5)
#w.fac<-c(1.0,0.5,2.0)
w.fac<-c(0.01, 0.1, 1, 10, 100)
w.fac<-c(1E-5,1E-6,1E-7)

dev<-'screen'
nox<-1; noy<-1;
cleanup()

######   end user options  ###################

setwd(data.path)
bio.interact<-FALSE

# retrospective runs are made in a separate dirictory
retro.dir<-"retro"

dir.create(retro.dir,showWarnings = FALSE)

SMS.files.single<-c("natmor.in","canum.in","west.in","weca.in","propmat.in","fleet_catch.in","fleet_names.in","fleet_info.dat","just_one.in")

for (from.file in SMS.files.single) {
  to.file<-file.path(data.path,retro.dir,from.file)
  file.copy(from.file, to.file, overwrite = TRUE)
}

# read data and options into FLR objects
control<-read.FLSMS.control()

control@read.HCR<-0

setwd(retro.dir)

for (fac in (w.fac)){
    control@obj.func.weight[1,"survey"]<-fac
    #control@obj.func.weight[1,"stomach"]<-fac    # stomach weighting factor used as smooth F factor

    write.FLSMS.control(control,write.multi=bio.interact)

    shell(paste( file.path(data.path,'retro',"sms.exe"),"-nox -nohess",sep=" "), invisible = TRUE)

    if (!file.copy("summary.out", paste("summary",fac,".out",sep=""), overwrite = TRUE)) stop("Retro stopped: something went wrong in copying summary.dat")
    file.remove("summary.out")

    if (!file.copy("sms.par", paste("sms",fac,".par",sep=""), overwrite = TRUE)) stop("Retro stopped: something went wrong in copying sms.par")
    file.remove("sms.par")

}

av.F.age<-control@avg.F.ages

lab<-''
i<-1
for (fac in(w.fac)) {
  file<-paste('summary',fac,'.out',sep='')
  s<-read.table(file,header=TRUE)
  s<-data.frame(Species=name[s$Species.n+1],s)
  rec<-subset(s,Quarter==control@rec.season & Age==control@first.age)
  rec<-tapply(s$N,list(s$Species.n,s$Year),sum)/1000

  s1<-subset(s,Quarter==1)
  ssb<-tapply(s1$SSB,list(s1$Species.n,s1$Year),sum)/1000

  if (i==1) {
   SSB<-array(NA,dim=c(nsp,dim(ssb)[2],length(w.fac)),
         dimnames=list(control@species.names,seq(control@first.year,control@last.year.model),(w.fac)))
   FI<-SSB
   REC<-SSB
  }
  SSB[,1:dim(ssb)[2],i]<-ssb
  REC[,1:dim(ssb)[2],i]<-rec

  F.at.age<-tapply(s$F,list(s$Year,,s$Age,s$Species.n),sum,na.rm=T)
  for (sp in (1:nsp)){
    FI[,1:dim(ssb)[2],i]<-apply(F.at.age[ ,(av.F.age[1]-fa+1):(av.F.age[2]-fa+1),sp],c(1),mean)  ### kun med en art-- fejl
  }
 i<-i+1
}

noxy<-nox*noy
i<-0
newplot(dev,nox,noy)

plot.retro<-function(x,label,legend.x=0.15,legend.y=1) {
yr<-as.numeric(dimnames(x)[[2]])
l.fac<-length(w.fac)

for (sp in (1:nsp)) {
  if (i==noxy) {newplot(dev,nox,noy); i<<-0 }
  plot(yr,x[sp,,1],xlab='',ylab=label,main=lab,type='b',
    ylim=c(0,max(x[sp,,],na.rm=T)),lwd=2,pch=1,col=2)
   legend("topright",legend=as.character(w.fac),pch=seq(1,l.fac),col=seq(1,l.fac))

  i<<-i+1
  f<-1
  for (fac in (w.fac)) {
    if (l.fac>1)  lines(yr,x[sp,,f],type='b',pch=f,col=f,lwd=2);
    f<-f+1
  }
}
}

plot.retro(SSB,'SSB',legend.x=0.4)
plot.retro(FI,expression(bar(F)),legend.x=0.5)
plot.retro(REC,"recriuts 10^6",legend.x=0.4)

i<-1
for (fac in(w.fac)) {
  file<-paste('sms',fac,'.par',sep='')
  s<-scan(file,comment.char = "#" )
  if (i==1) sms.par<-s else sms.par<-cbind(sms.par,s)
 i<-i+1
}

npar<- dim(sms.par)[1]
first.par<-npar-14
last.par<-npar
bias.fac<-sms.par[first.par:last.par,]
matplot(bias.fac,type='b')
abline(h=1);

setwd(data.path)


#' Perform fine mapping pipeline using susieR
#'
#' Clumps data, then maps those to LD representative regions. Within each detected LD representative region, fine mapping is performed
#'
#' @param vcffile Path to vcf file
#' @param bfile Path to ld reference panel
#' @param plink_bin Path to plink
#' @param pop EUR, ASN or AFR
#' @param clump_kb <what param does>
#' @param clump_r2 <what param does>
#' @param clump_p <what param does>
#' @param ... Optional arguments to be passed to susie_rss
#'
#' @export
#' @return List
susieR_pipeline <- function(vcffile, bfile, plink_bin, pop, threads=1, clump_kb=1000, clump_r2=0.001, clump_p=5e-8, ...)
{
	message("Performing clumping")
	clumped <- clump_gwasvcf(vcffile, plink=plink_bin, bfile=bfile)

	message("Map clumps to regions")
	regions <- map_variants_to_regions(clumped$chrpos, pop=pop)
	regions$rsid <- clumped$rsid[match(regions$variant, clumped$chrpos)]

	message("Obtain LD matrices for each region")
	m <- gwasvcf_to_finemapr(region=regions$region, vcf=vcffile, bfile=ldref, plink_bin=plink, threads=threads)

	message("Perform susieR finemapping in each region")
	m2 <- parallel::mclapply(1:length(m), function(i) {
		message(i)
		res <- susieR::susie_rss(
			m[[i]]$z$zscore,
			m[[i]]$ld,
			...
		)
		res$fmset <- sapply(m[[i]]$susieR$sets$cs, function(x){
			m[[i]]$z$snp[x[which.max(m[[i]]$susieR$pip[x])]]
		})
		return(res)
	}, mc.cores=threads)

	for(i in 1:length(m))
	{
		m[[i]]$susieR <- m2[[i]]
	}
	out <- list(clumped=clumped, regions=regions, res=m)
	return(out)
}


cat(sapply(readLines(tail(commandArgs(), n=1)), function(s) {
  balanced <- function(x = 1, y = 0) {
    if (y < 0) {
      return(FALSE)
    }
    i <- regexpr("[:()]", substring(s, x))[1] - 1
    if (i < 0) {
      return(y == 0)
    }
    x <- x + i
    if (substr(s, x, x) == "(") {
      balanced(x+1, y+1)
    } else if (substr(s, x, x) == ")") {
      balanced(x+1, y-1)
    } else if (substr(s, x, x) == ":") {
      if (x < nchar(s) & substr(s, x+1, x+1) == "(") {
        balanced(x+2, y) | balanced(x+2, y+1)
      } else if (x < nchar(s) & substr(s, x+1, x+1) == ")") {
        balanced(x+2, y) | balanced(x+2, y-1)
      } else {
        balanced(x+1, y)
      }
    } else {
      FALSE
    }
  }
  if (balanced()) {
    "YES"
  } else {
    "NO"
  }
}), sep="\n")


# sample plots
mtus_histogram <- function(country_data){
  #' Example histogram using the `gsdmtus` package
  # Calculate survey means:
  def_survey_objects(country_data)

  # Histogram of percent of time spent working from home (weighted)
  hist <- svyhist(~pct_home_work, svy_part_home, breaks=50,
                  main = "", yaxt = "none", ylab = "",
                  xaxt = "none",
                  xlab = "Share of work occurring at home\n(among those who do some, but not all, work at home)")
  axis(1,at=seq(0,1,by=0.1),labels =
         c("0","10%","20%","30%","40%","50%","60%","70%","80%","90%","100%"))
}

mtus_density <- function(country_data, new_plot = TRUE){
  def_survey_objects(country_data)
  #' Example density plot using the `gsdmtus` package
  line_color = "black"

  dens_part<-svysmooth(~work_time, svy_part_home,bandwidth = 30)
  dens_work<-svysmooth(~work_time, svy_all_work,bandwidth = 30)
  dens_home<-svysmooth(~work_time, svy_all_home,bandwidth = 30)

  # When new_plot == TRUE, the plot is reset from scratch.
  # When new-plot == FALSE, the mtus_density_ov function
  # can overlay lines from a second country onto the plot.
  if (new_plot == TRUE) {
    plot(dens_work,
         lty = 1,lwd=2, #col="red",
         yaxt="none",ylab="",xaxt="none",xlab="Total daily hours spent working",
         xlim=c(0,24*60), ylim=c(0,0.008))
  } else if (new_plot == FALSE) {
    line_color = "red"
  }

  lines(dens_work,lty=1,lwd=2, col = line_color)
  lines(dens_home,lty=2,lwd=1, col = line_color)
  lines(dens_part,lty=1,lwd=1, col = line_color)
  axis(1,at=seq(0,1440,by=60),labels = seq(0,24,by=1))
  legend("topright",inset=0,pt.cex=1,cex=.75, legend=
           c("People who worked exclusively away from home",
             "People who worked exclusively at home",
             "People who who did some, but not all, work at home"),
         lty=c(1,2,1),lwd=c(2,1,1))
}

mtus_cor_test <- function(country_data) {
  cor.test(country_data$work_time,country_data$pct_home_work)
  cor.test(country_data$work_time[country_data$work_time > 420],country_data$pct_home_work[country_data$work_time > 420])
  cor.test(country_data$work_time[country_data$work_time < 420],country_data$pct_home_work[country_data$work_time < 420])
}

mtus_svy_means <- function(country_data) {
  def_survey_objects(country_data)

  # Relative shares of workers all, part, or never from home
  svymean(~work_cat,svy_workers)
  svymean(~full_day,svy_workers)
  svymean(~interaction(full_day,work_cat),svy_workers)

  # Number of trips by group of workers
  svymean(~trips, svy_workers)
  svyby(~trips, ~work_cat, svy_workers, svymean)
  svyby(~trips, ~full_day, svy_workers, svymean)
  svyby(~trips, ~work_cat + full_day, svy_workers, svymean)

  # excluding work trips
  svymean(~fun_trips, svy_workers)
  svyby(~fun_trips, ~work_cat, svy_workers, svymean)
  svyby(~fun_trips, ~full_day, svy_workers, svymean)
  svyby(~fun_trips, ~work_cat + full_day, svy_workers, svymean)

  # just work trips
  svymean(~commutes, svy_workers)
  svyby(~commutes, ~work_cat, svy_workers, svymean)
  svyby(~commutes, ~full_day, svy_workers, svymean)
  svyby(~commutes, ~work_cat + full_day, svy_workers, svymean)
}

mtus_density_ov <- function(country1, country2){
  #' Overlay function for example density plot using the `gsdmtus` package
  mtus_density(country1)
  mtus_density(country2, new_plot = FALSE)
}

mtus_scatter <- function(country_data){
  #' Example scatterplot using the `gsdmtus` package
  ggplot(country_data[country_data$part_home,], aes(work_time, pct_home_work)) +
    geom_point(size=0.05,col="gray") +
    stat_smooth(col='black') +
    theme_bw() +
    scale_x_continuous(breaks = seq(0,1440,by=60),
                       labels = seq(0,24,by=1)) +
    scale_y_continuous(breaks = seq(0,1,by=0.05),
                       labels = paste(seq(0,100,by=5),"%",sep=""),
                       limits = c(0,NA)) +
    xlab("Daily hours spent working\n(among those who do some, but not all, work at home)") +
    ylab("Percent of work occurring at home")
}

mtus_trip_density <- function(country_data) {
  #' Example trip density plot using the `gsdmtus` package
  def_survey_objects(country_data)

  trip_dens_part<-svysmooth(~trips, svy_part_home, bandwidth = 1)
  trip_dens_work<-svysmooth(~trips, svy_all_work, bandwidth = 1)
  trip_dens_home<-svysmooth(~trips, svy_all_home, bandwidth = 1)

  trip_dens_all<-svysmooth(~trips, svy_workers, bandwidth = 1)

  plot(trip_dens_all,
       yaxt="none", ylab="",xaxt="none",xlab="Number of daily trips")
  axis(1,at=seq(0,32,by=2))

  plot(trip_dens_work,
       lty = 1,lwd=2,
       yaxt="none", ylab="",xaxt="none",xlab="Number of daily trips",
       xlim=c(0,30), ylim = c(0,0.5))
  lines(trip_dens_home,lty=2,lwd=1)
  lines(trip_dens_part,lty=1,lwd=1)
  axis(1,at=seq(0,32,by=2))
  legend("topright",inset=0.05,legend=
           c("People who worked exclusively away from home",
             "People who worked exclusively at home",
             "People who who did some, but not all, work at home"),
         lty=c(1,2,1),lwd=c(2,1,1))

}


##' to get the opposite direction, change the sign of the direction.
lpsolve_force_in_dir <- function(min_or_max, direction_constraint, indices_for_muscles,
    output_wrench_dimensionality = 4) {
    # show interest in maximizing the lambda scaler parameter only.
    c_in_cTx <- indices_to_control(direction_constraint, indices_for_muscles)

    lp_result <- lp(min_or_max, objective.in = c_in_cTx, const.mat = direction_constraint$constr,
        const.dir = direction_constraint$dir, const.rhs = direction_constraint$rhs,
        compute.sens = 0)

    # TODO make a function to format the output and return the list
    lambda_constraint_columns <- direction_constraint$constr[, which(c_in_cTx ==
        1)] %>% as.data.frame

    # TODO rm hardcoding to len-22 lambda indices
    lambda_start_indices <- head(which(0:nrow(lambda_constraint_columns)%%22 == 0),
        sum(c_in_cTx))
    lambda_indices <- sapply(lambda_start_indices, function(x) return(x:(x + (output_wrench_dimensionality -
        1))))
    lambda_values <- lp_result$solution[c_in_cTx == 1]
    num_tasks <- sum(c_in_cTx)
    task_directions_of_interest <- lapply(1:ncol(lambda_indices), function(i) {
        # multiplied by -1 because we need to move the output direction back to the rhs
        -lambda_constraint_columns[lambda_indices[, i], i]
    })
    output_vector_per_task <- compose_output_vector_per_task(num_tasks, task_directions_of_interest,
        lambda_values)
    vector_magnitude_per_task <- lapply(output_vector_per_task, function(vector_out) sqrt(sum(vector_out^2)))
    num_muscles <- get_num_muscles_via_indices_for_muscles(indices_for_muscles)
    muscle_activation_pattern_per_task <- compose_muscle_activation_per_task(lp_result,
        num_muscles)
    raw_x_concatenated <- compose_raw_x_concatenated(muscle_activation_pattern_per_task,
        lambda_values)
    output_structure <- list(total_cost = lp_result$objval, direction_per_task = task_directions_of_interest,
        muscle_activation_pattern_per_task = muscle_activation_pattern_per_task,
        lambda_values = lambda_values, output_vector_per_task = output_vector_per_task,
        vector_magnitude_per_task = vector_magnitude_per_task, raw_x_concatenated = raw_x_concatenated)
    return(output_structure)
}
compose_muscle_activation_per_task <- function(lp_result, num_muscles) {
    muscle_activation_pattern_per_task <- t(matrix(lp_result$solution, nrow = num_muscles +
        1)[1:(num_muscles), ]) %>% df_to_list_of_rows
}
compose_output_vector_per_task <- function(num_tasks, task_directions_of_interest,
    lambda_values) {
    output_vector_per_task <- lapply(1:num_tasks, function(i) {
        task_directions_of_interest[[i]] * lambda_values[i]
    })
}
compose_raw_x_concatenated <- function(muscle_activation_pattern_per_task, lambda_values) {
    num_tasks <- length(muscle_activation_pattern_per_task)
    if (num_tasks != length(lambda_values)) {
        stop("length(muscle_activation_pattern_per_task must be the same as length(lambda_values))")
    }
    x <- lapply(1:num_tasks, function(task_index) {
        c(muscle_activation_pattern_per_task[[task_index]], lambda_values[[task_index]])
    }) %>% dcc
    return(x)
}


library(sf)
library(pbapply)

# Find whether a given point (df, with X and Y attributes) is already in the dataset (CurrentDataset)
FindSpatialDuplicates = function(df, CurrentDataset, threshold = 0) {
    if (is.null(CurrentDataset))
        return(0) # No data, we're sure it's not duplicated

    Distances = abs(CurrentDataset$X-df[["X"]])+abs(CurrentDataset$Y-df[["Y"]])
    Duplicates = sum(Distances<=threshold) # Adjust fuzz threshold if necessary

    if (is.null(Duplicates))
        stop(paste0("Unable to calculate distances from point ", X, ",", Y))
    if (!is.finite(Duplicates))
    {
        print(CurrentDataset[is.na(CurrentDataset$X) | is.na(CurrentDataset$Y), c("X", "Y")])
        stop(paste0("Number of duplicates is ", Duplicates, ", check whether input makes sense. Target:", X, ",", Y))
    }
    return(Duplicates)
}

# Get a GPKG-compatible SF object from a data.frame with X and Y attributes
DFtoSF = function(VIDF, coords=c("X", "Y"))
{
    if (!is.data.frame(VIDF))
        VIDF = as.data.frame(VIDF)
    VISpatial = st_as_sf(VIDF, coords=coords, dim="XY", remove=FALSE)
    rm(VIDF)
    names(VISpatial)[names(VISpatial) == "geometry"] = "geom"
    st_geometry(VISpatial) = "geom" # rename to match GPKG name
    st_crs(VISpatial) = 4326
    return(VISpatial)
}

# Run a specificed function on the time series of input SF and return a compatible SF
RunSFFunction = function(sfo, fx, subset=TRUE, keepcols=c("X", "Y"), ...)
{
    cbind(sfo[subset, keepcols], fx(as.matrix(subset(as.data.frame(sfo), subset=subset, ...))))
}

# Apply a function to each row of the sf and return the result as a matrix
ApplySF = function(sfo, fx, subset=TRUE, select=TRUE, cl=NULL, ...)
{
    t(pbapply(as.matrix(subset(as.data.frame(sfo), subset=subset, select=select)), 1, fx, ..., cl=cl))
}


library(ggplot2)

margProb <- function(x) as.vector(table(x))/length(x)

nameProbs <- function(probs,cnames){
    if(is.vector(cnames)){
        stopifnot(all(sapply(probs,ncol)==length(cnames)))
        for(i in 1:length(probs)) colnames(probs[[i]]) <- cnames
        return(probs)
    }
    namediff <- setdiff(names(probs),names(cnames))
    if(length(namediff)) warning(paste('names(probs) not in names(cnames):',paste(namediff,collapse='\n')))
    for(nn in names(probs)) colnames(probs[[nn]]) <- cnames[[nn]]
    probs
}

rowMax <- function(x,...) apply(x,1,max,...)
rowMin <- function(x,...) apply(x,1,min,...)

makeplot2 <- function(mod,classNames=NULL,itemNames=NULL,cnames=NULL,probs=NULL,P=NULL,include.margin=FALSE,data=NULL,calc=NULL,wght=NULL){

    probs2 <- makeProbs(mod=mod,classNames=classNames,itemNames=itemNames,cnames=cnames,
                        probs=probs,P=P,include.margin=include.margin,data=data,calc=calc)

    if(!is.null(calc) | include.margin){
        plt <- ggplot(probs2,aes(response,prob,fill=orig))
    } else plt <- ggplot(probs2,aes(response,prob))

    plt <- plt+geom_col()+facet_grid(class~item,scales='free_x')+
        theme(axis.text.x = element_text(angle = 90, hjust =1,vjust=.2,size=8),axis.text.y=element_text(size=8))+
        scale_y_continuous(breaks=c(0.5,1),labels=c(0.5,1))+
            xlab(NULL)+ylab('Probability')
    if(!is.na(mod$probs.se[1]))
        plt <- plt+geom_errorbar(aes(ymin=ebmin,ymax=ebmax),width=0)
    if('orig'%in%names(probs2)) plt <- plt+theme(legend.position='none')
    plt
}

makeProbs <- function(mod,classNames=NULL,itemNames=NULL,cnames=NULL,probs=NULL,P=NULL,include.margin=FALSE,data=NULL,calc=NULL,wght=NULL){

    if(!missing(mod)){
        if(is.null(probs)) probs <- mod$probs
        if(is.null(P)) P <- mod$P
        if(is.null(data)) data <- mod$y
    }
    if(!is.null(cnames)) probs <- nameProbs(probs,cnames)
    if(is.null(classNames)) classNames <- paste('Class',1:nrow(probs[[1]]))
    if(!is.null(P))
        classNames <- paste0(classNames,'\n',round(P*100),
                             #ifelse(is.na(mod$P.se),'',paste0('\u00B1',round(200*mod$P.se))),
                             '%')
    if(include.margin){
        if(is.null(data)) stop('need data to include marginal probabilities')
        stopifnot(all(names(probs)%in%names(data)))
        for(nn in names(probs)) probs[[nn]] <- rbind(probs[[nn]],margProb(data[[nn]],wght))
        classNames <- c(classNames,paste0('Overall',ifelse(is.null(P),'','\n100%')))
    }

    if(is.null(itemNames)) itemNames <- if(is.null(names(probs))) 1:length(probs) else names(probs)
    K.j <- sapply(probs,ncol)
    probs2 <- NULL
    resps <- NULL
    for(i in 1:length(K.j)){
        pp <- as.data.frame(probs[[i]])
        resps <- c(resps,colnames(pp))
        pp$class <- classNames
        pp <- pp%>%gather(response,prob,1:K.j[i])
        pp$item <- itemNames[i]
        if(!is.null(calc)) pp$orig <- !names(probs)[i]%in%calc
        probs2 <- rbind(probs2,pp)
    }
    if(!is.na(mod$probs.se[1])){
        pse <- NULL
        for(i in 1:length(K.j)){
            pp <- as.data.frame(mod$probs.se[[i]])
            names(pp)=colnames(probs[[i]])
            if(include.margin) pp <- rbind(pp,0)
            pp$class <- classNames
            pp <- pp%>%gather(response,se,1:K.j[i])
            pp$item <- itemNames[i]
            pse <- rbind(pse,pp)
        }
        probs2 <- merge(probs2,pse,all.x=TRUE)
        probs2 <- within(probs2,{
                             ebmin=rowMax(cbind(prob-2*se,0))
                             ebmax=rowMin(cbind(prob+2*se,1))
                         }
                         )
    }
    probs2$response <- factor(probs2$response,levels=unique(resps))
    probs2$class <- factor(probs2$class,levels=classNames)
    probs2$item <- factor(probs2$item,levels=itemNames)

    if(include.margin){
        if(is.null(calc)) probs2$orig <- TRUE
        probs2$orig[grep('^Overall',probs2$class)] <- FALSE
    }

    probs2

}


#!/usr/bin/Rscript

#.libPaths("/var/www/html/OmicsARules/R-3.2.3/library");

args<-commandArgs(T);
path=args[1];
FDR_value=as.numeric(args[2]);

result=read.table(paste(path,"result0_pita.txt", sep="/"), header=TRUE);
occurence=result[7];
greater=result[8];
pvalue=greater/1000;

n=nrow(pvalue);
FDR=p.adjust(as.numeric(pvalue[[1]]),"fdr", n);

result_m=as.matrix(result);
pvalue_m=as.matrix(pvalue);
colnames(pvalue_m)=c("pvalue");

FDR_m=as.matrix(FDR);
colnames(FDR_m)="FDR";

result_all=cbind(result_m, pvalue_m, FDR_m);

data=result_all[result_all[,10] <= FDR_value,];

write.table(data, paste(path, "result_pita.txt", sep="/"), sep="\t", quote=FALSE, row.names = FALSE);

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

result=read.table(paste(path,"result0_TS.txt", sep="/"), header=TRUE);
occurence=result[5];
greater=result[6];
pvalue=greater/1000;

n=nrow(pvalue);
FDR=p.adjust(as.numeric(pvalue[[1]]),"fdr", n);

result_m=as.matrix(result);
pvalue_m=as.matrix(pvalue);
colnames(pvalue_m)=c("pvalue");

FDR_m=as.matrix(FDR);
colnames(FDR_m)="FDR";

result_all=cbind(result_m, pvalue_m, FDR_m);

data=result_all[result_all[,9] <= FDR_value,];

write.table(data, paste(path, "result_TS.txt", sep="/"), sep="\t", quote=FALSE, row.names = FALSE);


context('constraint dimensionality')
# TODO make prediction of num constraints from the H matrix, num tasks, and task dimensionality


setwd("I:\\VisTrails\\Central_VisTrailsInstall_debug\\vistrails\\packages\\sahm\\pySAHM\\Resources\\R_Modules")
source("FIT_BRT_pluggable.r")
source("FIT_MARS_pluggable.r")
source("FIT_RF_pluggable.r")
source("FIT_GLM_pluggable.r")

source("EvaluationStats.r")
source("TestTrainRocPlot.r")
source("read.ma.r")
source("proc.tiff.r")
source("PredictModel.r")

# Currently testing to see if models work with
#  * new test train split
#  * separation of model fit from prediction
#  * working with count data
#  * producing correct evaluation metrics
#Future testing will include testing that factor columns are handled correctly
#trace(proc.tiff,browser)
#options(error=expression(if(interactive()) recover() else dump.calls()))
#options(error=NULL)
#trace(proc.tiff,browser)
#######################################################
## Count TESTING
#this file does not have a test training split but uses Poisson data
input.file="N:\\Active\\FORT_RAM\\VisTrails\\workspace\\mtalbert_20110607T084252\\TestTrainingSplit_2.csv"
rc="responseCount"
output.dir="C:\\VisTrails"

fit.brt.fct(ma.name=input.file,
      tif.dir=NULL,output.dir=output.dir,
      response.col=rc,test.resp.col="response",make.p.tif=F,make.binary.tif=F,
      simp.method="cross-validation",debug.mode=T,responseCurveForm="pdf",tc=NULL,n.folds=3,alpha=.3,script.name="brt.r",
      learning.rate =NULL, bag.fraction = 0.5,prev.stratify = TRUE, model.family = "poisson", opt.methods=1,seed=1,save.model=TRUE)

    PredictModel(workspace=paste("C:\\VisTrails","modelWorkspace",sep="\\"),out.dir="C:\\VisTrails")

fit.glm.fct(ma.name=input.file,
      tif.dir=NULL,
      output.dir=output.dir,
      response.col=rc,make.p.tif=F,make.binary.tif=F,
      simp.method="AIC",debug.mode=T,responseCurveForm="pdf",script.name="glm.r",model.family="poisson")

    PredictModel(workspace=paste(output.dir,"modelWorkspace",sep="\\"),out.dir="C:\\VisTrails")

fit.mars.fct(ma.name=input.file,
        tif.dir=NULL,output.dir=output.dir,
        response.col=rc,make.p.tif=F,make.binary.tif=F,
        mars.degree=1,mars.penalty=2,debug.mode=T,responseCurveForm="pdf",model.family="poisson",script.name="mars.r")

    PredictModel(workspace=paste("C:\\VisTrails\\mtalbert_20110504T132851","modelWorkspace",sep="\\"),out.dir="C:\\VisTrails")

############################################################################
#Making sure some old stuff works here's a presence absence model with no
rc="ResponseBinary"
    input.file="C:\\VisTrails\\mtalbert_20110504T132851\\MergedDataSet_1.csv"
fit.brt.fct(ma.name=input.file,
      tif.dir=NULL,output.dir=output.dir,
      response.col=rc,test.resp.col="response",make.p.tif=F,make.binary.tif=F,
      simp.method="cross-validation",debug.mode=T,responseCurveForm="pdf",tc=NULL,n.folds=3,alpha=.3,script.name="brt.r",
      learning.rate =NULL, bag.fraction = 0.5,prev.stratify = TRUE, model.family = "bernoulli", opt.methods=2,seed=1,save.model=TRUE)

PredictModel(workspace=paste("C:\\VisTrails","modelWorkspace",sep="\\"),out.dir="C:\\VisTrails")

## Now testing GLM model with count data
input.file="N:\\Active\\FORT_RAM\\VisTrails\\workspace\\mtalbert_20110607T084252\\TestTrainingSplit_2.csv"
    rc="responseCount"
 output.dir="C:\\VisTrails"

##this does have a test training split, trying to figure out some good output for evaluation metrics module
input.file="N:\\Active\\FORT_RAM\\VisTrails\\workspace\\mtalbert_20110607T084252\\MergedDataset_2.csv"
    rc="responseCount"

fit.brt.fct(ma.name=input.file,
      tif.dir=NULL,output.dir=output.dir,
      response.col=rc,test.resp.col="response",make.p.tif=F,make.binary.tif=F,
      simp.method="cross-validation",debug.mode=T,responseCurveForm="pdf",tc=NULL,n.folds=3,alpha=.3,script.name="brt.r",
      learning.rate =NULL, bag.fraction = 0.5,prev.stratify = TRUE, model.family = "poisson", opt.methods=1,seed=1,save.model=TRUE)

#########################################################
## MARS TESTING
input.file="N:\\Active\\FORT_RAM\\VisTrails\\workspace\\mtalbert_20110607T084252\\MergedDataset_1.csv"
    rc="responseCount"

#########################################################
## GLM TESTING
output.dir="C:\\VisTrails\\mtalbert_20110504T132851"
    rc="ResponseBinary"
    input.file="C:\\VisTrails\\mtalbert_20110504T132851\\MergedDataSet_1.csv"

#this file does have a test training split
    input.file<-"I:\\VisTrails\\WorkingFiles\\workspace\\talbertc_20110519T121044\\TestTrainingSplit_1.csv"
    rc="responseBinary"

fit.glm.fct(ma.name=input.file,
      tif.dir=NULL,
      output.dir=output.dir,
      response.col=rc,make.p.tif=F,make.binary.tif=F,
      simp.method="AIC",debug.mode=T,responseCurveForm="pdf",script.name="glm.r")

PredictModel(workspace=paste("C:\\VisTrails\\mtalbert_20110504T132851","modelWorkspace",sep="\\"),out.dir="C:\\VisTrails")

########################################################
## RANDOM FOREST TESTING
output.dir="C:\\VisTrails\\mtalbert_20110504T132851"
    rc="ResponseBinary"
    input.file="C:\\VisTrails\\mtalbert_20110504T132851\\MergedDataSet_1.csv"

#this file does have a test training split
    input.file<-"I:\\VisTrails\\WorkingFiles\\workspace\\talbertc_20110519T121044\\TestTrainingSplit_1.csv"
    rc="responseBinary"

fit.rf.fct(ma.name=input.file,
  tif.dir=NULL,
  output.dir=output.dir,
  response.col=rc,make.p.tif=F,make.binary.tif=F,
      debug.mode=T,n.trees=1000)

PredictModel(workspace=paste("C:\\VisTrails\\mtalbert_20110504T132851","modelWorkspace",sep="\\"),out.dir="C:\\VisTrails")

#Now testing to make sure this code works with no test training split
ma.name<-"H:\\Desktop\\SAHM\\Rcode\\ExposingModelParameters\\ModelOutputCheck\\NewInput.csv"
ma.name="C:\\VisTrails\\mtalbert_20110406T093111\\sahm4h5b1t.mds"

ma.name="I:\\VisTrails\\WorkingFiles\\workspace\\GYA_demo\\test.csv"
fit.brt.fct(ma.name=ma.name,
      tif.dir=NULL,output.dir="H:\\Desktop\\SAHM\\Rcode\\ExposingModelParameters\\PDFCheck",
      response.col="ResponseBinary",test.resp.col="response",make.p.tif=T,make.binary.tif=T,
            simp.method="cross-validation",debug.mode=T,responseCurveForm="pdf",tc=NULL,n.folds=3,alpha=1,script.name="brt.r",
           learning.rate =NULL, bag.fraction = 0.5,prev.stratify = TRUE, model.family = "bernoulli", max.trees = NULL)

#this is the GLM_pluggable1.r under NewMDSBuilder (Works with new vistrails format)
input.file="I:\\VisTrails\\WorkingFiles\\workspace\\talbertc_20110510T100421\\TestTrainingSplit_1.csv"
output.dir="C:\\VisTrails\\mtalbert_20110504T132851"
rc="responseCount"

      fit.glm.fct(ma.name=input.file,
      tif.dir=NULL,output.dir="H:\\Desktop\\SAHM\\Rcode\\ExposingModelParameters\\PDFCheck",
      response.col=rc,make.p.tif=T,make.binary.tif=T,
      simp.method="AIC",debug.mode=T,responseCurveForm="pdf",script.name="glm.r")

#Mars check Works with new vistrails format
      fit.mars.fct(ma.name=ma.name,
        tif.dir=NULL,output.dir="H:\\Desktop\\SAHM\\Rcode\\ExposingModelParameters\\PDFCheck",
        response.col="ResponseBinary",test.resp.col="response",make.p.tif=T,make.binary.tif=T,
            mars.degree=1,mars.penalty=2,debug.mode=T,responseCurveForm="pdf",ma.test=NULL,model.family="binomial",script.name="mars.r")

fit.rf.fct(ma.name="I:\\VisTrails\\WorkingFiles\\workspace\\GYA_demo\\test.csv",
  tif.dir=NULL,
  output.dir="H:\\Desktop\\SAHM\\Rcode\\ExposingModelParameters\\PDFCheck",
  response.col="ResponseBinary",test.resp.col="response",make.p.tif=T,make.binary.tif=T,
      debug.mode=T,n.trees=1000,ma.test=NULL,make.r.curves=T,script.name="glm.r")

#this one does not subset paths set up in the old way works with old sahm as well as for
fit.brt.fct(ma.name="H:\\Desktop\\SAHM\\Data\\CanadaThistle\\canadathistle_gcs_grp_r_mds_train.mds",
tif.dir="H:\\Desktop\\SAHM\\Data\\CanadaThistle\\layers",output.dir="H:\\Desktop\\SAHM\\Rcode\\ExposingModelParameters\\PDFCheck",
response.col="response.binary",test.resp.col="response",make.p.tif=T,make.binary.tif=T,
      simp.method="cross-validation",debug.mode=T,responseCurveForm="pdf",tc=NULL,n.folds=3,ma.test=NULL,alpha=1,script.name="brt.r",
     learning.rate =NULL, bag.fraction = 0.5,prev.stratify = TRUE, model.family = "bernoulli", max.trees = NULL)

fit.mars.fct(ma.name="H:\\Desktop\\SAHM\\Data\\CanadaThistle\\canadathistle_gcs_grp_r_mds_train.mds",
  tif.dir="H:\\Desktop\\SAHM\\Data\\CanadaThistle\\layers",
  output.dir="H:\\Desktop\\SAHM\\Rcode\\ExposingModelParameters\\PDFCheck",
  response.col="response.binary",test.resp.col="response",make.p.tif=T,make.binary.tif=T,
      mars.degree=1,mars.penalty=2,debug.mode=T,responseCurveForm="pdf",ma.test=NULL,model.family="binomial",script.name="mars.r")

fit.glm.fct(ma.name="H:\\Desktop\\SAHM\\Data\\CanadaThistle\\canadathistle_gcs_grp_r_mds_train.mds",
  tif.dir="H:\\Desktop\\SAHM\\Data\\CanadaThistle\\layers",
  output.dir="H:\\Desktop\\SAHM\\Rcode\\ExposingModelParameters\\PDFCheck",
  response.col="response.binary",test.resp.col="response",make.p.tif=T,make.binary.tif=T,
      simp.method="AIC",debug.mode=T,responseCurveForm="pdf",ma.test=NULL,script.name="glm.r")


#########################################################################
############ Some basic code for outputting the results #################
############ from Illuminus
############ Taane Clark: last updated 1/8/2007
#########################################################################

# if you are using files with pert scores, you will need to uncomment
# some of the code below to remove the extra column when assessing the
# calls

########################
### read in the data ###
########################

example <- as.matrix(read.table("example.txt", header=T)) ## raw data
calls1 <- as.matrix(read.table("out_calls", header=F))  ## calls

########################
### ploting function ###
########################

plotthe <- function(i)
{

ncol3<- dim(example)[2]
nrow3 <-dim(calls1)[1]

par(ask = TRUE)

while(i<=nrow3)
{
#print(table(calls1[i,-c(1,2)]))
print(table(calls1[i,-c(1,2,3)]))
xx <- as.numeric(unlist(example[i,seq(3,ncol3-1,by=2)]))
yy <- as.numeric(unlist(example[i,seq(4,ncol3,  by=2)]))
#print(table(xx<0.0)); print(table(yy<0.0))
mx <- max(xx,na.rm=T)
my <- max(yy,na.rm=T)
cc <- (yy-xx)/(xx+yy)
ss <- log(as.numeric(xx)+as.numeric(yy))
# print(table(xx<=0 &  yy<=0))
missing <- as.numeric(xx)<=0 & as.numeric(yy) <= 0
cc[ missing ] <- 0.0
ss[ missing ] <- 0.0
#print(summary(cc))
#print(summary(ss))

############ plot 1: raw scale ###################

#plot(xx[!missing],yy[!missing],main=paste(as.character(example[i,1]),as.character(example[i,2]),
#"miss = ",sum(1*missing)),xlab="A",ylab="B", xlim=c(0,mx),ylim=c(0,my),type="n")
#points(xx[!missing],yy[!missing],pch=20, col = as.numeric(calls1[i,-c(1,2)])[!missing],cex=0.5)
plot(xx[!missing],yy[!missing],main=paste(as.character(example[i,1]),as.character(example[i,2]),
as.character(calls1[i,3]),"miss = ",sum(1*missing)),xlab="A",ylab="B",
xlim=c(0,mx),ylim=c(0,my),type="n")
points(xx[!missing],yy[!missing],pch=20, col = as.numeric(calls1[i,-c(1,2,3)])[!missing],cex=0.5)

######## plot 2: contrast / strength scale ########

#plot(cc,ss,main=paste(as.character(example[i,1]),as.character(example[i,2])),
#xlab="Contrast",ylab="Strength",type="n")
#points(cc,ss,pch=20, col = as.numeric(calls1[i,-c(1,2)]),cex=0.5)
plot(cc,ss,main=paste(as.character(example[i,1]),as.character(example[i,2]),
as.character(calls1[i,3])),xlab="Contrast",ylab="Strength",type="n")
points(cc,ss,pch=20, col = as.numeric(calls1[i,-c(1,2,3)]),cex=0.5)

i <- i+1
}
}

par(mfrow=c(1,2))
plotthe(1)


# use install.packages("PackageName") to install all packages below
library(shiny)
library(ggplot2)
library(magrittr)
library(dplyr)
library(rsconnect)

# Define UI logic ----

ui <- fluidPage(

  titlePanel("Historical Demographic Trends"),

  fluidPage(

    # Defines sidebar panel selections
    sidebarPanel(

      # Makes slider range for years
      sliderInput("slider", label = h3("Year Range"), min = 1934,
                  max = 2014, value = c(1934, 2014), sep = ""),

      # Makes radio buttons for sex
      radioButtons("radio", label = h3("Select Sex"),
                   choices = list("Men" = "Male", "Women" = "Female"),
                   selected = "Male"),

      # Makes checkboxes for age groups
      checkboxGroupInput("age", "Age Groups:",
                  c("Adjusted" = "adjusted",
                    "Ages 5-14" = "age05.14",
                    "Ages 15-24" = "age15.24",
                    "Ages 25-44" = "age25.44",
                    "Ages 45-64" = "age45.64",
                    "Ages 65-84" = "age65.84"),
                  selected = c("adjusted")),

      # Makes checkbox for whether the line is smoothed
      checkboxInput("smooth", "3-Year Moving Average", TRUE)

    ),

    # Defines main panel layouts
    mainPanel(
      h3(textOutput("selected_var")), # graph title based on sex selection, defined in output
      p("Positive = black population experience higher MV death rates compared to white population",
        style = "font-family: 'times'; font-si16pt"),
      plotOutput("mv_plot"), #graph defined below
      h6("Source: Historical CDC Vital Statistics Data"),
      h6("Analysis and app built by Monica M. King")

    )
)

)
# reads in cleaned data from AWS
mv_data <- read.csv(url("https://s3.amazonaws.com/shiny-app-data/absolute_differences_historical_bw.csv")) %>%
  mutate(bw_asdr_perdiff = (bw_asdr-1)*100, # defined var for % difference instead of ratio
         bw_asdr_perdiff.s = (bw_asdr.s-1)*100)

# sets the break of the x-axis label based on the selected year range
# @param: min_value is an integer
# @param: max_value is an integer
# @return is an integer

def_break_length <- function(min_value, max_value){
  total_range <- max_value-min_value
  if (total_range > 40){
    return(10)
  } else if (total_range %in% (15:40)){
    return(5)
  } else{
    return(1)
  }
}

# Define server logic
server <- function(input, output) {

  output$selected_var <- renderText({
    paste0("Black-White Differences in Motor Vehicle Death Rates for ", input$radio, "s, 1934-2014")
  })

  output$mv_plot <- renderPlot({mv_data %>%
    filter(age.cat %in% input$age,
           gender == input$radio,
           year %in% (input$slider[1]:input$slider[2])) %>%
      ggplot(aes(x= year,
                 y= if(input$smooth){ # whether y is smoothed or not
                   bw_asdr_perdiff.s
                 }else{
                   bw_asdr_perdiff
                 },
                 group = age.cat, colour = age.cat)) +
      scale_colour_manual(name = "Age Groups",
                          values = c("#000000", "#e41a1c", "#377eb8", "#4daf4a",
                                     "#984ea3", "#ff7f00"),
                          labels = c("Age-adjusted", "Ages 5-14", "Ages 15-24",
                                     "Ages 25-44", "Ages 45-64", "Ages 65-84")) +
      geom_hline(yintercept=1, color = "dark grey") +
      geom_line() +
      theme(legend.position="bottom") +
      theme_bw()  +
      theme(text = element_text(size=16))+
      theme(legend.position="right") +
      theme(axis.title.x = element_blank()) + # Remove x-axis label
      ylab("Black-White % Difference") +
      scale_x_continuous(breaks = seq(1930, 2015, def_break_length(input$slider[1], input$slider[2]))) +
      scale_y_continuous(breaks = seq(-80, 80, 10))}
)

}

shinyApp(ui, server)