############################################################
# For owl monkey project, last revised 04.18
# Plots and statistical tests for Figure 2 in owl monkey
# paper.
#
# Gregg Thomas
############################################################

library(ggplot2)
library(reshape2)
library(cowplot)
library(gridExtra)
this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

####################
## Read the input data
in_data = read.csv("data/mutational-spectra.csv", header=TRUE)
####################

####################
## Generate the owl monkey plot
om_spec = data.frame(in_data$Mutation, in_data$Owl.monkey.CpG.proportion, in_data$Owl.monkey.proportion)
names(om_spec) = c("Type", "CpG", "Non-CpG")
om_spec_m = melt(om_spec)

om_p = ggplot(om_spec_m, aes(Type, value, fill = variable)) +
  geom_bar(stat = "identity") +
  scale_fill_manual("legend", values = c("Non-CpG"="#006ddb","CpG"="#db6d00")) +
  ggtitle("Owl monkey") +
  labs(x="",y="Proportion of mutations") +
  theme_classic() +
  theme(axis.text=element_text(size=14),
        axis.title.y=element_text(size=14),
        axis.line=element_line(colour='#595959',size=0.75),
        axis.ticks=element_line(colour="#595959",size = 1),
        axis.ticks.length=unit(0.2,"cm"),
        legend.title=element_blank(),
        legend.position=c(0.1,0.87)
  )
####################

####################
## Generate the human plot
human_spec = data.frame(in_data$Mutation, in_data$Human.average.proportion)
names(human_spec) = c("Type", "Human average")
human_spec_m = melt(human_spec)

h_p = ggplot(human_spec_m, aes(Type, value, fill = variable)) +
  geom_bar(stat = "identity") +
  scale_fill_manual("legend", values = c("Human average" = "#920000")) +
  ggtitle("Human") +
  labs(x="",y="Proportion of mutations") +
  theme_classic() +
  theme(axis.text=element_text(size=14),
        axis.title.y=element_text(size=14),
        axis.line=element_line(colour='#595959',size=0.75),
        axis.ticks=element_line(colour="#595959",size = 1),
        axis.ticks.length=unit(0.2,"cm"),
        legend.position="none"
  )
####################

####################
## Generate the chimp plot
ch_spec = data.frame(in_data$Mutation, in_data$Chimp.proportion)
names(ch_spec) = c("Type", "Proportion")
ch_spec_m = melt(ch_spec)

c_p = ggplot(ch_spec_m, aes(Type, value, fill = variable)) +
  geom_bar(stat = "identity") +
  scale_fill_manual("legend", values = c("Proportion" = "#920000")) +
  ggtitle("Chimpanzee") +
  labs(x="",y="") +
  theme_classic() +
  theme(axis.text=element_text(size=14),
        axis.title.y=element_text(size=14),
        axis.line=element_line(colour='#595959',size=0.75),
        axis.ticks=element_line(colour="#595959",size = 1),
        axis.ticks.length=unit(0.2,"cm"),
        legend.position="none"
  )
####################

####################
## Arrange the three plots and display/save
g1 = arrangeGrob(h_p,c_p,nrow=1)
fig2 = plot_grid(om_p,g1, nrow=2, rel_heights=c(2, 1))
print(fig2)
ggsave(filename="fig2.pdf", fig2, width=8, height=6, units="in")
####################

####################
## Chi-square tests to check for significant differences between human and owl monkey spectra
print("--OWL MONKEY Chi-squared test using human proportions as expectations--")
print("Using all mutation categories:")
all_chi = chisq.test(in_data$Owl.monkey+in_data$Owl.monkey.CpG, p=in_data$Human.average.proportion)
print(all_chi)
print("Leaving out A>T:")
human_noAT = in_data$Human.average.proportion[in_data$Mutation!="A>T"]
human_noAT = human_noAT / sum(human_noAT)
om_noAT = in_data$Owl.monkey[in_data$Mutation!="A>T"] + in_data$Owl.monkey.CpG[in_data$Mutation!="A>T"]
noAT_chi = chisq.test(om_noAT, p=human_noAT)
print(noAT_chi)
####################


#' Title
#'
#' @param data Data to be plotted
#' @param type R-package to generate the plot. c("plotly", "heatmaply")
#'
#' @return A plotly heatmap
#' @importFrom rlang .data
#' @export
#'
create_heatmap <- function(data = NULL, type = "plotly") {
    if ("level3_name" %in% colnames(data)) {
        tmp <- tidyr::unite(data, .data$level1_name, .data$level2_name, .data$level3_name, col = "combined", sep = ": ")
    } else if ("level2_name" %in% colnames(data)) {
        tmp <- tidyr::unite(data, .data$level1_name, .data$level2_name, col = "combined", sep = ": ")
    } else if ("level1_name" %in% colnames(data)) {
        tmp <- data
        tmp$combined <- tmp$level1_name
    }
    spread_data <- tidyr::spread(tmp[, c("area", "area_name", "combined", "value")],
                                 key = .data$combined,
                                 value = .data$value
    )
    spread_data <- dplyr::filter(spread_data, .data$area != 8888)
    row.names(spread_data) <- spread_data$area_name
    spread_data$area_name <- NULL
    spread_data$area <- NULL
    if (type == "plotly") {
        heatmap <- plotly::plot_ly(
            y = row.names(spread_data),
            x = names(spread_data),
            z = abs(scale(spread_data)),
            type = "heatmap",
            colors = c("white", SKDEr::skde_colors(num = 7)),
            showscale = FALSE
        ) %>%
            plotly::config(displayModeBar = FALSE)
    } else if (type == "heatmaply") {
        heatmap <-  heatmaply::heatmaply(
            spread_data,
            plot_method = "plotly",
            dendrogram = "none",
            scale = "column",
            column_text_angle = 45,
            colors = c("white", SKDEr::skde_colors(num = 7)),
            grid_gap = 1,
            hide_colorbar = TRUE
        ) %>%
            plotly::config(displayModeBar = FALSE)
    }
    return(heatmap)
}


library(data.table)

indir = "~/git/US-covid19-data-scraping" # path directory to the repository

last_Date = "2020-10-29"
path.to.jhu.data = file.path(indir, "data", "official", "jhu_death_data_padded_201217.rds")
path.to.nyc.data = file.path(indir, "data", "official", "NYC_deaths_201217.csv")
path.to.deathByAge.data = file.path(indir, "data", "processed", last_Date, "DeathsByAge_US.csv")
path.to.demographics.data = file.path(indir, "data_visualization", "data", "us_population_withnyc.rds")

outtab.dir = file.path(indir, "data_visualization", "tables_v120")
outfig.dir = file.path(indir, "data_visualization", "figures_v120")

dir.create(outtab.dir, showWarnings = FALSE)
dir.create(outfig.dir, showWarnings = FALSE)

source(file.path(indir, "utils", "summary.functions.R"))
source(file.path(indir, "data_visualization", "functions", "data-visualization-summary_functions.r"))
source(file.path(indir, "data_visualization", "functions", "data-visualization-plot_functions.r"))

#
# Read data
# read demographics by age to get location label
pop_count = as.data.table( read_pop_count_by_age_us(path.to.demographics.data) )
setnames(pop_count, "state", "loc_label")
pop_info = unique(select(pop_count, code, loc_label))

# read death by age
deathByAge = as.data.table( read.csv( path.to.deathByAge.data ) )
set(deathByAge, NULL, 'date', deathByAge[,as.Date(date)])
deathByAge = merge(deathByAge, pop_info, by = c("code"))

# read overall death from JHU and NYC
death_data = as.data.table( readRDS( path.to.jhu.data ) )
tmp = as.data.table( read.csv( path.to.nyc.data ) )
setnames(tmp, c("date_of_interest","DEATH_COUNT"), c("date", "daily_deaths"))
tmp[, date := as.Date(date, format = "%m/%d/%Y")]
tmp[, code := "NYC"]
death_data = rbind(select(death_data, code, date, daily_deaths), select(tmp, code, date, daily_deaths))
death_data = merge(death_data, pop_info, by = c("code"))
death_data = subset(death_data, date <= last_Date)

#
# Make summaries
data_summary = summarise_DeathByAge(deathByAge, pop_info)

#
# Make reporting statistics on the data format
data_statistics = find_reporting_data_format_statistics(deathByAge, last_Date, death_data)

#
# Make reporting statistics on the data
last_month = as.Date("2020-11-01")
tmp = subset(deathByAge, date == last_month)
CumDeath_statistics = find_reporting_mortality_counts_statistics(copy(tmp), copy(pop_count))
CumDeath_statistics = c(list(format(last_month, "%B %d, %Y")), CumDeath_statistics)

#
# Plot
# observation days
tmp = subset(data_summary, n_days != "-")
tmp[, n_days := as.numeric(n_days)]
p_heat_map_usa_n_days = plot_heat_map_usa(tmp, "n_days", "Number of \nobservationed days")

# cumulative deaths over time
selected_states = c ("CA", "ID", "FL", "UT")
p_cum_deaths_by_age = plot_cum_deaths_by_age(deathByAge, selected_states)

# comparison to JHU data and NYC data
p_comparison_overall = plot_death_by_age_vs_deaths_overall(deathByAge, death_data)
p_comparison_overall_difference = plot_death_by_age_vs_deaths_overall_difference(deathByAge, death_data)

#
# Save
saveRDS(list(data_summary, data_statistics, CumDeath_statistics), file = file.path(outtab.dir, paste0("DeathsByAge_summary.rds")), version = 2)
ggsave(p_heat_map_usa_n_days, file = file.path(outfig.dir, paste0("heat_map_usa_", "NumberObservedDays", ".png")), w = 9, h = 5)
ggsave(p_cum_deaths_by_age, file = file.path(outfig.dir, paste0("CumDeathsByAgeData.png")), w = 11, h = 8)
ggsave(p_comparison_overall, file = file.path(outfig.dir, paste0("CumDeathsData_ComparisonUnstratified.png")), w = 8, h = 10)
ggsave(p_comparison_overall_difference, file = file.path(outfig.dir, paste0("CumDeathsData_ComparisonUnstratified_diff.png")), w = 8, h = 10)


source('covidmap/stage2.r')
opt = covidmap_stage2_get_cmdline_options()
print(opt)
env = covidmap_stage2_setup(opt)
covidmap_stage2_run(env)
covidmap_stage2_postprocess(env)


#' @title testr: Bayesian A/B Testing Engine
#' @description Tools for Bayesian design and analysis of of randomized
#'   experiments (A/B/../N tests). testr uses an adaptive design (i.e.
#'   early stopping rules), allowing tests to end as early as possible.
#' @name testr
#' @docType package
NULL


# prepare_data.r
# Author: David Van Riper
# Date: 2020-09-28
#
# This script creates three long data frames - SF1, v1 (Oct 2019) and v2 (June 2020) - and adds sex, age, and race codes to each record.

#### Load packages ####
require(tidyverse)

#### Factor parameters ####
sex_levels <- c(0,1)
sex_labels <- c("M", "F")

race_levels <- c(0,1,2,3,4,5,6,7, 8,9)
race_labels <- c("na", "white_alone", "black_alone", "aian_alone", "asian_alone", "nhopi_alone", "sor_alone", "two_or_more", "hisp", "white_alone_not_hisp")

age_grp_levels <- c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17)
age_grp_labels <- c("0-4", "5-9", "10-14", "15-19", "20-24", "25-29", "30-34", "35-39", "40-44", "45-49", "50-54", "55-59", "60-64", "65-69", "70-74", "75-79", "80-84", "85+")

version_levels <- c("sf", "v1", "v2")
version_labels <- c("sf", "v1", "v2")

#### Prepare single recode df ####
recode <- rbind(sex_age_five_year_recode.csv, sex_age_five_year_whitealone_recode.csv, sex_age_five_year_blackalone_recode.csv, sex_age_five_year_aianalone_recode.csv, sex_age_five_year_asianalone_recode.csv, sex_age_five_year_nhopialone_recode.csv, sex_age_five_year_soralone_recode.csv, sex_age_five_year_twoormore_recode.csv, sex_age_five_year_hisp_recode.csv, sex_age_five_year_whitealone_nothisp_recode.csv)

#### Remove sex_age recodes ####
rm(list=ls(pattern="^sex_"))

#### Create an SF1, v1, and v2 df with just age/sex/race variable ####
sf <- v2 %>%
  select(gisjoin, H76001_sf:H76049_sf, H9A001_sf:H9I049_sf)

v2 <- v2 %>%
  select(gisjoin, H76001_dp:H76049_dp, H9A001_dp:H9I049_dp)

v1a <- v1a %>%
  select(gisjoin, H76001_dp:H76049_dp)

#### Create long dfs for sf, v2, and v1s ####
# pivot longer, separate var into multiple parts and add a version value
long_sf <- sf %>%
  pivot_longer(H76001_sf:H9I049_sf, names_to = "var", values_to = "n") %>%
  separate(var, into = c("var_code", "version"), sep = "_")

long_v2 <- v2 %>%
  pivot_longer(H76001_dp:H9I049_dp, names_to = "var", values_to = "n") %>%
  separate(var, into = c("var_code", "version"), sep = "_") %>%
  mutate(version = "v2")

long_v1a <- v1a %>%
  pivot_longer(H76001_dp:H76049_dp, names_to = "var", values_to = "n") %>%
  separate(var, into = c("var_code", "version"), sep = "_") %>%
  mutate(version = "v1")

# v1b doesn't require separation because it doesn't have _dp on end of var names
long_v1b <- v1b %>%
  pivot_longer(H9A001:H9I049, names_to = "var", values_to = "n") %>%
  mutate(version = "v1")

#### Row bind v1a_long and v1b_long into single df ####
long_v1 <- bind_rows(long_v1a, long_v1b)

#### Row bind all sex by age by race counts into single df ####
df <- bind_rows(long_sf, long_v1)
df <- bind_rows(df, long_v2)

#### Remove unneeded dfs ####
rm(list = ls(pattern = "^v"))
rm(list = ls(pattern = "^long"))
rm(x)
rm(sf)

#### Join recodes to df ####
df <- left_join(df, recode, by = c("var_code" = "var")) %>%
  select(-var)

#### Apply factors to age_grp, sex, race, and version ####
df$sex <- factor(df$sex, levels = sex_levels, labels = sex_labels)
df$race <- factor(df$race, levels = race_levels, labels = race_labels)
df$age_grp <- factor(df$age_grp, levels = age_grp_levels, labels = age_grp_labels)
df$version <- factor(df$version, levels = version_levels, labels = version_labels)

#### Create final sex/age/race df ####
# group by county, version, age_grp, sex, race
# drop NA values before creating the final df
df_sar <- df %>%
  filter(!is.na(age_grp)) %>%
  group_by(gisjoin, version, age_grp, sex, race) %>%
  summarise(n = sum(n))


sizeof ('c') : 4
sizeof (10 * 'c') : 4
sizeof (100 + 12345) : 4
sizeof (1234567890) : 4
sizeof (1234512345 * 1234512345 * 12345678 * 1ULL) : 8
sizeof (-129) : 4
sizeof ({ptr}/{ptr}) : 4
sizeof (3 > 2 ? 3 : 2) : 4


##' Fit a dynamic model to the measles outbreak in Katanga
##'
##' Uses the LibBi interface provided by the rbi package
##' @param model a 'bi_model'
##' @param year the year to which to fit
##' @param end how many weeks to retain after the last data point
##' @param start_threshold when this number is exceeded over a two-week period,
##'     start fitting
##' @param vaccine_delay delay in vaccine protection; default: 0 (instantaneous protection)
##' @param nbdata number of data points to require; if fewer data points are
##'     available in a health zone, the health zone will be discarded
##' @param particles number of particles, if given; otherwise will be determined
##'     from the variance of the log-likelihood estimate
##' @param under_5_multiplier multiplier for population size to get under-5
##'     population size; default: 0.169
##' @return libbi object containing the posterior samples
##' @author Sebastian Funk
##' @importFrom dplyr %>% filter between group_by summarise ungroup n left_join
##' @importFrom tidyr replace_na
##' @importFrom lubridate wday
##' @importFrom rbi libbi sample sample_obs fix
##' @importFrom rbi.helpers adapt_proposal adapt_particles
##' @importFrom gpuR detectGPUs listContexts gpuInfo
##' @export
fit_dynamic_model <- function(model, year=2015, end=5, start_threshold=10, vaccine_delay=0, nbdata, particles, under_5_multiplier=.169)
{

    range <- as.Date(paste(year, c("01-01", "12-31"), sep="-"))

    ## filter cases to lie within given range
    cases_age_range <- katanga_measles_cases %>%
        filter(between(week_start, range[1], range[2]))

    ## get cases from relevant age group
    cases_range_health_zone <- cases_age_range %>%
        dplyr::filter(age == "1-4")

    ## create data table of times, with debutsem, week and biweek
    weeks <- expand.grid(week_start=seq(min(cases_range_health_zone$week_start),
                                        max(cases_range_health_zone$week_start),
                                        "1 week"),
                         health_zone=unique(cases_range_health_zone$health_zone),
                         stringsAsFactors = FALSE) %>%
        mutate(week=as.integer(week_start-min(week_start))/7+1,
               time=as.integer((week + 1) %/% 2))

    cases_range_health_zone %<>%
        left_join(weeks, by=c("health_zone", "week_start")) %>%
        group_by(time, health_zone) %>%
        summarise(week_start=min(week_start), cases=sum(cases), n=n()) %>%
        ungroup

    timestep_length <- 14

    ## retain health zones with any week with cases above start threshold
    cases_range_health_zone %<>%
        mutate(more_than_threshold=cases > start_threshold) %>%
        group_by(health_zone) %>%
        dplyr::filter(any(more_than_threshold)) %>%
        ungroup

    ## function to find consecutive TRUEs
    consecutive <- function(data) {
        lengths <- rle(data)$lengths
        return(data*unlist(lapply(lengths, function(x) rep(x, x))))
    }

    ## get the first time of the longest series of consecutive cases above the
    ## stating threshold, in each health zone
    min_times <- cases_range_health_zone %>%
        group_by(health_zone) %>%
        mutate(consec_above_threshold=consecutive(more_than_threshold)) %>%
        dplyr::filter(consec_above_threshold==max(consec_above_threshold)) %>%
        summarise(min_time=min(time),
                  consec_above_threshold=unique(consec_above_threshold))

    ## only retain times at or later than the minimum time found in the last
    ## command and with at least 2 data points above the threshold in a row
    cases_range_health_zone %<>%
        left_join(min_times, by="health_zone") %>%
        filter(time >= min_time, consec_above_threshold > 1) %>%
        select(time, value=cases, health_zone=health_zone)

    if (length(nb_data) > 0) {
        cases_range_health_zone %>%
            group_by(health_zone) %>%
            summarise(n=n()) %>%
            dplyr::filter(n >= nb_data) %>%
            .$health_zone -> threshold_health_zone
        cases_range_health_zone %<>%
            dplyr::filter(health_zone %in% threshold_health_zone)
    }

    ## update timings
    weeks %<>%
        left_join(min_times, by="health_zone") %>%
        dplyr::filter(time >= min_time)

    threshold_health_zone <- unique(weeks$health_zone)

    ## get mass vaccination campaigns in year(s) of given range, clean dates, set
    ## debutsem to Monday of week
    mvc_range <- katanga_2015_mvc %>%
        filter(year %in% year(range)) %>%
        mutate(week_start=date-(wday(date)-2) %% 7)

    ## filter MVCs to those in a health zone above the threshold, filter to
    ## campaigns less than a year long
    mvc_range %<>%
        filter(health_zone %in% threshold_health_zone) %>%
        filter(max_date-min_date<364) %>%
        filter(min_age < 5) %>%
        replace_na(list(vaccinated=0)) %>%
        mutate(vaccinated=case_when(
                   .$max_age == 10 ~ round(vaccinated * under_5_multiplier / .33),
                   .$max_age == 15 ~ round(vaccinated * under_5_multiplier / .46),
                   TRUE ~ vaccinated))

    ## fill campaign dates for those without daily data
    if (any(is.na(mvc_range$week_start))) {
        vacc <-
            apply(mvc_range %>% dplyr::filter(is.na(week_start)), 1, function(x) {
            population <- as.numeric(x[["population"]])
            targetpop <- as.numeric(x[["targetpop"]])
            year <- as.integer(x[["year"]])
            survey_coverage <- as.numeric(x[["survey_coverage"]])
            min_date <- as.Date(x[["min_date"]])
            max_date <- as.Date(x[["max_date"]])
            min_age <- as.numeric(x[["min_age"]])
            max_age <- as.numeric(x[["max_age"]])
            min_sem <- min_date - (wday(min_date) - 2) %% 7
            max_sem <- max_date - (wday(max_date) - 2) %% 7
            weeks <- seq(min_sem, max_sem, "1 week")
            days_within_weeks <- vapply(weeks, function(y) {
                min_time_diff <- min(as.integer(y - min_date), 0)
                max_time_diff <- min(as.integer(max_date - (y + 6)), 0)
                return(as.integer(7 + min_time_diff + max_time_diff))
            }, as.integer(0))
            ret <-
                data.frame(province=x[["province"]],
                           health_zone=x[["health_zone"]],
                           health_area=x[["health_area"]],
                           village=x[["village"]],
                           population=population,
                           targetpop=targetpop,
                           year=year,
                           doses=x[["doses"]],
                           vaccinated=round(as.integer(x[["vaccinated"]]) *
                                            days_within_weeks /
                                            sum(days_within_weeks)),
                           survey_coverage=survey_coverage,
                           min_date=min_date,
                           max_date=max_date,
                           min_age=min_age,
                           max_age=max_age,
                           week_start=weeks,
                           stringsAsFactors=FALSE)
            return(ret)
        })
        mvc_range %<>% bind_rows(vacc)
    }

    ## clean MVC data
    mvc_range %<>%
        filter(!is.na(week_start)) %>% ## these have just been fixed
        left_join(weeks, by=c("health_zone", "week_start")) %>%
        filter(!is.na(time)) %>%
        select(-week_start, -time) %>%
        left_join(weeks %>% select(week_start, health_zone, time, week),
                  by=c("health_zone", "week")) %>%
        mutate(time=time+1) %>%
        group_by(date, min_date, max_date, time, health_zone) %>%
        summarise(vaccinated=sum(vaccinated),
                  week_start=min(week_start),
                  min_age=min(min_age),
                  max_age=max(max_age)) %>%
        ungroup

    ## expand ranges to daily vaccinees
    if (any(is.na(mvc_range$date))) {
        daily_vacc <-
            apply(mvc_range %>% dplyr::filter(is.na(date)), 1, function(x) {
            week_start <- as.Date(x[["week_start"]])
            min_date <- max(as.Date(x[["min_date"]]), week_start)
            max_date <- min(as.Date(x[["max_date"]]), week_start+timestep_length-1)
            min_age <- as.numeric(x[["min_age"]])
            max_age <- as.numeric(x[["max_age"]])
            vaccinated <- as.integer(x[["vaccinated"]])
            dates <- seq(min_date, max_date, by="1 day")
            ret <-
                data.frame(date=dates,
                           week_start=week_start,
                           vaccinated=round(vaccinated / length(dates)),
                           min_date=min_date,
                           max_date=max_date,
                           min_age=min_age,
                           max_age=max_age,
                           time=as.integer(x[["time"]]),
                           health_zone=x[["health_zone"]],
                           stringsAsFactors = FALSE)
            return(ret)
            })
        mvc_range %<>% bind_rows(daily_vacc) %>%
            dplyr::filter(!is.na(date))
    }

    ## estimated number of vaccinees before/after exposure (assuming uniform
    ## exposure within each time interval)
    mvc_range %<>%
        mutate(days_after=as.integer(week_start+timestep_length-1-date),
               timing_factor=days_after/timestep_length,
               pre_exposure=round(timing_factor*vaccinated),
               post_exposure=vaccinated-pre_exposure) %>%
        group_by(health_zone, time) %>%
        summarise(pre_exposure=sum(pre_exposure),
                  post_exposure=sum(post_exposure),
                  min_date=min(min_date),
                  max_date=max(max_date),
                  min_age=min(min_age),
                  max_age=max(max_age),
                  week_start=min(week_start)) %>%
        ungroup

    ## require three data points after and three before campaign
    mvc_range %>%
        dplyr::filter(max_date < as.Date("2016-01-01")-3*timestep_length) %>%
        group_by(health_zone) %>%
        summarise(min_mvc=min(time)) %>%
        left_join(min_times, by="health_zone") %>%
        dplyr::filter(min_mvc-min_time >= 3) %>%
        .$health_zone -> threshold_health_zone

    cases_range_sum_health_zone <- cases_range_health_zone %>%
        dplyr::filter(health_zone %in% threshold_health_zone) %>%
        group_by(health_zone) %>%
        summarise(cases=sum(value)) %>%
        ungroup %>%
        arrange(-cases)

    threshold_health_zone <- cases_range_sum_health_zone$health_zone

    message("Fitting ", paste(threshold_health_zone, collapse=", "))

    cases_range_health_zone %<>%
        dplyr::filter(health_zone %in% threshold_health_zone) %>%
        mutate(health_zone=factor(health_zone),
               time=time+1) %>% ## observations are at the end of a (bi-)week
        arrange(time, health_zone)

    weeks %<>%
        dplyr::filter(health_zone %in% threshold_health_zone) %>%
        mutate(health_zone=factor(health_zone))

    mvc_range %<>%
        dplyr::filter(health_zone %in% threshold_health_zone) %>%
        mutate(health_zone=factor(health_zone))

    input_pre_mvc <- mvc_range %>%
        dplyr::select(time, value=pre_exposure, health_zone) %>%
        dplyr::filter(health_zone %in% threshold_health_zone) %>%
        arrange(health_zone) %>%
        mutate(health_zone=
                   factor(health_zone, levels(cases_range_health_zone$health_zone))) %>%
        group_by(health_zone) %>%
        do(rbind(., tail(., n=1) %>% mutate(time=time+1, value=0))) %>%
        arrange(time, health_zone)

    input_post_mvc <- mvc_range %>%
        dplyr::select(time, value=post_exposure, health_zone) %>%
        dplyr::filter(health_zone %in% threshold_health_zone) %>%
        mutate(health_zone=factor(health_zone,
                                  levels(cases_range_health_zone$health_zone))) %>%
        group_by(health_zone) %>%
        do(rbind(., tail(., n=1) %>% mutate(time=time+1, value=0))) %>%
        arrange(time, health_zone)

    N <- populations %>%
        dplyr::filter(health_zone %in% threshold_health_zone) %>%
        mutate(value=round(l5pop)) %>%
        dplyr::select(health_zone, value) %>%
        mutate(health_zone=
                   factor(health_zone,
                          levels=levels(cases_range_health_zone$health_zone)))

    min_times %<>%
        dplyr::filter(health_zone %in% threshold_health_zone) %>%
        mutate(value=min_time) %>%
        dplyr::select(health_zone, value)

    mvc_times_health_zone <-
        expand.grid(time=unique(input_pre_mvc$time),
                    health_zone=unique(cases_range_health_zone$health_zone)) %>%
        arrange(time, health_zone)

    input_pre_mvc %<>%
        right_join(mvc_times_health_zone, by=c("time", "health_zone")) %>%
        replace_na(list(value=0)) %>%
        mutate(time=time+vaccine_delay)

    input_post_mvc %<>%
        right_join(mvc_times_health_zone, by=c("time", "health_zone")) %>%
        replace_na(list(value=0)) %>%
        mutate(time=time+vaccine_delay)

    total_coverage <- katanga_mcv_admin %>%
        dplyr::filter(health_zone %in% threshold_health_zone) %>%
        dplyr::filter(year<2015) %>%
        group_by(health_zone) %>%
        summarise(target=sum(target), doses=sum(doses)) %>%
        mutate(coverage=doses/target)

    est_vacc <- dhs_coverage_estimates %>%
        dplyr::filter(health_zone %in% threshold_health_zone) %>%
        mutate(zs_zone=factor(health_zone)) %>%
        select(health_zone, value=coverage_estimate)

    min_dates <- weeks %>%
        group_by(health_zone) %>%
        summarise(min_date=min(week_start)-min(time)*7*(1+!ode))

    model %<>%
        fix(n_health_zone=length(threshold_health_zone))

    input <- list(pre_mvc=input_pre_mvc, post_mvc=input_post_mvc,
                  N=N, est_vacc=est_vacc,
                  start_data=min_times)

    message(base::date(), " starting.")

    libbi_options <- list(model, nsamples=8192,
                          assert=opts[["debug"]], single=TRUE,
                          input=input,
                          obs=list(Incidence=cases_range_health_zone),
                          end_time=max(cases_range_health_zone$time),
                          noutputs=max(cases_range_health_zone$time),
                          verbose=opts[["verbose"]])

    ngpu <- detectGPUs()
    if (ngpu > 0) {
        context <- listContexts() %>%
            dplyr::filter(device_type=="gpu") %>% .$context %>% min
        gpu <- gpuInfo(context_idx=context)
        if (grepl("NVIDIA", gpu$deviceVendor)) {
            libbi_options <-
                c(libbi_options,
                  list(cuda=TRUE, gpu_cache=TRUE, nthreads=12,
                       cuda_fast_math=TRUE,
                       openmp=FALSE))
        }
    }

    bi <- do.call(libbi, libbi_options)

    if (missing(particles))
    {
        if (deterministic) {
            min_particles <- 1
        } else {
            min_particles <- max(ceiling(log2(nrow(cases_range_health_zone))), 256)
        }
        bi$options$nparticles <- min_particles
    } else {
        bi$options$nparticles <- particles
    }

    message(base::date(), " test run")
    bi %<>% sample(proposal="prior")

    if (missing(particles))
    {
        bi %<>% adapt_proposal(min=0.1, max=0.4, adapt="size")
        bi %<>% adapt_particles(max=2**20)
    }

    bi %<>% adapt_proposal(min=0.1, max=0.3, adapt="size")

    if (missing(particles)) {
        nparticles <- bi$options$nparticles
        bi %<>% adapt_particles(max=2**20)
        adapt_proposal(min=0.1, max=0.3, adapt="size")
    }

    bi <- sample(bi, nsamples=262144, thin=64)
    bi_obs <- sample_obs(bi)

    bi_obs$supplement <-
        list(min_date=min(weeks$debutsem)- min(weeks$time)*14,
             mvc=mvc_range, timestep=paste("2 week"),
             vaccine_delay=vaccine_delay)

    return(bi_obs)
}


library(flume)
library(RColorBrewer)
library(ggplot2)
load("flume_examples/ex1/data/ex1_data.rda")
mainstem = c(1:4)
left_trib = 5:24
right_trib = 25:52
cols = brewer.pal(3, "Dark2") ## hue_pal()(3)
nnode = length(net)

## make some nice colors for the network plot
alpha = rep("77", nnode)
alpha[sp_nodes] = "ff"

hue = rep(cols[1], nnode)
hue[left_trib] = cols[2]
hue[right_trib] = cols[3]

vcol = paste0(hue, alpha)

pdf("figures/fig_kamp.pdf", w = 5, h = 5)
par(mar = c(0,0,0,0))
plot(net, vertex.size = 10, vertex.color = vcol)
dev.off()


#' refmat class
#'
#' Storage and methods for CPU matrix data.
#'
#' @details
#' Data is held in an external pointer.
#'
#' @rdname refmat-class
#' @name refmat-class
refmatR6 = R6::R6Class("refmat",
  public = list(
    #' @details
    #' Class initializer. See also \code{?mat}.
    #' @param nrows,ncols The dimension of the matrix.
    #' @param type Storage type for the matrix. Should be one of 'int' or 'double'.
    initialize = function(nrows=0, ncols=0, type="double")
    {
      type = match.arg(tolower(type), TYPES_STR)

      nrows = check_is_natnum(nrows)
      ncols = check_is_natnum(ncols)

      private$type_str = type
      private$type = type_str2int(type)

      private$x = numeric(nrows*ncols)
      dim(private$x) = c(nrows, ncols)
    },

    #' @details
    #' Change the dimension of the matrix object.
    #' @param nrows,ncols The new dimension.
    resize = function(nrows, ncols)
    {
      nrows = check_is_natnum(nrows)
      ncols = check_is_natnum(ncols)

      private$x = numeric(nrows*ncols)
      dim(private$x) = c(nrows, ncols)
      invisible(self)
    },

    #' @details
    #' Set the data in the refmat object to point to the array in 'data'. See
    #' also \code{?as_refmat}.
    #' @param data R matrix.
    inherit = function(data)
    {
      if (!is.double(data))
        storage.mode(data) = "double"

      private$x = data
      invisible(self)
    },

    #' @details
    #' Duplicate the matrix in a deep copy.
    dupe = function()
    {
      self$clone(deep=TRUE)
    },

    #' @details
    #' Print one-line information about the matrix.
    info = function()
    {
      cat("# refmat")
      cat(sprintf(" %dx%d", nrow(private$x), ncol(private$x)))
      cat(" type=d")
      cat("\n")
      invisible(self)
    },

    #' @details
    #' Print the data.
    #' @param ndigits Number of decimal digits to print.
    print = function(ndigits=4)
    {
      print(private$x, digits=ndigits)
      invisible(self)
    },

    #' @details
    #' Fill all entries with zero.
    fill_zero = function()
    {
      private$x[] = 0
      invisible(self)
    },

    #' @details
    #' Fill all entries with supplied value.
    #' @param v Value to set all entries to.
    fill_val = function(v)
    {
      private$x[] = v
      invisible(self)
    },

    #' @details
    #' Fill the matrix (column-wise) with linearly-spaced values.
    #' @param start,stop Beginning/end of the linear spacing.
    fill_linspace = function(start, stop)
    {
      private$x[] = seq(from=start, to=stop, length.out=nrow(private$x)*ncol(private$x))
      invisible(self)
    },

    #' @details
    #' Fill diagonal values to 1 and non-diagonal values to 0.
    fill_eye = function()
    {
      private$x = diag(1, nrow(private$x), ncol(private$x))
      invisible(self)
    },

    #' @details
    #' Set diagonal entries of the matrix to those in the vector. If the vector
    #' is smaller than the matrix diagonal, the vector will recycle until the
    #' matrix diagonal is filled.
    #' @param v A refvec object.
    fill_diag = function(v)
    {
      if (!is_refvec(v))
        v = as_refvec(v)

      check_type_consistency(self, v)

      private$x = diag(v$data_ptr())
      invisible(self)
    },

    #' @details
    #' Fill the matrix with random unifmorm data.
    #' @param seed Seed for the generator. Can be left blank.
    #' @param min,max Parameters for the generator.
    fill_runif = function(seed, min=0, max=1)
    {
      if (!missing(seed))
        set.seed(seed)

      private$x[] = runif(min=min, max=max)
      invisible(self)
    },

    #' @details
    #' Fill the matrix with random normal data.
    #' @param seed Seed for the generator. Can be left blank.
    #' @param mean,sd Parameters for the generator.
    fill_rnorm = function(seed, mean=0, sd=1)
    {
      if (!missing(seed))
        set.seed(seed)

      private$x[] = rnorm(mean=mean, sd=sd)
      invisible(self)
    },

    #' @details
    #' Fill diagonal values to 1 and non-diagonal values to 0.
    diag = function()
    {
      ret = refvec()
      ret$set(diag(private$x))
      ret
    },

    #' @details
    #' Fill diagonal values to 1 and non-diagonal values to 0.
    antidiag = function()
    {
      m = nrow(private$x)
      n = ncol(private$x)
      minmn = min(m, n)
      v = numeric(minmn)
      for (i in 1:minmn)
        v[i] = private$x[m-i+1, i]

      ret = refvec()
      ret$inherit(v)
      ret
    },

    #' @details
    #' Scale all entries by the supplied value.
    #' @param s Value to scale all entries by.
    scale = function(s)
    {
      private$x = private$x * s
      invisible(self)
    },

    #' @details
    #' Reverse rows.
    rev_rows = function()
    {
      private$x = private$x[nrow(private$x):1, ]
      invisible(self)
    },

    #' @details
    #' Reverse columns.
    rev_cols = function()
    {
      private$x = private$x[, ncol(private$x):1]
      invisible(self)
    },

    #' @details
    #' Get element from the matrix.
    #' @param i,j Indices (0-based).
    get = function(i, j)
    {
      i = check_is_natnum(i)
      j = check_is_natnum(j)

      private$x[i+1, j+1]
    },

    #' @details
    #' Set element of the matrix.
    #' @param i,j Indices (0-based).
    #' @param v Value.
    set = function(i, j, v)
    {
      i = check_is_natnum(i)
      j = check_is_natnum(j)
      v = check_is_number(v)

      private$x[i+1, j+1] = v
      invisible(self)
    },

    #' @details
    #' Get the specified row.
    #' @param i Index (0-based).
    #' @param v A refvec object.
    get_row = function(i, v)
    {
      if (!is_refvec(v))
        stop("'v' must be a refvec object")

      check_type_consistency(self, v)

      i = check_is_natnum(i)
      v$inherit(private$x[i+1, ])
      invisible(self)
    },

    #' @details
    #' Get the specified column.
    #' @param j Index (0-based).
    #' @param v A refvec object.
    get_col = function(j, v)
    {
      if (!is_refvec(v))
        stop("'v' must be a refvec object")

      check_type_consistency(self, v)

      j = check_is_natnum(j)

      v$inherit(private$x[, j+1])
      invisible(self)
    },

    #' @details
    #' Returns number of rows and columns of the matrix.
    dim = function() dim(private$x),

    #' @details
    #' Returns number of rows of the matrix.
    nrows = function() nrow(private$x),

    #' @details
    #' Returns number of columns of the matrix.
    ncols = function() ncol(private$x),

    #' @details
    #' Returns the external pointer data. For developers only.
    data_ptr = function() private$x,

    #' @details
    #' Returns the integer code for the underlying storage type. For developers only.
    get_type = function() private$type,

    #' @details
    #' Returns the string code for the underlying storage type. For developers only.
    get_type_str = function() private$type_str,

    #' @details
    #' Returns an R vector containing a copy of the class data.
    to_robj = function() private$x,

    #' @details
    #' Copies the values of the input to the class data. See also \code{?as_cpumat}.
    #' @param robj R matrix.
    from_robj = function(robj)
    {
      private$x = robj
      invisible(self)
    }
  ),

  private = list(
    x = NULL,
    type = -1L,
    type_str = ""
  )
)

#' refmat
#'
#' Constructor for refmat objects.
#'
#' @details
#' Data is held in an external pointer.
#'
#' @param nrows,ncols The dimensions of the matrix.
#' @param type Storage type for the matrix. Should be one of 'int' or 'double'.
#' @return A refmat class object.
#'
#' @seealso \code{\link{mat-class}}
#'
#' @export
refmat = function(nrows=0, ncols=0, type="double")
{
  refmatR6$new(nrows=nrows, ncols=ncols, type=type)
}

#' as_refmat
#'
#' Convert an R matrix to a refmat object.
#'
#' @param x R matrix.
#' @param copy Should the R data be copied? If \code{FALSE}, be careful!
#' @return A refmat object.
#'
#' @export
as_refmat = function(x)
{
  ret = refmat()
  ret$from_robj(x)
  ret
}


setwd('/mnt/workspace/DCRI/Data')
library(dplyr)

aimhigh=read.csv('aimhigh.csv')
bari=read.csv('bari2d.csv')
allhat=read.csv('allhat.csv')
accord=read.csv('accord.csv')

colnames(aimhigh)
nrow(aimhigh)
table(aimhigh$study.1)

colnames(accord)
nrow(accord)
table(accord$study.1)

colnames(allhat)
nrow(allhat)
table(allhat$study.1)

colnames(bari)
nrow(bari)
table(bari$study.1)

head(aimhigh)

dat=rbind(aimhigh, allhat) %>% rbind(accord) %>% rbind(bari)
#head(dat)
#table(dat$study.1, useNA="ifany")
#table(dat$antihyp)
#nrow(dat)
#summary(dat$BP.s)
#table(dat$dthStat, dat$study.1, useNA="ifany")

#missing=subset(dat, person_id==NA)
#nrow(missing)

hyp=subset(dat, BP.s>=130 | BP.d>=80 | Htn==1 | antihyp==1)

hyp$type_hyp=ifelse(hyp$BP.s>=130 & hyp$BP.d<80, 'Systolic',
    ifelse(hyp$BP.s<130 & hyp$BP.d>=80,'Diastiolic',
           ifelse(hyp$BP.s>=130 & hyp$BP.d>=80,'Both','Controlled')))
#table(hyp$Htn, hyp$study.1, useNA="ifany")
hyp$Htn=ifelse(is.na(hyp$Htn) & hyp$study.1=='ACCORD', 0, hyp$Htn)
#table(hyp$Htn, hyp$study.1, useNA="ifany")

hyp$dthStat=ifelse(is.na(hyp$dthStat) & hyp$study.1=='AIMHIGH', 0, hyp$dthStat)
hyp$dthStat=ifelse(hyp$study.1=='ACCORD', 1-hyp$dthStat, hyp$dthStat)
#https://stackoverflow.com/questions/23479512/stratified-random-sampling-from-data-frame

hyp %>%
    select(study.1, BP.s, BP.d, dthDays) %>%
    group_by(study.1) %>%
    summarise(days_mean = mean(dthDays, na.rm=T), days_median = median(dthDays, na.rm=T), min_days=min(dthDays, na.rm=T), max_days=max(dthDays, na.rm=T))

#1825 max days - censor for 5 year death
hyp$death = ifelse(hyp$dthDays>1825, 0, hyp$dthStat)
hyp$tdeath = ifelse(hyp$dthDays>1825, 1825, hyp$dthDays)
hyp$tdeath = ifelse(hyp$dthDays==0, 0.1, hyp$dthDays)
hyp %>%
    select(study.1, BP.s, BP.d, tdeath) %>%
    group_by(study.1) %>%
    summarise(days_mean = mean(tdeath, na.rm=T), days_median = median(tdeath, na.rm=T), min_days=min(tdeath, na.rm=T), max_days=max(tdeath, na.rm=T))

set.seed(150)
train <- hyp %>%
    select(study.1, person_id) %>%
    group_by(study.1) %>%
    sample_frac(0.75)

test <- hyp %>%
    select(study.1, person_id) %>%
   filter(!person_id %in% train$person_id)

train$train=1
test$test=1

head(train)
head(test)
nrow(train)
nrow(test)

head(hyp)
final = hyp %>% left_join(train, by=c("person_id",'study.1')) %>% left_join(test, by=c("person_id",'study.1'))
head(final)

table(hyp$study.1)
table(hyp$antihyp)
table(hyp$type_hyp)
colnames(hyp)

write.csv(hyp, 'analysis_ds.csv', row.names=FALSE)

anly=read.csv('analysis_ds.csv')

table(anly$study.1)
nrow(anly)

sub=anly[anly$study.1=='',]

nrow(sub)
head(sub)


# main.r
#
# MIT License
#
# Copyright (c) 2021 Oliver Wissett
#
# Permission is hereby granted, free of charge, to any person obtaining a copy
# of this software and associated documentation files (the "Software"), to deal
# in the Software without restriction, including without limitation the rights
# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
# copies of the Software, and to permit persons to whom the Software is
# furnished to do so, subject to the following conditions:
#
#   The above copyright notice and this permission notice shall be included in all
# copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
# SOFTWARE.

library(ggplot2)  # Provides graphing functions
library(dplyr)    # Adds piping and data manipulation functions
library(readr)    # Allows for easy handling of CSV inputs
library(reshape2) # Adds the melt function to do some data wrangling.
library(stringr)  # Adds some nice regex stuff
library(ggthemes) # Adds nice looking ggplot themes
library(tidyr)
library(viridis)

# Load dataset
DSF_DATAPATH = '../../datasets/Tripeptides_DSF.csv'

dsf_df <- readr::read_csv(DSF_DATAPATH)

assign_peptide <- function(rowID) {
  if (rowID == 'A')
    return('None')

  if (rowID == 'B')
    return('KAK')

  if (rowID == 'C')
    return('KFK')

  if (rowID == 'D')
    return('KTK')

  if (rowID == 'E')
    return('KGK')
}

assign_condition <- function(colID) {
  if(colID < 4) {
    return('HisZ')
  } else {
    return('Control')
  }
}

calculate_gradient <- function(x, y) {
  return(diff(y)/diff(x))
}

dsf_tibble <- dsf_df %>%
  select(c(1, seq(2, ncol(.), by = 2))) %>%
  tibble() %>%
  rename(temperature = 1) %>%
  slice(-1) %>%
  melt(id.vars = 'temperature',
       value.name = 'fluorescence',
       variable.name = 'cellID') %>%
  mutate(rowID = substr(cellID,1,1),
         colID = as.numeric(str_extract(cellID, '(?<=^[A-Z])[0-9]*'))) %>%
  mutate(peptide = sapply(rowID, assign_peptide),
         condition = sapply(colID, assign_condition),
         fluorescence = as.numeric(fluorescence),
         temperature = as.numeric(temperature)) %>%
  mutate(peptide = factor(peptide, levels = c('None', 'KAK', 'KTK','KGK', 'KFK')),
         condition = factor(condition, levels = c('HisZ', 'Control'))) %>%
  dplyr::filter(colID < 7 & rowID != 'F' & rowID != 'G' & rowID != 'H')

dsf_norm <- dsf_tibble %>%
  drop_na() %>%
  group_by(peptide, condition, cellID) %>%
  summarise(count = n(),
            fluorescence.norm = (fluorescence - min(fluorescence))/ (max(fluorescence) - min(fluorescence)),
            temperature = temperature)

dsf_summary <- dsf_norm %>%
  group_by(peptide, condition, temperature) %>%
  summarise(count = n(),
            fluorescence.mean = mean(fluorescence.norm),
            fluorescence.se = sd(fluorescence.norm) / sqrt(n()),
            temperature = temperature) %>%
  mutate(fluorescence.lower = fluorescence.mean - fluorescence.se,
         fluorescence.upper = fluorescence.mean + fluorescence.se)

# Plotting time...

ggplot(dsf_norm %>% filter(condition == 'HisZ'),
       aes(temperature, fluorescence.norm,
                       colour = peptide,
                       shape = condition)) +
  geom_point() +
  theme_classic()

dsf_traces <- ggplot(dsf_summary %>% filter(condition == 'HisZ'),
                     aes(temperature, fluorescence.mean,
                        colour = peptide)) +
  geom_point(size = 2) +
  theme_hc() +
  labs(y = 'Relative Fluorescence',
       x = 'Temperature (°C)',
       colour = 'Peptide') +
  theme(
    axis.title = element_text(face="bold", size = 18),
    axis.text = element_text(face="bold", size = 12),
    panel.background = element_rect(fill = 'white'),
    axis.line = element_line(colour = 'black')
  ) +
  scale_color_brewer(palette = 'Set1')

dsf_traces

ggplot(dsf_summary %>% filter(condition == 'HisZ'),
       aes(temperature, gradient, color = peptide)) +
  geom_point()


#' Idle
#'
#' Measuring idle cycles.
#'
#' This function measures the evaluation of the provided expression, expr, for
#' the number of cycles that specific specialized processing units are idle.
#' The additional arguments, gcFirst and burnin, can be toggled to better
#' simulate the target context.
#'
#' @param expr
#' A valid R expression to be profiled.
#' @param events
#' The class of processing unit to profile; options are "float",
#' "int", "numeric", "branch", "load", and "all".
#' @param gcFirst
#' logical; determines if garbage collection should be called
#' before profiling.
#' @param burnin
#' logical; determines if the function should first be evaluated
#' with an empty expression.
#'
#' @return
#' The results of the requested PAPI events are returned, in a named
#' list, with values stored in double precision.
#'
#' @keywords programming
#'
#' @examples
#' \dontrun{
#' library(pbdPAPI)
#'
#' system.idle(1+1, events="float")
#' }
#'
#' @export
system.idle <- function(expr, events="float", gcFirst=TRUE, burnin=TRUE)
{
  events <- match.arg(tolower(events), c("float", "int", "numeric", "branch", "load", "all"))

  if (missing(expr))
    expr <- NULL

  shorthand <- events

  if (events == "float")
    events <- "PAPI_FPU_IDL"
  else if (events == "int")
    events <- "PAPI_FXU_IDL"
  else if (events == "numeric")
    events <- c("PAPI_FPU_IDL", "PAPI_FXU_IDL")
  else if (events == "branch")
    events <- "PAPI_BRU_IDL"
  else if (events == "load")
    events <- "PAPI_LSU_IDL"
  else if (events == "all")
    events <- c("PAPI_FPU_IDL", "PAPI_FXU_IDL", "PAPI_BRU_IDL", "PAPI_LSU_IDL")

  papi.avail.lookup(events=events, shorthand=shorthand)

  ret <- system.event(expr=expr, events=events, gcFirst=gcFirst, burnin=burnin)

  return( ret )
}


load_install_packages <- function(list.of.packages) {
    new.packages <- list.of.packages[!(list.of.packages %in% installed.packages()[,"Package"])]
    if(length(new.packages)) install.packages(new.packages,repos="http://cran.cnr.Berkeley.edu/")
    for (i in list.of.packages) {
        library(i,character.only=T)
    }
}

load_install_packages(c("knockoff", "argparse", "rjson", "ranger", "doMC"))

init_arg <- function() {
    parser <- ArgumentParser(description='knockoff gan')
    parser$add_argument('--it', type="integer", default=2000, help="number of GAN iterations")
    parser$add_argument('--target', type="character", help="column name with target/response values")
    parser$add_argument('-i', type="character", help="input data in csv format")
    parser$add_argument('-o', type="character", help="json output file name")
    parser$add_argument('--fdr', type="double", default=0.1)
    parser$add_argument('--usegan', type="integer", default=1)
    parser$add_argument('--scale', type="integer", default=1)
    parser$add_argument('--verbose', type="integer", default=1)
    parser$add_argument('--exe', type="character", default="python3", help="name of python interpreter, typically python3 or python" )
    parser$add_argument('--projdir', type="character")
    parser$add_argument(
        '--replication',
        type="integer",
        default=20,
        help="number of evaluations over which the results are collected")
    parser$add_argument('--stat', type="character", default='rf', help="Importance statistics based on .. random forest (rf), glmnet_coefdiff (glm)")
    return (parser)
}

get_selected_features <- function(selected_lst, max_it) {
    selected_a <- matrix(0, nrow = 1, ncol=dim(X)[2])
    for (i in 1:length(selected_lst)) {
        if (use_verbose) {
            print(sprintf("%d) %s", i, paste(selected_lst[[i]], collapse=" ")))
        }
        selected_a[1, selected_lst[[i]]] <- selected_a[1,selected_lst[[i]]] + 1
    }
    if (use_verbose) {
        print("")
    }
    return (which(selected_a[1,] > (max_it/2)))
}

args <- init_arg()$parse_args()
python_exe <- args$exe
niter <- args$it
fn_src <- args$i
lbl <- args$target
fdr_threshold <- args$fdr
use_gan <- args$usegan
use_scale <- args$scale
use_verbose <- args$verbose
num_iterations <- args$replication
stat_type <- args$stat
fn_json <- args$o
proj_dir <- args$projdir

df = read.csv(fn_src)

stopifnot(is.element(lbl, names(df)))

features = names(df)

features = features[features != lbl]
X = as.matrix(df[, features])
y = as.matrix(df[, lbl])

num_categories = length(unique(y))
if (num_categories != 2) {
    print(sprintf("error: target %s is not binary: %d): %s",
                  lbl,
                  num_categories,
                  paste0(unique(y), collapse=" ")))
}

stopifnot(num_categories == 2)

nfeatures = dim(X)[2]

selected_lst <- list()
fn_knockoff <- tempfile()
if (!dir.exists(dirname(fn_knockoff))) {
   dir.create(dirname(fn_knockoff))
}
for (it in 1:num_iterations) {
    if (!use_gan) {
        mu = rep(0, nfeatures)
        rho = 0.10
        Sigma = toeplitz(rho^(0:(nfeatures-1))) # diagnal const
        diag_s = create.solve_asdp(Sigma)
        X_k = create.gaussian(X, mu, Sigma, diag_s=diag_s)
    } else {
        script_bs <- "KnockoffGAN.py"
        if (length(proj_dir)) {
            script <- sprintf("%s/alg/knockoffgan/%s", proj_dir, script_bs)
        } else {
            script <- script_bs
        }
      	cmd <- sprintf("%s %s -i %s -o %s --target %s --it %d --scale %d",
	                python_exe, script, fn_src, fn_knockoff, lbl, niter, use_scale)
        print(cmd)
        rval <- system(cmd)
        stopifnot(!rval)
        print(sprintf("reading %s", fn_knockoff))
        df_k = read.csv(fn_knockoff)
        X_k = as.matrix(df_k[, names(df_k) != lbl])
    }
    if (stat_type=="rf") {
        W = stat.random_forest(X, X_k, y, family="binomial")
    } else if (stat_type=="glm") {
        W = stat.glmnet_coefdiff(X, X_k, y, family="binomial")
    } else {
        stopifnot(FALSE)
    }
    t = knockoff.threshold(W, fdr=fdr_threshold, offset=1)
    selected = which(W >= t)
    selected_lst[[it]] <- selected
    print(sprintf("%d) selected: %s", it, paste(selected_lst[[it]], collapse=" ")))
    selected_avg <- get_selected_features(selected_lst, it)
    print(sprintf("%d,%d)) average selected: %d) %s",
                  it,
                  num_iterations,
                  length(selected_avg),
                  paste(features[selected_avg], collapse=" ")))
}

selected_final <- get_selected_features(selected_lst, length(selected_lst))

print(
    sprintf(
        "fdr %0.2f #%d,%d,%0.2f%%) (th %0.0f) : %s",
        fdr_threshold,
        length(selected_final), nfeatures, length(selected_final)/nfeatures,
        num_iterations/2,
        paste(features[selected_final], collapse=" ")))

result_json = sprintf('{ "features_selected": [\"%s\" ], "features": ["%s"]}',
    paste(features[selected_final], collapse='","'),
    paste(features, collapse='","'))
if (length(fn_json)) {
    write(result_json, file=fn_json)
}
file.remove(fn_knockoff)


library(igraph)
library(R.utils)

foo1 <- function() {
  print("Tic");
  for (kk in 1:100) {
    print(kk);
    Sys.sleep(0.3);
  }
  print("Tac");
}

withTimeout(foo1(), timeout = 1, onTimeout = "warning")

foo2 <- function() {
  print("Tic");
  N <- 10000
  g <- erdos.renyi.game(N, 0.75)
  V(g)$color <- sample(5,N, replace=TRUE)
  is_isomorphic_to(g, g, method='vf2')
  print("Tac");
}

withTimeout(foo2(), timeout = 1, onTimeout = "warning")


library(tidyverse)

sample <- c('wt', 'mut')
gene <- c('IFN', 'ACTIN')
time <- c(0, 12, 24, 48)
rt <- c('+', '-') # reverse transcriptase added?
rep <- 1:3

set.seed(47681)
sample_data <- crossing(sample, time, gene, rep, rt)

plus_rts <- filter(sample_data, rt == "+")

t0 <- filter(plus_rts, time == 0) %>% rowwise() %>% mutate(exp = sample(5:15, 1))
t12 <- filter(plus_rts, time == 12) %>% rowwise() %>% mutate(exp = sample(45:55, 1))
t24 <- filter(plus_rts, time == 24) %>% rowwise() %>% mutate(exp = sample(95:100, 1))
t48 <- filter(plus_rts, time == 48) %>% rowwise() %>% mutate(exp = sample(350:600, 1))

plus_rts <- bind_rows(t0, t12, t24, t48)

# add multiplier for genes
ifns <- filter(plus_rts, gene == "IFN") %>% mutate(exp = exp * 1.5)
actins <- filter(plus_rts, gene == "ACTIN") %>% mutate(exp = exp * 0.2)
plus_rts <- bind_rows(ifns, actins)

minus_rts <- filter(sample_data, rt == "-") %>% mutate(exp = 0)

sample_data <- bind_rows(plus_rts, minus_rts) %>% arrange(sample, time, gene, rep)

qpcr_names <- sample_data %>%
  unite(name, sample, time, gene, rt, rep, sep = "_") %>%
  pluck("name") %>%
  matrix(nrow = 8, ncol = 12) %>%
  as_tibble() %>%
  set_names(nm = 1:12) %>%
  mutate(row = toupper(letters[1:8])) %>%
  select(row, everything())

qpcr_data <- sample_data %>%
  pluck("exp") %>%
  matrix(nrow = 8, ncol = 12) %>%
  as_tibble() %>%
  set_names(nm = 1:12) %>%
  mutate(row = toupper(letters[1:8])) %>%
  select(row, everything())

devtools::use_data(qpcr_names, compress = 'xz', overwrite = TRUE)
devtools::use_data(qpcr_data, compress = 'xz', overwrite = TRUE)


utilities_path = "/home/yuanhao/single_cell/scripts/evaluation_pipeline/evaluation/utilities.r"
source(utilities_path)
result_list = list()
method_names = c("Observed", "DISC", "SAVER", "scImpute", "VIPER", "MAGIC", "DCA", "deepImpute", "scScope", "scVI")
text_color = rep("black", length(method_names))
names(text_color) = method_names
text_color["DISC"] = "red"
bar_color = rep("gray50", length(method_names))
names(bar_color) = method_names
bar_color["Observed"] = "gray80"
bar_color["DISC"] = "red"
for(ii in method_names){
  result_list[[ii]] = list()
  for(jj in c(1, 2, 3, 4, 5)){
    if(ii %in% c("Observed", "DISC", "SAVER", "MAGIC", "DCA", "scScope", "scVI")){
      if(ii %in% c("SAVER", "MAGIC", "DCA", "scScope", "scVI")){
        use_name = ii
      }else if(ii == "Observed"){
        use_name = "RAW"
      }else if(ii == "DISC"){
        use_name = "DeSCI"
      }else{
        stop("Invaild use_name!")
      }
      cell_type_result = as.matrix(read.table(paste0("/home/wucheng/imputation/pbmc/ds0.3/repeat", jj, "/", use_name, "/Recall1.txt"), sep = "\t"))
      overall_result = as.matrix(read.table(paste0("/home/wucheng/imputation/pbmc/ds0.3/repeat", jj, "/", use_name, "/Accuracy.txt"), sep = "\t", header = T))
      this_result = list(Jaccard = cell_type_result["Jaac", ], ACC = overall_result[, "Accuracy"])
      result_list[[ii]][[jj]] = this_result
    }else{
      if(ii == "VIPER"){
        use_name = "VIPER_gene"
      }else{
        use_name = ii
      }
      all_result = readRDS(paste0("/home/yuanhao/data/fn/pbmc3k/ds/downsampling_first_repeat_", jj, "/imputation/cluster_evaluation_0.3/3_", use_name, "_mc_10_mce_1_resume_dim/pca/identification_result.rds"))
      this_result = list(Jaccard = all_result[["cell_type_result"]][, "Jaccard"], ACC = all_result[["summary"]]["ACC"])
      result_list[[ii]][[jj]] = this_result
    }
  }
}
output_dir = paste0("/home/yuanhao/data/fn/pbmc3k/ds/ds_0.3_results/clustering")
dir.create(output_dir, showWarnings = F, recursive = T)

acc_result = t(sapply(result_list, function(x){
  return(as.numeric(sapply(x, function(y){
    return(y[["ACC"]])
  })))
}))
jaccard_mat = t(sapply(result_list, function(x){
  return(rowMeans(sapply(x, function(y){
    return(y[["Jaccard"]])
  })))
}))

pdf(paste0(output_dir, "/ACC.pdf"), height = 6, width = 5)
barplot_usage(rowMeans(acc_result), standard_error = apply(acc_result, 1, ste), main = "", cex.main = 1.5, bar_color = bar_color, text_color = text_color, use_data_order = T, ylab = "ACC", cex.lab = 1.5, font.main = 1, ylim = c(-0.1, 1), decreasing = TRUE)
dev.off()

pdf(paste0(output_dir, "/Jaccard.pdf"), height = 5, width = 10)
cell_type_heatmap(jaccard_mat, "Jaccard")
dev.off()


# Calculate probability of null model producing results as extreme as our observations
# like wfs_nullmodel_function.r, but specifically for loci run with many simulations (those with low p-values)
# run after wfs_make_sims_null.r or wfs_make_sims_null_3times.r
# This version set up to run for Lof

# pop <- 'Lof'; yrs <- '071114' # for Lof 3 time points
# pop <- 'Lof'; yrs <- '0711'
#pop <- 'Lof'; yrs <- '0714'
 pop <- 'Can'; yrs <- '00'

# load functions: assume this is run on a cod or abel node
require(parallel, lib.loc="/projects/cees/lib/R_packages/")
require(iterators, lib.loc="/projects/cees/lib/R_packages/") # used with foreach
require(foreach, lib.loc="/projects/cees/lib/R_packages/") # for parallel procssing using foreach()
require(doMC, lib.loc="/projects/cees/lib/R_packages/")
require(doParallel, lib.loc="/projects/cees/lib/R_packages/") # needed for foreach
require(doSNOW, lib.loc="/projects/cees/lib/R_packages/") # set up SOCK cluster
require(bit, lib.loc="/projects/cees/lib/R_packages/") # for use with ff
require(ff, lib.loc="/projects/cees/lib/R_packages/") # for big objects shared across processes
require(data.table, lib.loc="/projects/cees/lib/R_packages/")

# load observed data
if(pop == 'Lof'){
	if(yrs == '0711'){
		targfile <- 'data_2019_03_18/Frequency_table_Lof07_Lof11.txt'
	}
	if(yrs == '0714'){
		targfile <- 'data_2019_03_18/Frequency_table_Lof07_Lof14.txt'
	}
	if(yrs == '071114'){
		targfile <- 'data_2019_03_18/Frequency_table_Lof07_Lof11.txt'
		targfile2 <- 'data_2019_03_18/Frequency_table_Lof07_Lof14.txt'
	}
}
if(pop == 'Can'){
	targfile <- paste('data_2019_03_18/Frequency_table_CAN_40_TGA.txt', sep='')
}
targ <- fread(targfile, header=TRUE)
setnames(targ, 3:7, c('alcnt1', 'f1samp', 'alcnt2', 'f2samp', 'ABS_DIFF'))
targ[,locusnum:=1:nrow(targ)] # add a locus number indicator

if(yrs=='071114'){
	targ2 <- fread(targfile2, header=TRUE)
	setnames(targ2, 3:7, c('alcnt1', 'f1samp', 'alcnt3', 'f3samp', 'ABS_DIFF13'))
	setkey(targ, CHROM, POS)
	setkey(targ2, CHROM, POS)
	targ <- targ[targ2,.(locusnum, CHROM, POS, alcnt1, alcnt2, alcnt3, f1samp, f2samp, f3samp)]
}

# trim only to loci with low p-values in a previous run
print('Trimming to loci with p<=4/(n+1)') # 4 out of n+1 sims
if(pop=='Lof' & yrs=='0711'){
	pvals <- as.data.table(readRDS('analysis/wfs_nullmodel_pos&pvals_07-11.rds'))
	targ <- merge(targ, pvals[,.(CHROM, POS, n, p)], by=c('CHROM', 'POS')) # merge in p-values for Lof
}
if(pop=='Lof' & yrs=='0714'){
	pvals <- as.data.table(readRDS('analysis/wfs_nullmodel_pos&pvals_07-14.rds'))
	targ <- merge(targ, pvals[,.(CHROM, POS, n, p)], by=c('CHROM', 'POS')) # merge in p-values for Lof
}
if(pop=='Lof' & yrs=='1114'){
	pvals <- as.data.table(readRDS('analysis/wfs_nullmodel_pos&pvals_11-14.rds'))
	targ <- merge(targ, pvals[,.(CHROM, POS, n, p)], by=c('CHROM', 'POS')) # merge in p-values for Lof
}
if(pop=='Lof' & yrs=='071114'){
	pvals <- as.data.table(readRDS('analysis/wfs_nullmodel_pos&pvals_07-11-14.rds'))
	targ <- merge(targ, pvals[,.(CHROM, POS, n, p)], by=c('CHROM', 'POS')) # merge in p-values for Lof
}
if(pop=='Can'){
	pvals <- as.data.table(readRDS('analysis/wfs_nullmodel_pos&pvals_Can.rds'))
	targ <- merge(targ, pvals[,.(CHROM, POS, n, p)], by=c('CHROM', 'POS')) # merge in p-values for Lof
}
print(nrow(targ)) # initial # loci
targ <- targ[p<=4/(n+1),]
print(nrow(targ)) # after trimming

# trim only to loci with simulation files
if(pop=='Lof'){
	simfiles <- list.files(path='analysis/temp', pattern='wfs_simsnull_ff.+_[[:digit:]]+\\.ffData') # the existing simulations
	sims <- gsub('wfs_simsnull_ff|.ffData', '', simfiles) # trim file names to just sample sizes and rep #
}
if(pop=='Can'){
	simfiles <- list.files(path='analysis/temp', pattern='wfs_simsnullCAN_ff.+_[[:digit:]]+\\.ffData') # the existing simulations
	sims <- gsub('wfs_simsnullCAN_ff|.ffData', '', simfiles) # trim file names to just sample sizes and rep #
}
sim_locs <- unique(gsub('_[[:digit:]]+', '', sims)) # trim to just the sample sizes
if(yrs!='071114') targ_locs <- targ[,paste(alcnt1, alcnt2, sep=',')]
if(yrs=='071114') targ_locs <- targ[,paste(alcnt1, alcnt2, alcnt3, sep=',')]
keep <- targ_locs %in% sim_locs
print(dim(targ)) # how many loci initially
sum(keep) # how many to keep
targ <- targ[keep,] # trim
print(dim(targ)) # how many kept (a double check)

# Null model test: how likely are results this extreme?
# locusnum: the locus number
# thistarg: f1samp and f2samp (first and second sample allele frequencies), as a data.table
# thisout.ff: ff object from the null model simulations, 7 x many, with rows for f1samp and f2samp.
# tol: how close simulations and observation have to be to have the "same" starting frequency or to have the same change in frequency
nullmodtest <- function(thistarg, thisout.ff, tol=1/100){

	# find extreme simulations
	stinds <- abs(thisout.ff['f1samp',] - thistarg[,f1samp]) < tol # null model simulations that had the same starting sample frequency
	delta <- thistarg[,f2samp] - thistarg[,f1samp] # observed allele frequency change
	if(delta>0){
		extinds <- (thisout.ff['f2samp',stinds] - thisout.ff['f1samp',stinds]) >= (delta - tol) # simulations that also had as or greater allele frequency change
	} else {
		extinds <- (thisout.ff['f2samp',stinds] - thisout.ff['f1samp',stinds]) <= delta + tol # simulations that also had as or more extreme allele frequency change (for delta <= 0)
	}

	return(data.frame(e=sum(extinds), n=sum(stinds)))
}

# for 3 timepoints
nullmodtest3 <- function(thistarg, thisout.ff, tol=1/100){

	# find extreme simulations
	stinds <- abs(thisout.ff['f1samp',] - thistarg[,f1samp]) < tol # null model simulations that had the same starting sample frequency
	delta <- thistarg[,f2samp] - thistarg[,f1samp] # observed allele frequency change
	delta2 <- thistarg[,f3samp] - thistarg[,f1samp] # observed allele frequency change
	if(delta>0){
		extinds1 <- (thisout.ff['f2samp',stinds] - thisout.ff['f1samp',stinds]) >= (delta - tol) # simulations that also had as or greater allele frequency change
	}
	if(delta<=0){
		extinds1 <- (thisout.ff['f2samp',stinds] - thisout.ff['f1samp',stinds]) <= delta + tol # simulations that also had as or more extreme allele frequency change (for delta <= 0)
	}
	if(delta2>0){
		extinds2 <- (thisout.ff['f3samp',stinds] - thisout.ff['f1samp',stinds]) >= (delta2 - tol) # simulations that also had as or greater allele frequency change
	}
	if(delta2<=0){
		extinds2 <- (thisout.ff['f3samp',stinds] - thisout.ff['f1samp',stinds]) <= delta2 + tol # simulations that also had as or more extreme allele frequency change (for delta <= 0)
	}

	extinds <- extinds1 & extinds2 # is this the right way to combine the p-values?

	return(data.frame(e=sum(extinds), n=sum(stinds)))
}

##############################################################
### run calculations for each row of targ with a low p-value
##############################################################

for(i in 1:nrow(targ)){
	print(paste('row', i, 'of', nrow(targ)))
	# find the appropriate files with null simulations
	if(yrs!='071114') targ_loc <- targ[i,paste(alcnt1, alcnt2, sep=',')]
	if(yrs=='071114') targ_loc <- targ[i,paste(alcnt1, alcnt2, alcnt3, sep=',')]
	if(pop=='Lof') ffnms <- list.files(path='analysis/temp', pattern=paste('wfs_simsnull_ff', targ_loc, '_[[:digit:]]+\\.ffData', sep=''), full.names=TRUE) # the existing simulations
	if(pop=='Can') ffnms <- list.files(path='analysis/temp', pattern=paste('wfs_simsnullCAN_ff', targ_loc, '_[[:digit:]]+\\.ffData', sep=''), full.names=TRUE) # the existing simulations
		# could add in the file: pattern=paste('wfs_simsnull_ff', targ_loc, '\\.ffData', sep='')
	ffnms <- gsub('.ffData', '', ffnms)

	res <- data.frame(e=numeric(0),n=numeric(0)) # vector of number of simulations more extreme than observations and count of simulations with same starting sample freq

	# loop through the files of simulations
	for(j in 1:length(ffnms)){
		print(paste('     file', j, 'of', length(ffnms)))
		# load one file of simulations
		ffload(ffnms[j], overwrite=TRUE, rootpath=getOption('fftempdir')) # takes 30 sec or so. loads thisout.ff

		if(yrs != '071114') thisres <- nullmodtest(thistarg=targ[i,.(f1samp, f2samp)], thisout.ff=thisout.ff) # run null model test. returns vector of number of simulations more extreme than observations and count of simulations with same starting sample freq
		if(yrs == '071114') thisres <- nullmodtest3(thistarg=targ[i,.(f1samp, f2samp, f3samp)], thisout.ff=thisout.ff) # 3 time points

		# save results from this loop
		res <- rbind(res, thisres)

		# remove ff temporary files
		delete(thisout.ff)
		rm(thisout.ff)
	}

 	# calculate p-value (see North et al. 2002 Am J Hum Gen for why the +1s)
 	# add to targ
 	targ[i, ':=' (p=(sum(res$e)+1)/(sum(res$n)+1), n=sum(res$n))]

}

# insert new p-values and n sims into pvals dataframe (probably a more elegant way to do this)
for(i in 1:nrow(targ)){
	j <- pvals[,CHROM]==targ[i,CHROM] & pvals[,POS]==targ[i,POS]
	pvals[j, p:=targ[i,p]]
	pvals[j, n:=targ[i,n]]
}

# recalculate p.adj and p.adj3 (from wfs_nullmodel_combine.r and wfs_nullmodel_analysis.r)
# pvals[,p.adj := p.adjust(p, method='fdr')]
# pvals[!(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')),p.adj3 := p.adjust(p, method='fdr')]

# examine
summary(pvals)
pvals[p==min(p),.(CHROM, POS, p, r=p*(n+1)-1, n=n)] # low p-values
pvals[,min(p*(n+1)-1)] # if <=3, have more to re-run
pvals[p*(n+1)-1 <= 3,.(CHROM, POS, nloci=.N, r=p*(n+1)-1, n=n)] # number left to run

# need to write out pos&pvals again
if(pop=='Lof' & yrs=='071114') outfile <- 'analysis/wfs_nullmodel_pos&pvals_07-11-14.rds'
if(pop=='Lof' & yrs=='0711') outfile <- 'analysis/wfs_nullmodel_pos&pvals_07-11.rds'
if(pop=='Lof' & yrs=='0714') outfile <- 'analysis/wfs_nullmodel_pos&pvals_07-14.rds'
if(pop=='Lof' & yrs=='1114') outfile <- 'analysis/wfs_nullmodel_pos&pvals_11-14.rds'
if(pop=='Can') outfile <- 'analysis/wfs_nullmodel_pos&pvals_Can.rds'
print(outfile)
# saveRDS(pvals[,.(CHROM, POS, n, p, p.adj, p.adj3)], file=outfile)
saveRDS(pvals, file=outfile)


#################################
library(tidyverse)
library(furrr)
library(lme4)
library(MSnbase)
library(MSqRob)

##Import and preprocess data
############################
MSnSet2df = function(msnset){
  ## Converts Msnset to a tidy dataframe
  ## Always creates feature and vector column so these shouldn't be defined by user.
  ## convenient for downstream analysis steps.
  if(any(c("sample", "feature", "expression") %in% c(colnames(fData(msnset)),colnames(pData(msnset))))){
    stop("Column names in the \"fData\" or \"pData\" slot of the \"msnset\" object cannot be named
         \"sample\", \"feature\" or \"expression\". Please rename these columns before running the analysis.")
  }

  dt <- as.data.frame(Biobase::exprs(msnset)) %>% mutate(feature = rownames(.)) %>%
    gather(sample, expression, - feature, na.rm=TRUE)
  dt <- fData(msnset) %>% mutate(feature = rownames(.)) %>% left_join(dt,. , by = 'feature')
  dt <- pData(msnset) %>% mutate(sample = rownames(.)) %>% left_join(dt,. , by = 'sample')
  as_data_frame(dt)
}

## robust summarisation
do_robust_summaristion = function(msnset, group_var = Proteins, keep_fData_cols = NULL, nIter = 20,
                                  sum_fun = summarizeRobust){
  ## TODO use funture_map instead of mutate to speed up
  ## Uses assumption that featureNames and sampleNames exist in every msnset
  ## Can also be used for multiple rounds of normalization, e.g. first from PSMs to peptides, then from peptides to proteins
  system.time({## Time how long it takes
    group_var <- enquo(group_var) ;#group_var = quo(Proteins)
  ## Make tidy dataframe from Msnset
    df <- MSnSet2df(msnset)
    ## Do summarisision according defined groups
    dt <- filter(df, !is.na(expression)) %>% group_by(!!group_var) %>%
      mutate(expression = sum_fun(expression, feature, sample, nIter = nIter)) %>%
      dplyr::select(!!group_var, sample, expression) %>%
      ## collapse to one value per group
      distinct
    ## Construct an Msnset object from dataframe
    dt_exprs <- spread(dt, sample, expression) %>% ungroup
    exprs_data <- dplyr::select(dt_exprs, - !!group_var) %>% as.matrix
    rownames(exprs_data) <- as.character(pull(dt_exprs, !!group_var))

    fd <- dplyr::select(dt_exprs,!!group_var)

    ##Select the group variable and all variables you want to keep
    if (!is.null(keep_fData_cols)){
      fd_ext <- dplyr::select(df, !!group_var, one_of(keep_fData_cols)) %>% distinct
      if(nrow(fd)!=nrow(fd_ext)){
        stop("Values in the \"group_var\" column can only correspond to a single value in the \"keep_fData_cols\" column.")
      }
      fd <- left_join(fd,fd_ext)
    }

    fd <- as.data.frame(fd)
    rownames(fd) <- as.character(pull(fd, !!group_var))
    out <- MSnSet(exprs_data, fData = AnnotatedDataFrame(fd) , pData = pData(msnset)[colnames(exprs_data),,drop = FALSE])
  }) %>% print
  out
}

summarizeRobust <- function(expression, feature, sample, nIter=100,...) {
  ## Assumes that intensities mx are already log-transformed
  ## characters are faster to construct and work with then factors
  feature <- as.character(feature)
  ##If there is only one 1 peptide for all samples return expression of that peptide
  if (length(unique(feature)) == 1L) return(expression)
  sample <- as.character(sample)
  ## modelmatrix breaks on factors with 1 level so make vector of ones (will be intercept)
  if (length(unique(sample)) == 1L) sample = rep(1,length(sample))

  ## sum contrast on peptide level so sample effect will be mean over all peptides instead of reference level
  X = model.matrix(~ -1 + sample + feature,contrasts.arg = list(feature = 'contr.sum'))
  ## MasS::rlm breaks on singulare values.
  ## check with base lm if singular values are present.
  ## if so, these coefficients will be zero, remove this collumn from model matrix
  ## rinse and repeat on reduced modelmatrx till no singular values are present
  repeat {
    fit = .lm.fit(X,expression)
    id = fit$coefficients != 0
    X = X[ , id, drop =FALSE]
    if (!any(!id)) break
  }
  ## Last step is always rlm
  fit = MASS::rlm(X,expression,maxit = nIter,...)
  ## Only return the estimated effects effects as summarised values
  sampleid = seq_along(unique(sample))
  return(X[,sampleid,drop = FALSE] %*% fit$coefficients[sampleid])
}

## mixed models
###############
setGeneric (
  name= "getBetaB",
  def=function(model,...){standardGeneric("getBetaB")}
)

.getBetaBMermod = function(model) {
  betaB <- c(as.vector(getME(model,"beta")),as.vector(getME(model,"b")))
  names(betaB) <- c(colnames(getME(model,"X")),rownames(getME(model,"Zt")))
  betaB
}
setMethod("getBetaB", "lmerMod", .getBetaBMermod)

.getBetaBGlm = function(model)
  model$coefficients

setGeneric (
  name= "getVcovBetaBUnscaled",
  def=function(model,...){standardGeneric("getVcovBetaBUnscaled")}
)

setMethod("getBetaB", "glm", .getBetaBGlm)

.getVcovBetaBUnscaledMermod = function(model){
  ## TODO speed up (see code GAM4)
  p <- ncol(getME(model,"X"))
  q <- nrow(getME(model,"Zt"))
  Ct <- rbind2(t(getME(model,"X")),getME(model,"Zt"))
  Ginv <- solve(tcrossprod(getME(model,"Lambda"))+Diagonal(q,1e-18))
  vcovInv <- tcrossprod(Ct)
  vcovInv[((p+1):(q+p)),((p+1):(q+p))] <- vcovInv[((p+1):(q+p)),((p+1):(q+p))]+Ginv

 solve(vcovInv)
}

setMethod("getVcovBetaBUnscaled", "lmerMod", .getVcovBetaBUnscaledMermod)

.getVcovBetaBUnscaledGlm = function(model)
  ## cov.scaled is scaled with the dispersion, "cov.scaled" is without the dispersion!
  ## MSqRob::getSigma is needed because regular "sigma" function can return "NaN" when sigma is very small!
  ## This might cause contrasts that can be estimated using summary() to be NA with our approach!
  summary(model)$cov.scaled/MSqRob::getSigma(model)^2

setMethod("getVcovBetaBUnscaled", "glm", .getVcovBetaBUnscaledGlm)

## Estimate pvalues contrasts
contrast_helper = function(formula, msnset, contrast = NULL){
  ## Gives back the coefficients you can use to make contrasts with given the formula and dataset
  ## If a factor variable is specified (that is present in the formula) all the possible contrasts
  ## within this variable are returned
  contrast <- enquo(contrast) ;#contrast = quo(condition)
  df <- MSnSet2df(msnset)
  all_vars <- formula %>% terms %>% delete.response %>% all.vars
  names(all_vars) <- all_vars
  df[,all_vars] <- map2_dfr(all_vars,df[,all_vars],paste0)
  coefficients <- c("(Intercept)", df %>% dplyr::select(all_vars) %>% unlist %>% unique %>% as.character)
  if (contrast != ~NULL) {
    c <- pull(df,!! contrast) %>% unique %>% sort %>% as.factor
    comp <- combn(c,2,simplify = FALSE)
    ## condIds = map(comp,~which( coefficients %in% .x))
    ## L = rep(0,length(coefficients))
    ## L = sapply(condIds,function(x){L[x]=c(-1,1);L})
    ## rownames(L) = coefficients
    ## colnames(L) = map_chr(comp, ~paste(.x,collapse = '-'))
    condIds <- map(comp, ~which(coefficients %in% .x))
    L <- rep(0,nlevels(c))
    L <- sapply(comp,function(x){L[x]=c(-1,1);L})
    rownames(L) <- levels(c)
    colnames(L) <- map_chr(comp, ~paste(rev(.x),collapse = '-'))
    L
  } else coefficients
}

setGeneric (
  name= "getXLevels",
  def=function(model,...){standardGeneric("getXLevels")}
)

.getXLevelsGlm = function(model)
  map2(names(model$xlevels), model$xlevels, paste0) %>% unlist

setMethod("getXLevels", "glm", .getXLevelsGlm)

.getXLevelsMermod = function(model)
  getME(model,"flist") %>% map(levels) %>% unlist %>% unname

setMethod("getXLevels", "lmerMod", .getXLevelsMermod)

contEst <- function(model, contrasts, var, df, lfc = 0){
  #TODO only contrast of random effect possible and not between fixed regression terms
  betaB <- getBetaB(model)
  vcov <- getVcovBetaBUnscaled(model)
  coefficients <- names(betaB)
  id <- coefficients %in% rownames(contrasts)

  coefficients <- coefficients[id]
  vcov <- vcov[id,id]
  betaB <- betaB[id]

  xlevels <- getXLevels(model)
  id <- !apply(contrasts,2,function(x){any(x[!(rownames(contrasts) %in% xlevels)] !=0)})
  contrasts <- contrasts[coefficients, id, drop = FALSE]
  ## If no contrasts could be found, terminate
  if (is.null(colnames(contrasts))) return(new_tibble(list()))

  se <- sqrt(diag(t(contrasts)%*%vcov%*%contrasts)*var)
  logFC <- (t(contrasts)%*%betaB)[,1]

  ### Addition to allow testing against another log FC (lfc)
  ### See https://www.ncbi.nlm.nih.gov/pmc/articles/PMC2654802/

  lfc <- abs(lfc)
  aest <- abs(logFC)

  Tval <- setNames(rep(0, length(logFC)),names(se))
  tstat.right <- (aest - lfc)/se
  tstat.left <- (aest + lfc)/se
  pval <- pt(tstat.right, df = df, lower.tail = FALSE) +
    pt(tstat.left, df = df, lower.tail = FALSE)
  tstat.right <- pmax(tstat.right, 0)
  fc.up <- (logFC >= lfc)
  fc.up[is.na(fc.up)] <- FALSE
  fc.down <- (logFC < -lfc)
  fc.down[is.na(fc.down)] <- FALSE
  Tval[fc.up] <- tstat.right[fc.up]
  Tval[fc.down] <- -tstat.right[fc.down]
  Tval[is.na(logFC)] <- NA

  new_tibble(list(contrast = colnames(contrasts),
                  logFC = logFC,
                  se = se,
                  t = Tval,
                  df = rep(df, length(se)),
                  pvalue = pval))
}

do_lmerfit = function(df, form, nIter = 10, tol = 1e-6, control = lmerControl(calc.derivs = FALSE)){
  fit <- lmer(form, data = df, control = control)
  ##Initialize SSE
  res <- resid(fit)
  ## sseOld=sum(res^2)
  sseOld <- fit@devcomp$cmp['pwrss']
  while (nIter > 0){
    nIter = nIter-1
    fit@frame$`(weights)` <- MASS::psi.huber(res/(mad(res)))
    fit <- refit(fit)
    res <- resid(fit)
    ## sse=sum(res^2)
    sse <- fit@devcomp$cmp['pwrss']
    if(abs(sseOld-sse)/sseOld <= tol) break
    sseOld <- sse
  }
  return(fit)
}

calculate_df = function(df, model, vars){
  ## Get all the variables in the formula that are not defined in vars
  form <- attributes(model@frame)$formula
  vars_formula <- all.vars(form)
  vars_drop <- vars_formula[!vars_formula %in% vars]
  ## Sum of number of columns -1 of Zt mtrix of each random effect that does not involve a variable in vars_drop
  mq <- getME(model,'q_i')
  id <- !map_lgl(names(mq),~{any(stringr::str_detect(.x,vars_drop))})
  p <- sum(mq[id]) - sum(id)
  ## Sum of fixed effect parameters that do not involve a variable in vars_drop
  mx <- getME(model,'X')
  id <- !map_lgl(colnames(mx),~{any(stringr::str_detect(.x,vars_drop))})
  p <- p + sum(id)

  ## n is number of sample because 1 protein defined per sample
  n <- n_distinct(df$sample)
  n-p
}

do_mm = function(formulas, msnset, group_vars = feature,type_df = 'traceHat'
                  , contrasts = NULL, lfc = 0, p.adjust.method = "BH", max_iter = 20L
                  , squeeze_variance = TRUE
               , control = lmerControl(calc.derivs = FALSE)
                 ## choose parallel = plan(sequential) if you don't want parallelisation
               ## , parallel_plan = plan(cluster, workers = makeClusterPSOCK(availableCores()))
               , parallel = TRUE, cores = availableCores()
                 ){
  if(!(type_df %in% c("conservative", "traceHat")))
    stop("Invalid input `type_df`.")

  system.time({## can take a while
    if (parallel){
      cl <- makeClusterPSOCK(cores)
      plan(cluster, workers = cl)
    } else {
    plan(sequential)}

    ## future::plan(parallel_plan,gc = TRUE)
    formulas <-  map(c(formulas), ~update(.,expression ~ . ))
    group_vars <- enquo(group_vars) # group_var = quo(protein)
    df <- MSnSet2df(msnset)

    ## Glm adds variable name to levels in catogorical (eg for contrast)
    ## lme4 doesnt do this for random effect, so add beforehand
    ## Ludger needs this for Hurdle
    df = formulas %>% map(lme4:::findbars) %>% unlist %>% map_chr(all.vars) %>% unique %>%
      purrr::reduce(~{mutate_at(.x,.y,funs(paste0(.y,.)))}, .init=df)

    cat("Fitting mixed models\n")
    ## select only columns needed for fitting
    df_prot <- df %>%
      group_by_at(vars(!!group_vars)) %>% nest %>%
      mutate(model = furrr::future_map(data,~{
        for (form in formulas){
          fit = try(do_lmerfit(.x, form, nIter = max_iter,control = control))
          if (class(fit) == "lmerMod") return(fit)
        }
        fit
      }))

    ## Return also failed ones afterward
    df_prot_failed <- filter(df_prot, map_lgl(model,~{class(.x) != "lmerMod"}))
    df_prot <- filter(df_prot, map_lgl(model, ~{class(.x)=="lmerMod"}))

    if(nrow(df_prot) == 0) {print("No models could be fitted"); return(df_prot_failed)}

    df_prot <-
      mutate(df_prot
           , formula = map(model,~{attributes(.@frame)$formula})
             ## get trace hat df for squeezeVar
           , df = map_dbl(model, ~getDf(.x))
           , sigma = map_dbl(model,~{MSqRob::getSigma(.x)})) %>%
      ## Squeeze variance
      bind_cols(as_data_frame(MSqRob::squeezeVarRob(.$sigma^2, .$df, robust = TRUE))) %>%
      ## mutate(var_protein = ifelse(squeeze_variance,var.post,sigma^2),
      mutate(var_protein = if (squeeze_variance) var.post else sigma^2,
             df_post = df + df.prior
           , df_protein =
               if (type_df == "conservative")
                 ## Calculate df on protein level, assumption is that there is only one protein value/run,
                 map2_dbl(data, model,~calculate_df(.x,.y, vars = colnames(pData(msnset))))
               else if (type_df == "traceHat")
                 ## Alternative: MSqRob implementation with trace(Hat):
                 if(squeeze_variance) df_post else df
             )

    ## Calculate fold changes and p values for contrast
    cat("Estimating p-values contrasts\n")
    df_prot <- df_prot %>%
      mutate(contrasts =  furrr::future_pmap(list(model = model, contrasts = list(contrasts),
                                                     var = var_protein,
                                                     df = df_protein, lfc = lfc), contEst))  %>%
      ## Calculate qvalues BH
      select_at(vars(!!group_vars, contrasts)) %>%
      unnest %>%
      group_by(contrast) %>%
      mutate(qvalue = p.adjust(pvalue, method = p.adjust.method)) %>%
      group_by_at(vars(!!group_vars)) %>% nest(.key = contrasts) %>%
      left_join(df_prot,.)
  }
  ) %>% print
  if (parallel) stopCluster(cl)
  bind_rows(df_prot,df_prot_failed)
}

read_moff = function(moff,meta){
  print('START READING MOFF DATA')
  set = readMSnSet2(moff, ecol = -c(1,2),fnames = 'peptide',
                    sep = '\t',stringsAsFactors = FALSE)
  colnames(fData(set)) = c('peptide','protein')
  pd = read_tsv(meta) %>% column_to_rownames('sample') %>% as.data.frame

  ## fix msnbase bug 1
  ## if there is only 1 sample. Msnbase doesn't name it
  if (length(sampleNames(set) ==1))
    sampleNames(set) = rownames(pd)

  pData(set) = pd
  ## fix msnbase bug 2
  ## bug in msnbase in summarisation (samplenames should be alphabetically)
  sample_order = order(sampleNames(set))
  set = MSnSet(exprs(set)[,sample_order,drop = FALSE]
             , fData =  AnnotatedDataFrame(fData(set))
             , pData = AnnotatedDataFrame(pData(set)[sample_order,,drop = FALSE]))
  print('END READING MOFF DATA')
  set
}

preprocess = function(set){
  print('START PREPROCESSING')
  if (ncol(set) == 1){
    exprs(set)[0 == (exprs(set))] <- NA
    set = log(set, base = 2)
    ## keep smallest unique groups
    groups2 <- smallestUniqueGroups(fData(set)$protein,split = ',')
    sel <- fData(set)$protein %in% groups2
    set <- set[sel,]
  } else {
    ## normalisation
    exprs(set)[0 == (exprs(set))] <- NA
    set <- normalize(set, 'vsn')
    ## keep smallest unique groups
    groups2 <- smallestUniqueGroups(fData(set)$protein,split = ',')
    sel <- fData(set)$protein %in% groups2
    set <- set[sel,]
    ## remove peptides with less then 2 observations
    sel <- rowSums(!is.na(exprs(set))) >= 2
    set <- set[sel]
  }
  print('END PREPROCESSING')
  set
}

summarise = function(set){
  print('START SUMMARISATION')
  ## Summarisation
  if (ncol(set) == 1){
    set = combineFeatures(set,fun="median", groupBy = fData(set)$protein,cv = FALSE)
  } else {
    ## set = combineFeatures(set,fun="robust", groupBy = fData(set)$protein,cv = FALSE)
    set = do_robust_summaristion(set,protein)
  }
  exprs(set) %>% as.data.frame %>% rownames_to_column('protein') %>% write_tsv('summarised_proteins.tsv')
  print('END SUMMARISATION')
  set
}

quantify = function(set, cpu = 0){
  print('START QUANTITATION')
  if ((cpu == 0) | is.na(cpu)) cpu = availableCores()
  print(cpu)
  form = colnames(pData(set)) %>% paste0('(1|',.,')',collapse='+') %>% paste('~',.) %>% as.formula
  contrasts <- contrast_helper(form, set, condition)
  res = do_mm(formulas = form, set, group_vars = c(protein)
            , contrasts = contrasts,type_df = 'traceHat', parallel = TRUE,cores = cpu) %>%
    filter(!map_lgl(contrasts, is.null)) %>%
    transmute(protein, contrasts) %>% unnest %>%
    transmute(protein
            , comparison = str_replace_all(contrast, 'condition', '')
            , logFC,pvalue,qvalue) %>%
    write_tsv('quantitation.tsv')
  print('END QUANTITATION')
}

args = commandArgs(trailingOnly=TRUE)
moff = args[1]
meta = args[2]
summarise_only = args[3]
cpu = strtoi(args[4])

res = read_moff(moff, meta) %>%
  preprocess %>%
  summarise
if (summarise_only != 1)
  quantify(res, cpu)


#predefine_start

outputdir<-"Z:/Shared/Labs/Vickers Lab/ShilinZhao/20151017_3018-KCV-45-46/bowtie1_genome_1mm_NTA_smallRNA_table/result"
inputfile<-"smallRNA_1mm_3018-KCV-45-46.miRNA.count"
outputfile<-"smallRNA_1mm_3018-KCV-45-46.miRNA.count.png"
replaceSampleName<-0

#predefine_end

options(bitmapType='cairo')

setwd(outputdir)

library(ggplot2)
library(reshape2)

data<-read.table(inputfile, header=T, sep="\t", stringsAsFactor=F, row.names=1)
isDataNumeric = unlist(lapply(data[1,], function(x){is.numeric(x)}))
if (any(isDataNumeric)) {
  index = 1
  while(!all(isDataNumeric[index:ncol(data)])){
    index = index + 1
  }
} else {
  cat("Error: No numeric data found for ", inputfile, "\n")
  quit(save="no")
}

if(index > 1){
  indecies<-c(1:(index-1))
}else{
  indecies<-c()
}
countData<-data[,c(index:ncol(data)),drop=F]
rownames(countData)<-gsub(";.*", "", rownames(countData))
if(replaceSampleName){
  colnames(countData)<-paste0("S", c(1:ncol(countData)))
}

totalCount<-apply(countData,2,sum)

percData<-data.frame(prop.table(as.matrix(countData), margin=2)*100)

top3indecies<-unique(melt(data.frame(apply(percData, 2, function(x){
  unlist(order(x, decreasing=TRUE)[1:3])
})))$value)

top3indecies<-sort.int(top3indecies)
perctable<-percData[top3indecies,,drop=F]
perctable$Feature<-factor(rownames(perctable), levels=rownames(perctable))
melttable<-melt(perctable, id="Feature")
colnames(melttable)<-c("Feature", "Sample", "Percentage")

png(filename = outputfile, height=1000, width=max(2000, ncol(countData) * 100), res=300)
g<-ggplot(melttable, aes(x=Sample, y=Percentage, fill=Feature))+
  geom_bar(stat="identity") +
  theme_classic() +
  theme(axis.text.x = element_text(angle=90, vjust=0.5, size=11, hjust=1, face="bold"),
        axis.line.x = element_line(colour = "black"),
        axis.line.y = element_line(colour = "black"))
print(g)
dev.off()


source("alternate_methods/epinow2_2.r")

# Wrapper script to run a single area under the
# epinow2 model
opt = epinow2_get_cmdline_options()
print(opt$area_index)
epinow2_run(opt$area_index, opt)


#create update files from maps
#only years for which maps exist will be added in given years

rm(list=ls())

library(tidyverse)
library(raster)

scenario <- "calibration_2020-04-18"

update_yrs <- seq(2001, 2018, 1)

#specify csv containing spatially uniform capital values
#each row is a year, each column is Capital
uniform_caps <- read_csv("Data/UniformCapitals_2020-02-10b.csv")

#need to use region file to identify required XY cells for this simulation
region <- read_csv("Data/region2001_2020-04-18.csv",
  col_types = cols(`Land Price` = col_double(),
    `Growing Season` = col_double(),
    Other  = col_double(),
    `Soy Protection` = col_double(),
    `Maize Protection` = col_double(),
    `Pasture Protection` = col_double(),
    `OAgri Protection` = col_double(),
    `Agri Infrastructure` = col_double(),
    `OAgri Infrastructure` = col_double()
    )
  ) #needed to read correct type

#specify capital map filename patterns  (assumes all map files end 'YEAR.asc')
mois <- "MoistureCap_OctNovDecJanFebMar_S_"
PortAccess <- "PortAccessCap2020_"
Oagri <- "singleLC_OtherAgri_"
other <- "singleLC_Other_"
Soy_LP <- "Soy_ProtectionMap_025_"
Pas_LP <- "Pasture_ProtectionMap_025_"
GrowSeason <- "GSCap_JanFebMarAprMayJun_S_"
LandPrice <- "LandPrice_Capital_08_"
#human <- "HumanCapital"

#create list of capital maps to work through
map_caps <- list(mois, GrowSeason,PortAccess,LandPrice)
#map_caps <- list()
#map_caps <- list(mois, PortAccess, other, Soy_LP, Pas_LP, GrowSeason, LandPrice)
#map_caps <- list(PortAccess, other, Soy_LP, Pas_LP)

#labels that need to be use for capitals in the final output file
map_caps_labs <- list("Moisture", "Growing Season","Port Access","LandPrice")
#map_caps_labs <- list()
#map_caps_labs <- list("Moisture", "Port Access", "Other", "Soy Protection", "Pasture Protection", "Growing Season", "LandPrice")
#map_caps_labs <- list("Port Access", "Other", "Soy Protection", "Pasture Protection")

#FUNCTIONS
#raster to xyz  (with help from https://stackoverflow.com/a/19847419)
#sepcify input raster, whether nodata cells should be output, whether a unique cell ID should be added
#return is a matrix. note format is row (Y) then col (X)
extractXYZ <- function(raster, nodata = FALSE, addCellID = TRUE){

  vals <- raster::extract(raster, 1:ncell(raster))   #specify raster otherwise dplyr used
  xys <- rowColFromCell(raster,1:ncell(raster))
  combine <- cbind(xys,vals)

  if(addCellID){
    combine <- cbind(1:length(combine[,1]), combine)
  }

  if(!nodata){
    combine <- combine[!rowSums(!is.finite(combine)),]  #from https://stackoverflow.com/a/15773560
  }

  return(combine)
}

#read raster data function
readMapXYZ <- function(mapz)
{
  #map <- raster(path)     #read raster
  map <-flip(mapz, 'y')    #flip maps as CRAFTY read values from the bottom of the map
  map <- extractXYZ(map)  #convert from map to xyz (as tibble)
  map <- round(map, 3)
  return(as_tibble(map))  #return xyz as tibble
}

#loop each year
for(i in seq_along(update_yrs)) {

  #select only few columns we need (and we drop muniID belo also)
  joined <- dplyr::select(region, Y, X, muniID)

  print(update_yrs[i])

  #loop each capital
  for(j in seq_along(map_caps)) {

    #create file name to check
    filen <- paste0("Data/updates/",map_caps[j],update_yrs[i],".asc")

    #if file exists, extract xyz
    if(file_test("-f",filen)) {

      ras <- raster(filen)
      xy <- readMapXYZ(ras)

      #create table for this year
      xy <- xy %>%
        dplyr::select(-V1) %>%
        dplyr::rename(Y = row, X = col, !!map_caps_labs[[j]] := vals) %>% #see https://stackoverflow.com/a/26003971
        mutate(Y = round(Y,3)) %>%
        mutate(X = round(X,3))

      joined <- left_join(joined, xy, by = c("Y", "X"))
    }

  }

  #select the uniform capital values for this year (should produce a one-row table)
  unis <- uniform_caps %>%
    filter(Year == !!update_yrs[i])

  #repeat the single row to match the number of pixels in the maps above
  unis_rep <- unis %>%
    slice(rep(1:n(), length(joined$Y)))

  #join the mapped and uniform values
  joined <- cbind(joined, unis_rep)

  #some Moisture cells seem to be NA, change those values (also need to do this for GrowSeason?)
  if(exists("Moisture")){
    # for now replace with mean of all non-NA values
    mois_replace <- round(mean(joined$Moisture, na.rm=T),3)
    print(mois_replace)

    #replace Moisture NAs
    joined <- joined %>%
      mutate(Moisture = replace(Moisture, is.na(Moisture), mois_replace))
  }

  #drop un-necessary columns and replace Moisture NAs
  joined <- joined %>%
    dplyr::select(-muniID, -Year)
    #dplyr::select(-muniID)

  write_csv(joined,paste0("Data/updates/",scenario,"_update",update_yrs[i],".csv"))

  rm(joined)  #remove joined for next year

}


# This has turned out to be nightmare fuel after reboot.
# R had problems finding Rcpp, so had to reinstall with dependencies
# Also had problems with limma from Bioconductor, but hopefully that's sorted

library(TCGAbiolinks)
library(DESeq2)

# Download AML RNAseq data
aml.rnaseq.query <- GDCquery(project = "TCGA-LAML",
                     data.category = "Transcriptome Profiling",
                     data.type = "Gene Expression Quantification",
                     workflow.type = "HTSeq - Counts")
GDCdownload(aml.rnaseq.query, method = "client")
aml.rnaseq <- GDCprepare(query = aml.rnaseq.query,
                         save = TRUE,
                         save.filename = "tcga-amlRnaseq.rda",
                         summarizedExperiment = TRUE)

# Download clinical data
aml.clin.query <- GDCquery(project = "TCGA-LAML",
                      data.category = "Clinical")

aml.patient <- GDCprepare_clinic(aml.clin.query, clinical.info = "patient")

# Convert raw count data into matrix, format patient numbers and convert to row names,
# remove extra clinical entries, and then try doing DESeq2 with that

# CHECK EXTRA PATIENT DATA LATER

aml.rnaseq.matrix <- assay(aml.rnaseq)
colnames(aml.rnaseq.matrix) <- sub("TCGA-AB-","",colnames(aml.rnaseq.matrix))
colnames(aml.rnaseq.matrix) <- sub("-.*","",colnames(aml.rnaseq.matrix))
rownames(aml.patient) <- aml.patient[,"patient_id"]
aml.patient.cut <- aml.patient[colnames(aml.rnaseq.matrix),]

# Double check that data match
all(rownames(aml.patient.cut) %in% colnames(aml.rnaseq.matrix))
all(rownames(aml.patient.cut) == colnames(aml.rnaseq.matrix))

# Create DESeq data set and run DEseq2
aml.rnaseq.DE <- DESeqDataSetFromMatrix(countData = aml.rnaseq.matrix,
                                        colData = aml.patient.cut,
                                        design = ~ acute_myeloid_leukemia_calgb_cytogenetics_risk_category)
aml.rnaseq.DE <- DESeq(aml.rnaseq.DE)

# Run DESeq2 on AML count data
#aml.rnaseq.DE <- DESeqDataSet(aml.rnaseq, design = ~ patient)
#aml.rnaseq.DE <- DESeq(aml.rnaseq.DE)


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')

setwd("/Users/mengmengjiang/all datas/chap5")
library(xlsx)

#针头为25G
#n1<-read.xlsx("he-25g.xlsx",sheetName="2kv18",header=TRUE)
#n2<-read.xlsx("he-25g.xlsx",sheetName="2kv54",header=TRUE)
#n3<-read.xlsx("he-25g.xlsx",sheetName="2kv180",header=TRUE)

#读取针头为30g
n1<-read.xlsx("he-30g.xlsx",sheetName="2kv18",header=TRUE)
n2<-read.xlsx("he-30g.xlsx",sheetName="2kv54",header=TRUE)
n3<-read.xlsx("he-30g.xlsx",sheetName="2kv180",header=TRUE)

#针头为32g
n4<-read.xlsx("he-32g.xlsx",sheetName="2kv18",header=TRUE)
n5<-read.xlsx("he-32g.xlsx",sheetName="2kv54",header=TRUE)
n6<-read.xlsx("he-32g.xlsx",sheetName="2kv180",header=TRUE)

#针头为34g
n7<-read.xlsx("he-34g.xlsx",sheetName="2kv18",header=TRUE)
n8<-read.xlsx("he-34g.xlsx",sheetName="2kv54",header=TRUE)
n9<-read.xlsx("he-34g.xlsx",sheetName="2kv180",header=TRUE)

###画图
plot(n1$fv, n1$he_ra, xlab = expression(italic(log(W["ev"]))),
     ylab=expression(italic(D/d["d"])),mgp=c(1.1, 0, 0),tck=0.01,
     xlim=c(-10,1),ylim=c(2,20),col=0)

###颜色###
yan<-rainbow(9)

rho<-(1000*0.5/(3.1415926*3.1415936))

####30g针头下###

#1#18nl-30g##
a<-log(rho*18*18/(n1$fv*60*60*3.1^3))
a1<-1/n1$d_eRn

#2###18nl-32g###
b<-log(rho*18*18/(n2$fv*60*60*2.3^3))
b1<-1/n2$d_eRn

#3#18nl-34G##

c<-log(rho*18*18/(n3$fv*60*60*1.9^3))
c1<-1/n4$d_eRn

#4#54nl-30g##

d<-log(rho*54*54/(n4$fv*60*60*3.1^3))
d1<-1/n3$d_eRn

#5#54nl-32G##
e<-log(rho*54*54/(n5$fv*60*60*2.3^3))
e1<-1/n5$d_eRn

#6#54nl-34G##
f<-log(rho*54*54/(n6$fv*60*60*1.9^3))
f1<-1/n6$d_eRn

#7#180nl-30G##
g<-log(rho*180*180/(n7$fv*60*60*3.1^3))
g1<-1/n7$d_eRn

#8#180nl-32G##
h<-log(rho*180*180/(n8$fv*60*60*2.3^3))
h1<-1/n8$d_eRn

#9#180nl-34G##
i<-log(rho*180*180/(n9$fv*60*60*1.9^3))
i1<-1/n9$d_eRn

###
xx<-c(a,b,c,d,e,f,g,h,i)

pchc<-c(1,2,3,4,5,6,7,22,24)

#画点
points(lowess(a,1/n1$d_eRn,f=1/4,iter=3),col=yan[1],pch=1,lwd=2,lty=2,cex=0.8)
points(lowess(b,1/n2$d_eRn,f=1/4,iter=3),col=yan[2],pch=2,lwd=2,lty=2,cex=0.8)
points(lowess(c,1/n3$d_eRn,f=1/4,iter=3),col=yan[3],pch=3,lwd=2,lty=2,cex=0.8)

points(lowess(d,1/n4$d_eRn,f=1/4,iter=3),col=yan[4],pch=4,lwd=2,lty=2,cex=0.8)
points(lowess(e,1/n5$d_eRn,f=1/4,iter=3),col=yan[5],pch=5,lwd=2,lty=2,cex=0.8)
points(lowess(f,1/n6$d_eRn,f=1/4,iter=3),col=yan[6],pch=6,lwd=2,lty=2,cex=0.8)

points(lowess(g,1/n7$d_eRn,f=1/4,iter=3),col=yan[7],pch=7,lwd=2,lty=2,cex=0.8)
points(lowess(h,1/n8$d_eRn,f=1/4,iter=3),col=yan[8],pch=22,lwd=2,lty=2,cex=0.8)
points(lowess(i,1/n9$d_eRn,f=1/4,iter=3),col=yan[9],pch=24,lwd=2,lty=2,cex=0.8)

##拟合

abline(lm(a1[8:18]~a[8:18]),col=yan[1],lty=4)
abline(lm(b1[10:23]~b[10:23]),col=yan[2],lty=4)
abline(lm(c1[7:18]~c[7:18]),col=yan[3],lty=4)

abline(lm(d1[9:22]~d[9:22]),col=yan[4],lty=4)
abline(lm(e1[7:22]~e[7:22]),col=yan[5],lty=4)
abline(lm(f1[9:22]~f[9:22]),col=yan[6],lty=4)

abline(lm(g1[10:13]~g[10:13]),col=yan[7],lty=4)
abline(lm(h1[10:18]~h[10:18]),col=yan[8],lty=4)
abline(lm(i1[8:20]~i[8:20]),col=yan[9],lty=4)

leg<-c("18nl/min-30G","18nl/min-32G","18nl/min-34G",
       "54nl/min-30G","54nl/min-32G",
       "54nl/min-34G","180nl/min-30G","180nl/min-32G","180nl/min-34G")

legend("topright",legend=leg,col=yan,pch=pchc,bty="n",lwd=1.5,lty=2,inset=.02,cex=0.8)