# This script compares models that have already been run through model.r.

library(forecast)
library(ggplot2)

source('2019-06-19-jsa-type-ch2/init/init_a.r')

chosen_models <- c("BGY-E0-C4-I8000-A0.8-T12",
                   "BGY-E1-C4-I300000-A0.999-T15")
model_param_list <- lapply(chosen_models, function(x) parse_model_identifier(x))
model_dir_list <- lapply(model_param_list[1], function(x) initialize_model_params(x))

results <- list()
theme <- theme_minimal()
plots <- list()
for (i in 1:length(chosen_models)) {

    dir_model_folder <- model_dir_list[i]

    # initial model data
    data_raw <- read.csv(paste0(dir_model_folder, "data.csv"), na.strings=c("")) # original data
    data <- read_rdump(paste0(dir_model_folder, "count_info.data.R"))

    # load zero inflated fits
    load(paste0(dir_model_folder, "fit.data"))       # as "fit"
    zips <- fit; rm(fit)

    # load posterior simulation
    load(paste0(dir_model_folder, "post.data"))      # as "allsim"

    # create data.frame of observed
    cumm <- lapply(seq(data$P), function(ii) { # each group
        data.frame(index=1:data$end[ii],                    # index (offset "year")
                   value=data$counts[ii, ],                 # count
                   cml_value=cumsum(data$counts[ii, ]),     # cumulative
                   off=data$off[ii, ],                      # tax. effort
                   group=ii)}) %>% rbind.fill               # group (e.g. "family")
    cumm$sim <- 0 # set sim to 0 to indicate that it is observed data

    # create data.frame of simulated (interpolated)
    cummsim <- lapply(seq(length(allsim)), function(jj) { # each sim
        lapply(seq(data$P), function(ii) { # each group
            data.frame(index=1:data$end[ii],
                    value=allsim[[jj]][[ii]],
                    cml_value=cumsum(allsim[[jj]][[ii]]),
                    off=data$off[ii, ],
                    group=ii,
                    sim=jj)}) %>% rbind.fill
        }) %>% rbind.fill

    # combine the observed and simmed series
    Z <- rbind(cumm, cummsim)

    # add original year back
    Z$year <- Z$index + min(data_raw$year) - 1

    # merge observed values
    Z <- data.table(Z)
    obs_Z <- Z[sim == 0, c("group", "year", "cml_value")]
    Z2 <- merge(Z, obs_Z, by=c("group", "year"), all.x=T, all.y=T, suffixes=c("_sim", "_obs"))
    Z2 <- Z2[sim!=0]

    # get accuracy
    result <- lapply(unique(Z2$group), function(grp) {
        lapply(unique(Z2$sim), function(s) {
            to_calc <- Z2[group==grp & sim==s]
            data.frame(accuracy(to_calc$cml_value_sim, to_calc$cml_value_obs),
                       group=grp, sim=s)
        })
    })

    results[[i]] <- result
}

# list of models of groups of simulations
formatted <- list()
for (i in 1:length(results)) {
    formatted[[i]] <- lapply(results[[i]], function(grp) {
        rbindlist(lapply(grp, as.data.frame))
    })
}
formatted2 <- list()
mapping <- unique(data.frame(groupname=as.character(data_raw$group),
                             group=as.numeric(data_raw$group)))
for (i in 1:length(results)) {
    formatted2[[i]] <- merge(rbindlist(formatted[[i]]), mapping,
                             by="group", all.x=T, all.y=F)
}

do.call(cbind, lapply(formatted2, function(model) {
    model[, list(MAPE_mean = mean(MAPE)), by=c('groupname')]
}))

do.call(cbind, lapply(formatted2, function(model) {
    model[, list(MAPE_mean = mean(MAPE))]
}))

# https://otexts.com/fpp2/accuracy.html
# https://pkg.robjhyndman.com/forecast/reference/accuracy.html


source("install_required_packages.r")
source("synth_validation_benchmark.r")

library(tictoc)

tic("total")
for(i in 1:15){
  tic(paste("real_data_raw/data_1000_1_run",i,sep = ""))
  benchmark("real_data_raw/data_1000_1",100,100,FALSE,TRUE)
  toc()
}
toc()


######################################################
# Loading tables in R
######################################################

### OTU tables

# Note: This the the rarefied one!
otu <- read.table("otutable_r10k.txt",
                  comment="",
                  header=TRUE,
                  sep="\t",
                  skip=1,
                  as.is=TRUE,
                  check.names=F,
                  row=1)

# View first 2 lines using head()
head(otu, n=2)

# View dimensions
dim(otu)

# Print row names (which are OTU IDs)
row.names(otu)

#Print column names (which are samples IDs the taxonomy header)
colnames(otu)

### Alpha diversity tables

# Read in the alpha diversity table
alpha <- read.table("alpha_diversity.txt",
                    sep='\t',
                    header=TRUE,
                    as.is=TRUE,
                    check.names=FALSE,
                    row=1)

### Beta diversity tables

# Load the beta diversity matrix, notice that we use read.table(),
# but then change from a dataframe to a matrix with as.matrix()
beta <- as.matrix(read.table("weighted_unifrac_dm.txt",
                             sep = "\t",
                             header=T,
                             row = 1,
                             as.is = T,
                             check.names = F))

### Metadata files

metadata <- read.table('mouse_mapfile.txt',
                       header=T,
                       sep='\t',
                       check.names=F,
                       comment='',
                       row=1)

# View the 'Genotype' column of the mapping file dataframe
metadata[,'Genotype']

metadata$Genotype

# The class function will also tell you whether your variable is
# a factor, numeric, character, etc.
class(metadata[,'Genotype'])
```

######################################################
# Formatting the data
######################################################

# First, define all the samples in the OTU table.
# Remember, when we load in the OTU table, samples are columns
# Now let's see what the intersect is with the  metadata row names
IDs_Keep <- intersect(colnames(otu), rownames(metadata))

# Now let's filter the metadata to keep only those samples
# We tell R to make a new data frame that only has the rows we want
metadata <- metadata[IDs_Keep,]

# Now let's filter the OTU table to keep just the intersecting samples

# First, lets rotate the table so the samples are the rows (like the map and alpha)
# We will store it as a new otu table (incase we need the old one)
otu2 <- t(otu)

# This will also remove the taxonomy, because it's not a sample ID we want
otu2 <- otu2[IDs_Keep,]

# Now let's filer the alpha diversity table to keep only those samples
# Alpha diversity has the samples as row names
alpha <- alpha[IDs_Keep, ]

# Now let's filter the beta diversity table to keep only those samples
# Beta diversity has the samples as row names AND column names
# We must filter both the rows and columns
beta <- beta[IDs_Keep,IDs_Keep]

#Let's check to make sure the sample orders match
rownames(metadata) == rownames(otu2)

#Let's see how many samples are in the otu table and mapping
nrow(otu2)
nrow(metadata)

######################################################
# Alpha diversity differences in R
######################################################

### Testing for differences

# Run a test using the shannon index in the alpha diversity table
wilcox.test(alpha$shannon ~ metadata$BMI_Type)

# Note that you would run a t-test in the same way, only using
# the t.test() function

# Now we run a test using the shannon index in the alpha diversity table
kruskal.test(alpha$shannon ~ metadata$Genotype)

# Note that you would run an ANOVA in the same way, only using
# the aov() function

### Plotting the data

#We can also see what box plots of the alpha diversity looks like.

alpha2 <- alpha
alpha2$BMI_Type <- metadata$BMI_Type

library(ggplot2)

ggplot(data=alpha2, aes(x=BMI_Type, y= shannon)) +
  geom_boxplot(outlier.color = NA) + # removes outlier points becuase we add in the jitter anyways
  geom_jitter(width= 0.1, aes(color=BMI_Type), alpha=0.5) +
  theme_bw() +
  guides(color=F) #because the x-axis is already labeled

# We can also print this plot to a pdf with the `pdf()` function followed by `dev.off()` to close the pdf.

plot_output <- ggplot(data=alpha2, aes(x=BMI_Type, y= shannon)) +
  geom_boxplot(outlier.color = NA) +
  geom_jitter(width= 0.1, aes(color=BMI_Type)) +
  theme_bw() +
  guides(color=F)

pdf("Alpha_Diversity.pdf", height=4, width=4)
plot(plot_output)
dev.off()

######################################################
# PCoA in R
######################################################

library(ape)
library(vegan)
library(ggplot2)

### Principal coordinates analysis  (PCoA)

# Run the pcoa() function on the beta diversity table,
# and store the vectors generated as a dataframe
PCOA <- data.frame(pcoa(beta)$vectors)

# If you look at the PCOA table, you'll see the column names
# are the 'axes' and the row names are sample IDs. We want them to
# be labeled "PC" instead of "axis"

# We will make a vector with place holders
new_names <- rep("", ncol(PCOA))

# Fill in first with PC followed by the number (e.g. PC1, PC2, PC3...)
for(i in 1:ncol(PCOA)){
  new_names[i] <- paste("PC",i, sep="")
}

# Replace the column names of PCOA
names(PCOA) <- new_names

# Create a column that is SampleIDS for PCOA
PCOA$SampleID <- rownames(PCOA)

#Create a column that is SampleIDs for the metadata
metadata$SampleID <- rownames(metadata)

# Merge the metadata and beta diversity
PCOA <- merge(PCOA, metadata, by = "SampleID")

### Plotting the PCoA

# Note that geom_point() makes it a scatter plot where the points
# are colored according to BodySite
ggplot(PCOA) +
  geom_point(aes(x = PC1, y = PC2, color = Source)) +
  labs(title="PCoA Plot")

# Now let's add some clusters.  This makes it look great, but can
# also be misleading and make us think there are groups when there
# aren't. Note that we are using BodySite to color the points and body
# AREA to fill the clusters

ggplot(PCOA) +
  geom_point(aes(x = PC1, y = PC2, color = Source)) +
  labs(title="PCoA and Clusters") +
  stat_ellipse(alpha = 0.3, geom="polygon", linetype="blank", aes(x = PC1, y = PC2, fill = Source))

### Changing plotting parameters

colors <- c("darkorchid", "deepskyblue", "darkred", "darkolivegreen")
colors2 <- c("lightblue", "azure3")
ggplot(PCOA, aes(x = PC1, y = PC2)) +
    stat_ellipse(alpha = 0.5, geom="polygon", aes(fill=Source)) +
    geom_point(alpha=0.65, size = 3, aes(color = Genotype)) +
    labs(title="Mouse Microbiome Beta Diversity") +
    scale_color_manual(values= colors) +
    scale_fill_manual(values=colors2) +
    theme(plot.title = element_text(size = 16),
          axis.title = element_text(size = 14),
          axis.text = element_text(size = 12),
          legend.title = element_text(size = 14),
          legend.text = element_text(size = 12)) +
    theme_bw()

### Testing for signifcant differences

# Turn the beta table into resemblance matrix using as.dist()
beta_dist = as.dist(beta)

# Test for a significant difference across all groups.
# This will run an ADONIS test.
ad = adonis(beta_dist ~ metadata[,"Genotype"], data=metadata, permutations=999)
ad

# Now let's write our output to a file.

# This takes just the analysis of variance table (aoc.tab)
# from the output
a.table <- ad$aov.tab

# This writes it to a file
write.table(a.table, file="beta_analysis.txt", quote=FALSE, sep="\t", col.names = NA)


add <- function(a, b)
{
    return a+b
}

add<-function(a,b){return a+b}
add<- function(a,b){x<- a +b;return x}


papi.flips <- function(expr)
{
  papi.check.ncounters(3L)

  ret <- .Call(papi_flips_on)
  if (ret == -1L)
    stop("PAPI failed to initialize hardware counters.\nYour platform may not support floating point operation event.\n")

  eval(expr)

  ret <- .Call(papi_flips_off)
  if (is.integer(ret) && ret == -1L)
    stop("There was a problem recovering the counter information.")

  return( ret )
}

#' flips
#'
#' Measuring floating point instructions.
#'
#' This function measures the evaluation of the provided expression, expr, for
#' real time, process time, number of floating point instructions, and floating
#' point instruction rate. 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 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 return is a list consisting of:
#' \tabular{ll}{
#'    \code{real_time} \tab real time spent evaluating expression \cr
#'    \code{proc_time} \tab total process time spent evaluating expression \cr
#'    \code{flpins} \tab FLoating Point INStructions (count) \cr
#'    \code{mflips} \tab Mflips (flpins per second) \cr
#' }
#'
#' @keywords programming
#'
#' @examples
#' \dontrun{
#' library(pbdPAPI)
#'
#' system.flips(1+1)
#' }
#'
#' @export
system.flips <- function(expr, gcFirst=TRUE, burnin=TRUE)
{
  if (burnin)
    b <- system.flips(gcFirst=gcFirst, burnin=FALSE)

  if (gcFirst)
    invisible(gc(FALSE))

  if (missing(expr))
    expr <- NULL

  events <- "PAPI_FP_INS"
  papi.avail.lookup(events=events, shorthand=FALSE)

  ret <- papi.flips(expr=expr)

  if (burnin)
  {
    for (i in 3:length(ret))
      ret[[i]] <- max(ret[[i]] - b[[i]], 0)
  }

  return( ret )
}


# creates a barplot with errorbars
mybarplot <- function(means,sds,rownames,...) {
	mp <- barplot2(means,plot.grid = TRUE,names.arg=rownames,
	ci.l = means-sds, ci.u = means+sds,plot.ci = TRUE,...)
	box()
}


# Packages ----------------------------------------------------------------
library(here)
library(dplyr)
library(brms)
library(parallel)

# Options -----------------------------------------------------------------
options(mc.cores = detectCores())

# Get data ----------------------------------------------------------------
utla_rt_with_covariates <-
  readRDS(here("data", "utla_rt_with_covariates.rds")) %>%
  filter(week_infection > "2020-10-01") %>%
  mutate(tier = if_else(tier == tier[1], paste0("_", tier), tier)) %>%
  mutate(prop = 1 - prop) %>%
  mutate(tier = if_else(tier == "none", "_none", tier)) %>%
  mutate(positive_samples = as.integer(prop * samples),
         id = 1:n(), positive_prop = NA_real_)

# Define custom family ------------------------------------------------
add_var_student <- custom_family(
  "add_var_student", dpars = c("mu", "sigma", "nu", "alpha"),
  links = c("log", "identity", "identity", "identity"),
  lb = c(NA, 0, 1, 0),
  type = "real",
  vars = "vreal1[n]"
)

stan_funs <- "
real add_var_student_lpdf(real y, real mu, real sigma, real nu, real alpha,
                          real f) {
    real combined_mu = (1 + (alpha - 1) * f) * mu;
    return student_t_lpdf(y | nu, combined_mu, sigma);
                            }
real add_var_student_rng(real mu, real sigma, real nu, real alpha, real f) {
    real combined_mu = (1 + (alpha - 1) * f) * mu;
    return student_t_rng(nu, combined_mu, sigma);
  }
"
stanvars <- stanvar(block = "functions", scode = stan_funs)

# Set up shared priors ----------------------------------------------------
priors <- c(prior(gamma(2, 0.1), class = nu),
            prior(lognormal(0, 1), class = alpha),
            prior(student_t(3, 0, 0.5), class = sigma))

# Set up model ------------------------------------------------------------
base_model <- function(form, iter = 2000, ...) {
  brm(formula = form,
      family = add_var_student,
      stanvars = stanvars,
      warmup = 500, iter = iter, ...)
}

# Fit models --------------------------------------------------------------
fit_models <- function(gt, data, main_only = TRUE, parallel = TRUE,
                       type = c("static", "dynamic"),
                       static_weeks = 1) {
  # filter for target
  dynamic_data <- data %>%
     rename_with(~ sub(paste0("_", gt, "_gt"), "", .x)) %>%
     filter(!is.na(rt_mean))
  static_data <-
    lapply(seq_len(static_weeks),
           function(x) {
             dynamic_data %>%
               filter(week_infection == (max(week_infection) - (x - 1) * 7))
           })

  ##Static model ------------------------------------------------------------
  # set model settings and priors
  static_model <- function(form, i, ...) {
    base_model(form = form, data = static_data[[i]],
               control = list(adapt_delta = 0.95),
               ...)
  }
  # fit models
  static <- list()
  if ("static" %in% type) {
    static[["intercept"]] <-
      lapply(seq_len(static_weeks), function(i) {
        static_model(rt_mean | vreal(prop) ~ 1, i, prior = priors)
      })
    static[["region"]] <-
      lapply(seq_len(static_weeks), function(i) {
        static_model(rt_mean | vreal(prop) ~ nhser_name, i,
                     prior = c(priors,
                               prior(student_t(3, 0, 0.5), class = "b")))
      })
  }

  # Dynamic model -----------------------------------------------------------
  # set model settings and priors
  dynamic_model <- function(form, iter = 2000, ...) {
    base_model(form = form, data = dynamic_data,
               prior = c(priors,
                         prior(student_t(3, 0, 0.5), class = "b")),
               control = list(adapt_delta = 0.95, max_treedepth = 12),
               iter = iter, ...)
  }
  # fit models

  dynamic_models <- list()
  if ("dynamic" %in% type) {
    if (!main_only) {
      dynamic_models[["interventions_only"]] <-
        as.formula(rt_mean | vreal(prop) ~ tier)

      dynamic_models[["interventions"]] <-
        as.formula(rt_mean | vreal(prop) ~ tier +
          retail_and_recreation + transit_stations + workplaces + residential)

      dynamic_models[["interventions_random"]] <-
        as.formula(rt_mean | vreal(prop) ~ tier + (1 | utla_name) +
          retail_and_recreation + transit_stations + workplaces + residential)

      dynamic_models[["interventions_region"]] <-
        as.formula(rt_mean | vreal(prop) ~ tier + nhser_name +
          retail_and_recreation + transit_stations + workplaces + residential)
    }

    dynamic_models[["interventions_random_region"]] <-
      as.formula(rt_mean | vreal(prop) ~ tier + (1 | utla_name) +
        nhser_name + retail_and_recreation + transit_stations + workplaces + residential)

    if (!main_only) {
      dynamic_models[["interventions_time_region"]] <-
        as.formula(rt_mean | vreal(prop) ~ tier + s(time, k = 9) +
                     nhser_name + retail_and_recreation + transit_stations + workplaces + residential)
    }

    dynamic_models[["interventions_time_region_random"]] <-
      as.formula(rt_mean | vreal(prop) ~ tier + s(time, k = 9) +
        (1 | utla_name) + nhser_name +
        retail_and_recreation + transit_stations + workplaces + residential)

    if (!main_only) {
      dynamic_models[["interventions_time_by_region"]] <-
        as.formula(rt_mean | vreal(prop) ~ tier +
          s(time, k = 9, by = nhser_name) +
          retail_and_recreation + transit_stations + workplaces + residential)
    }

    dynamic_models[["interventions_time_by_random_region"]] <-
      as.formula(rt_mean | vreal(prop) ~ tier +
        s(time, k = 9, by = nhser_name) +
        (1 | utla_name) +
        retail_and_recreation + transit_stations + workplaces + residential)

    if (!main_only) {
      dynamic_models[["interventions_independent_time_region"]] <-
        as.formula(rt_mean | vreal(prop) ~ tier + factor(time):nhser_name +
          retail_and_recreation + transit_stations + workplaces + residential)

      dynamic_models[["interventions_independent_time_random_region"]] <-
        as.formula(rt_mean | vreal(prop) ~ tier + factor(time):nhser_name +
          (1 | utla_name) +
          retail_and_recreation + transit_stations + workplaces + residential)
    }

  }

  if (parallel) {
    dynamic <- parallel::mclapply(dynamic_models, dynamic_model)
  } else {
    dynamic <- lapply(dynamic_models, dynamic_model)
  }

  return(list(models = list(static = static, dynamic = dynamic),
              data = list(static = static_data, dynamic = dynamic_data)))
}

# fit models
gt <- c("short", "long")
res <- lapply(gt, fit_models,
              data = utla_rt_with_covariates,
              type = c("static", "dynamic"),
              static_weeks = 6)
names(res) <- gt

# Save fits ---------------------------------------------------------------
output_path <- here("output")
dir.create(output_path, recursive = TRUE, showWarnings = FALSE)

save_results <- function(name) {
  saveRDS(res[[name]],
          here::here("output", paste0("sgene_fits_", name, "_gt.rds")))
}
lapply(gt, save_results)


library(Gviz)

gviz_data_track <- function(bw, title, track_color, max_value) {

  reg_track <- DataTrack(range=bw,
                         genome="dm3", name=title,
                         type="polygon",
                         ylim=c(0, max_value),
                         col=track_color,
                         fill.mountain=c(track_color, track_color))
  reg_track
}

max_value <- function(bw, region.gr) {
  stopifnot(length(bw) == 1)
  stopifnot(length(region.gr) == 1)
  regionMaxs(region.gr, bw)
}

gviz_dual_data_track <- function(m.bw, de.bw, region.gr, title, colors, max_value) {

  colors %<>% rev
  colors <- c(colors, "black")

  data_matrix <- c(unlist(import(m.bw,  which=region.gr, as="NumericList")),
                   unlist(import(de.bw, which=region.gr, as="NumericList")),
                   rep(0, times=width(region.gr))) %>%
                 matrix(nrow=3, byrow=TRUE)

  data_matrix[, c(1, ncol(data_matrix))] <- 0

  reg_track <- DataTrack(data=data_matrix,
                         start=start(region.gr):end(region.gr), width=0, #ncol(data_matrix),
                         chromosome=as.character(seqnames(region.gr)),
                         genome="dm3", name=title,
                         groups=c("Toll10b", "gd7", "zero"),
                         type="a",#alpha=0.5,
                         ylim=c(0, max_value),
                         legend=TRUE,
                         col.mountain=colors, fill.mountain=colors, col.line=colors, col=colors)
  reg_track
}


#' Horton Laws
#'
#' calculates network area, length and bifurcation ratios, using (\code{lm(...)})
#'
#' requires /NHDPlusAttributes directory (see \code{net_nhdplus})
#'
#' Horton estimates (\code{$Horton_est}) include network - 1 (i.e \code{$ohm})
#' because a given group.comid, may not include the whole stream order
#'
#' @param netdelin output from \code{net_delin}
#' @param vpu vector processing unit
#' @param nhdplus_path Directory for NHDPlusV2 files (\code{\link{net_nhdplus}}
#'
#' @return named \code{list}: \code{$topology} is data used to estimate horton
#'   laws: \code{$group.comid} root COMID for steam network; \code{$str_ord}
#'   stream order; \code{$str_num} count of stream reaches,\code{str_len} Mean
#'   reach length; \code{str_area} mean drainage area. \code{$horton_est} are
#'   estimated horotn ratios: \code{ohm} is the strahler order of the network -
#'   1 (see \code{Details}. \code{$Rb,$Rl,$Ra} are bifurcation, length and area
#'   ratios, respectively. \code{Rb.r2, Rl.r2, Ra.r2} are R^2 values from
#'   \code{lm(...)}.
#'
#' @examples
#' # identify NHDPlusV2 COMID
#' a <- net_sample(nhdplus_path = getwd(), vpu = "01", ws_order = 6, n = 5)
#' # delineate stream network
#' b <- net_delin(group_comid = as.character(a[,"COMID"]), nhdplus_path = getwd(), vpu = "01")
#' #estimate horton ratios
#' c <- net_hort(netdelin = b, vpu = "01", nhdplus_path = getwd())
#' @export

net_hort<-function (netdelin, vpu, nhdplus_path){

  if(!is.character(vpu)){
    stop("vpu must be character")
  }

  directory<-grep(paste(vpu,"/NHDPlusAttributes",sep=""),
                  list.dirs(nhdplus_path,full.names=T),
                  value = T)

  vaa<-grep("PlusFlowlineVAA.dbf",
            list.files(directory[1], full.names = T),
            value = T)

  vaa<-foreign::read.dbf(vaa)
  names(vaa) <- toupper(names(vaa))

  #M measures and net.id become unnecessary.
  #the focal ohm is the group comid - 1.
  if(any(duplicated(netdelin$Network[, c("group.comid", "net.comid")]))){
    warning ("FYI droping M and net.id values, group.comid is network index")
  }

  full.net <- unique(netdelin$Network[,c("group.comid", "net.comid", "vpu")])

  vaa <- merge(full.net, vaa, by.x = "net.comid", by.y = "COMID")

  warn_mess <- vaa[as.character(vaa[ ,"group.comid"]) ==
                     as.character(vaa[ ,"net.comid"]),
                   c("net.comid","STREAMORDE")]

  #remove diveregences
  vaa <- vaa[vaa[,"STREAMORDE"] == vaa[, "STREAMCALC"], ]
  names(vaa)

  data<-data.frame(group.comid = character(), str_ord = integer(),
                   str_num = integer(), srt_len = numeric(),
                   str_area = numeric())

  hor.laws <- data.frame(group.comid = character(), ohm = numeric(),
                         Rb = numeric(), Rb.r2 = numeric(),
                         Rl = numeric(), Rl.r2 = numeric(),
                         Ra = numeric(), Ra.r2 = numeric())

  for (q in unique(full.net[,"group.comid"])){
    a <- vaa[vaa[,"group.comid"] == q,
             c("group.comid", "net.comid",
               "STREAMORDE", "LEVELPATHI",
               "TONODE", "FROMNODE","HYDROSEQ",
               "TOTDASQKM", "LENGTHKM", "AREASQKM")]

  for (p in unique(a[,"STREAMORDE"])){
    #p<-1
    # z is a list of each flowline of a given order stream order w/ From - To path
    z <- a[a[,"STREAMORDE"] == p, ]
    z <- split(z,list(z[,"LEVELPATHI"],as.character(z[,"group.comid"])))
    TOO <- lapply(z,"[[","TONODE")
    FRO <- lapply(z,"[[","FROMNODE")

    for (i in length(z):1){
      #i<-1
      #with element i, compare tonode to all fromnodes not i
      #upsrt connection
      TOO_ULi <- unlist(TOO[i], use.names=F)
      FRO_UL <- unlist(FRO[-i], use.names = F)
      TOO_ULi <- TOO_ULi[TOO_ULi %in% FRO_UL]

      if(length(TOO_ULi) > 0){
        TOO_ULi<-sapply(lapply(z,"[[",c("FROMNODE")), function(x) x %in% TOO_ULi)
      if(length(dim(TOO_ULi))>0){
        TOO_ULi<-apply(TOO_ULi,2,function(x) any(x))
      } else {
        TOO_ULi<-sapply(TOO_ULi,function(x) any(x))
      }
      z[[ifelse(which(TOO_ULi), names(which(TOO_ULi)))]]["LEVELPATHI"] <- unique(z[[i]]["LEVELPATHI"])
      }

      #with element i, compare fromnodes to all tonodes not i
      #downstr connection
      FRO_ULi <- unlist(FRO[i], use.names = F)
      TOO_UL <- unlist(TOO[-i], use.names = F)
      FRO_ULi <- FRO_ULi[FRO_ULi%in%TOO_UL]

      if(length(FRO_ULi) > 0){
      #which element in -i matches
      FRO_ULi <- sapply(lapply(z, "[[", c("TONODE")), function(x) x %in% FRO_ULi)
      if(length(dim(FRO_ULi)) > 0){
        FRO_ULi <- apply(FRO_ULi, 2, function(x) any(x))
      } else {
        FRO_ULi <- sapply(FRO_ULi, function(x) any(x))
      }
      z[[ifelse(which(FRO_ULi), names(which(FRO_ULi)))]]["LEVELPATHI"] <- unique(z[[i]]["LEVELPATHI"])
      }
    }

    z <- setNames(do.call(rbind.data.frame, z), names(z[[1]]))
    z <- split(z, list(z[, "LEVELPATHI"], as.character(z[, "group.comid"])))

    #spply aggregares list element
    #naming w/comid
    L <- sapply(lapply(z, "[","LENGTHKM"), sum)
    group.comid <- unlist(lapply(strsplit(names(L), "\\."), "[[", 2))
    L <- data.frame(group.comid = group.comid, L = L, row.names = NULL)
    L <- aggregate(L[,"L"],by = list(group.comid = L[,"group.comid"]), mean)
    names(L)[2] <- "str_len"

    #A <- sapply(lapply(z, "[[", "AREASQKM"), sum)
    A <-  sapply(lapply(z, "[[", "TOTDASQKM"), max)
    group.comid <- unlist(lapply(strsplit(names(A), "\\."), "[[", 2))
    A <- data.frame(group.comid = group.comid, A = A, row.names = NULL)
    A <- aggregate(A[,"A"], by = list(group.comid = A[, "group.comid"]), mean)
    names(A)[2] <- "str_area"

    N <- sapply(lapply(z, "[[", 7), length)
    group.comid <- unlist(lapply(strsplit(names(N), "\\."), "[[", 2))
    N <- data.frame(group.comid = group.comid, N = N, row.names = NULL)
    N <- aggregate(N[,"N"], by = list(group.comid = N[, "group.comid"]), length)
    names(N)[2] <- "str_num"

  temp <- Reduce(function(x, y)
    merge(x, y,by = c("group.comid"), all.x = T), list(N, L, A))

  data <- rbind(data, data.frame(str_ord = p, temp))
  }

      horton <- data[data[,"group.comid"] == q, ]
      # drops the comid because it may be incomplete.
      # a 5th order comid could occur in middle of reach
      # also cannot horton ratios from 1 data point...
      # probably should for 2 eiither, especially
      # since we dont know if the comid includes whole path

      if (length(horton[,"group.comid"]) > 2){
        # for instance: Nw=stream number of order w;
        # Rb^ohm-w is bifurcation ratio (i.e. constant)
        # raised to watershed order minus the order (w)
        # thus Nw=Rb^ohm-w #here i estimate that constant value (Rb)
        # take log to linear model
        # log(Nw)= ohm*logRb-w*logRb
        # log(Nw)=log(Rb)*(ohm-w)

        horton <- horton[horton[,"str_ord"] != max(horton[,"str_ord"]), ]
        ohm <- max(horton[, "str_ord"])
        x <- ohm - horton[, "str_ord"]

        # estimate log(Rb) as slope
        lmRb <- summary(lm(log(horton[,"str_num"]) ~ (x)))
        # log(Rb)=0.9367344; log() has default base of exp(1)
        # thus slove for Rb w/base e
        Rb <- exp(lmRb$coefficients["x", 1])
        lmRb.r.squared <- (lmRb$r.squared)

        #Lw=L1*RL^(w-1)
        x <- horton[, "str_ord"] - 1
        L1 <- rep(horton[horton[,"str_ord"] ==1, "str_len"], length(horton[, "str_len"]))
        lmRl <- summary(lm(log(horton[, "str_len"]) ~ log(L1) + (x)))
        Rl <- exp(lmRl$coefficients["x", 1])
        lmRl.r.squared <- (lmRl$r.squared)

        #Aw=A1*RA^(w-1)
        x <- horton[,"str_ord"] - 1
        A1 <- rep(horton[horton[,"str_ord"] == 1, "str_area"], length(horton[, "str_area"]))
        lmRa <- summary(lm(log(horton[, "str_area"]) ~ log(A1) + (x)))
        Ra <- exp(lmRa$coefficients["x", 1])
        lmRa.r.squared <- (lmRa$r.squared)
        group.comid <- q

        out <- data.frame(COMID = group.comid, ohm = ohm,
                          Rb = Rb, Rb.r2 = lmRb.r.squared,
                          Rl = Rl, Rl.r2 = lmRl.r.squared,
                          Ra = Ra, Ra.r2 = lmRa.r.squared)

        hor.laws <- rbind(hor.laws, out)
        } else {
          ohm <- max(horton[,"str_ord"])-1
          out <- data.frame(COMID = q, ohm = ohm,
                            Rb = NA, Rb.r2 = NA,
                            Rl = NA, Rl.r2 = NA,
                            Ra = NA, Ra.r2 = NA)

          hor.laws <- rbind(hor.laws, out)
          }
  }

  names(hor.laws)[1] <- "group.comid"

  data.out <- list(topology = data[,c("group.comid","str_ord", "str_num", "str_len", "str_area")],
                   Horton_est = hor.laws)

  warn <- merge(warn_mess[,c("net.comid","STREAMORDE")],
                hor.laws[,c("group.comid","ohm")],
                by.x = "net.comid", by.y = "group.comid")

  if (any(warn[,"STREAMORDE"]-1 != warn[,"ohm"])){
    #this is caused by incorrect stream order in network
    id<-as.character(warn[warn[,"STREAMORDE"]-1 != warn[,"ohm"], "net.comid"])
    warning(paste("group.comid", id, "estimates may be inaccurate due to incorrect NHDPlusV2 vaa STREAMORDER"))
  }

  return(data.out)
  }


#my_truth---plots time series for every file of autocorrealtions
#N0t work in R-studio

rm(list=ls())
pret<-NULL

shardul_vikridit<-list.files("N:\\Project_Data_Sagar\\my_truth\\single_pot_sangram_clipso\\")

for( sony in shardul_vikridit){

jai<-read.table(paste("N:\\Project_Data_Sagar\\my_truth\\single_pot_sangram_clipso\\",sony,sep=""))

species<-substr(sony,1,nchar(sony)-4)   #file name
acf(jai$V1,main=paste("ACF plot",species),col="red")    #ACF plotting

savePlot(paste("N:\\Project_Data_Sagar\\my_truth\\acf_sangram_clipso\\",species,sep=""),type="jpeg")

    }   #main for ends
___________________________________________________________________________________________________________________________________________
#plots PACF
rm(list=ls())
pret<-NULL

shardul_vikridit<-list.files("N:\\Project_Data_Sagar\\my_truth\\single_pot_sangram_clipso\\")

for( sony in shardul_vikridit){

jai<-read.table(paste("N:\\Project_Data_Sagar\\my_truth\\single_pot_sangram_clipso\\",sony,sep=""))

species<-substr(sony,1,nchar(sony)-4)   #file name
pacf(jai$V1,main=paste("PACF plot",species),col="red")    #ACF plotting

savePlot(paste("N:\\Project_Data_Sagar\\my_truth\\pacf_sangram_clipso\\",species,sep=""),type="jpeg")

    }   #main for ends


# 3. faza: Vizualizacija podatkov

library(ggplot2)
library(dplyr)
library(tmap)
library(rgdal)
library(tidyr)
library(rgeos)
library(ggpubr)
library(digest)
library(mosaic)
library(maptools)
library(readr)
library(tmaptools)
library(RColorBrewer)
library(scales)

# Uvozimo zemljevid.
#zemljevid <- uvozi.zemljevid("http://baza.fmf.uni-lj.si/OB.zip", "OB",
#                             pot.zemljevida="OB", encoding="Windows-1250")
#levels(zemljevid$OB_UIME) <- levels(zemljevid$OB_UIME) %>%
#  { gsub("Slovenskih", "Slov.", .) } %>% { gsub("-", " - ", .) }
#zemljevid$OB_UIME <- factor(zemljevid$OB_UIME, levels=levels(obcine$obcina))
#zemljevid <- fortify(zemljevid)

# Izračunamo povprečno velikost družine
#povprecja <- druzine %>% group_by(obcina) %>%
#  summarise(povprecje=sum(velikost.druzine * stevilo.druzin) / sum(stevilo.druzin))

# stolpični graf POVPREČNI TRANSPORT V 9 LETIH PO DRŽAVAH

povprecje_blaga <- evropa_promet  %>% group_by(Države) %>%
  summarise(`povprecje blaga` = sum(Blago)/9)

povprecje_potnikov <- evropa_promet  %>% group_by(Države) %>%
  summarise(`povprecje potnikov` = sum(Potniki)/9)

graf_evropa_blago <- ggplot(data = povprecje_blaga, mapping = aes(x= Države, y= `povprecje blaga`)) +
  geom_bar(stat = 'identity', position = 'dodge') +
  theme(axis.text.x = element_text(angle = 90, size = 8, hjust = 1)) +
  ggtitle('Povprečni transport blaga v 9 letih po državah') +
  ylab('Povprečje blaga')

graf_evropa_potniki <- ggplot(data = povprecje_potnikov, mapping = aes(x= Države, y= `povprecje potnikov`)) +
  geom_bar(stat = 'identity', position = 'dodge') +
  theme(axis.text.x = element_text(angle = 90, size = 8,hjust = 1)) +
  ggtitle('Povprečni transport potnikov v 9 letih po državah')+
  ylab('Povprečje potnikov')

graf_evropa <- ggarrange(graf_evropa_blago, graf_evropa_potniki)

# linijski grafi za uvoz in izvoz blaga in potnikov

graf_uvoz_blago <- ggplot(blagovni_promet %>% filter(tovor == "uvoz"),
                          aes(x=leto, y=tone, color=tip)) + geom_line() +
  ggtitle("Uvoz blaga")+
  ylab('tone (1000)')+
  xlab('leto')

graf_izvoz_blago <- ggplot(blagovni_promet %>% filter(tovor == "izvoz"),
                          aes(x=leto, y=tone, color=tip)) + geom_line() +
  ggtitle("Izvoz blaga")+
  ylab('tone (1000)')+
  xlab('leto')

graf_uvoz_potnikov <- ggplot(potniski_promet %>% filter(tovor == 'uvoz'),
                              aes(x=leto, y = potniki, color = tip))+ geom_line() +
  ggtitle('Uvoz potnikov') +
  ylab('potniki (1000)')+
  xlab('leto')

graf_izvoz_potnikov <- ggplot(potniski_promet %>% filter(tovor == 'izvoz'),
                              aes(x=leto, y = potniki, color = tip))+ geom_line() +
  ggtitle('Izvoz potnikov') +
  ylab('potniki (1000)')+
  xlab('leto')

#ZEMLJEVIDI

evropski_blagovni_promet_2018 <- filter(evropski_blagovni_promet, Leto == '2018')
evropski_potniski_promet_2018 <- filter(evropski_potniski_promet, Leto == '2018')
data(World)

evropa <- filter(World, continent == "Europe") %>%
  rename(Države = name)

podatki <- merge(evropa, evropski_blagovni_promet_2018, by="Države", all.x=TRUE) %>%
  rename(drzava=Države)
podatki2 <- merge(evropa, evropski_potniski_promet_2018, by='Države', all.x=TRUE) %>%
  rename(drzava = Države)

zemljevid_blagovnega_prometa <- tm_shape(podatki %>% set_projection("latlong"),
                                         xlim=c(-15, 35), ylim=c(32, 72)) +
  tm_polygons("Blago") + tm_legend(legend.position=c("left", "top"))

zemljevid_potniskega_prometa <- tm_shape(podatki2 %>% set_projection("latlong"),
                                         xlim=c(-15, 35), ylim=c(32, 72)) +
  tm_polygons("Potniki") + tm_legend(legend.position=c("left", "top"))

#primer iz vaj
#source("https://raw.githubusercontent.com/jaanos/APPR-2019-20/master/lib/uvozi.zemljevid.r")
#data("World")
#svet <- tm_shape(World) + tm_polygons("HPI")
#print(svet)


./tests.verify: test performed on 2003.08.28

#### Test: ./tests.verify running ./make_module_1.sh
['__doc__', '__file__', '__name__', 'gridloop1', 'gridloop2']
CPU time of ./make_module_1.sh: 3.5 seconds on hpl-lapx30 i686, Linux

#### Test: ./tests.verify running ../../Grid2Deff.py verify1
f1...x-y= [[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
f1...x-y= 0.0
f1...x-y= 2.0
f1...x-y= 0.5
f1...x-y= 2.5
f1...x-y= 1.0
f1...x-y= 3.0
f computed by external gridloop1 function:
[[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
f is correct
Creating array(3,2)
f1...x-y= 0.0
f1...x-y= 2.0
f1...x-y= 0.5
f1...x-y= 2.5
f1...x-y= 1.0
f1...x-y= 3.0
f computed by external gridloop2 function:
[[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
f is correct
array seen from Python:
value at (0,0)  	 = a[0,0] = 0
value at (0,1)  	 = a[0,1] = 2
value at (0.5,0)  	 = a[1,0] = 0.5
value at (0.5,1)  	 = a[1,1] = 2.5
value at (1,0)  	 = a[2,0] = 1
value at (1,1)  	 = a[2,1] = 3
CPU time of ../../Grid2Deff.py: 0.3 seconds on hpl-lapx30 i686, Linux

#### Test: ./tests.verify running ../../Grid2Deff.py exceptions1
exceptions.ValueError a is not of type 'Float'
exceptions.ValueError NumPy array is 1-dimensional; expected 2 dimensions
exceptions.TypeError Not a callable object
CPU time of ../../Grid2Deff.py: 0.3 seconds on hpl-lapx30 i686, Linux


library(dplyr)

library(purrr)
library(magrittr)

iris %>% group_by(Species) %>%select(1:4) %>% summarize(meanSL=mean(Sepal.Length),meanSW=mean(Sepal.Width),meanPW=mean(Petal.Width),meanPL=mean(Petal.Length))


#
# QES_1.0_Extract.R - Global Equity Markets
#

#
library (Quandl)
library (quantmod)
library (timeSeries)
library (zoo)

#
# Define scenario start and end dates
#
scenario_start_date             <-'2003-12-01'
scenario_end_date               <-'2018-05-11'

#
# Define working storage
#
scenario_name               <-'QES'
scenario_version_number     <-'1.0'
filename_base               <-paste(scenario_name,scenario_version_number,sep="_")
filename_assets             <-paste(scenario_name,scenario_version_number,"assets.csv",sep="_")
filename_daily_data         <-paste(scenario_name,scenario_version_number,"ddata.csv",sep="_")
filename_daily_prices       <-paste(scenario_name,scenario_version_number,"dprices.csv",sep="_")
filename_daily_prices_raw   <-paste(scenario_name,scenario_version_number,"dprices_raw.csv",sep="_")
filename_daily_returns      <-paste(scenario_name,scenario_version_number,"dreturns.csv",sep="_")
filename_weekly_data        <-paste(scenario_name,scenario_version_number,"wdata.csv",sep="_")
filename_weekly_prices      <-paste(scenario_name,scenario_version_number,"wprices.csv",sep="_")
filename_weekly_returns     <-paste(scenario_name,scenario_version_number,"wreturns.csv",sep="_")
filename_monthly_data       <-paste(scenario_name,scenario_version_number,"mdata.csv",sep="_")
filename_monthly_prices     <-paste(scenario_name,scenario_version_number,"mprices.csv",sep="_")
filename_monthly_returns    <-paste(scenario_name,scenario_version_number,"mreturns.csv",sep="_")
filename_quarterly_data     <-paste(scenario_name,scenario_version_number,"qdata.csv",sep="_")
filename_quarterly_prices   <-paste(scenario_name,scenario_version_number,"qprices.csv",sep="_")
filename_quarterly_returns  <-paste(scenario_name,scenario_version_number,"qreturns.csv",sep="_")
filename_yearly_data        <-paste(scenario_name,scenario_version_number,"ydata.csv",sep="_")
filename_yearly_prices      <-paste(scenario_name,scenario_version_number,"yprices.csv",sep="_")
filename_yearly_returns     <-paste(scenario_name,scenario_version_number,"yreturns.csv",sep="_")

#
# Establish authorization with Quandl
#
Quandl.api_key("Quandl API Key Goes Here")

#
# Read asset names from asset names file
#
assetdata.df <-read.csv(file=filename_assets,head=TRUE,sep=",")

#
# Select daily prices
#
dprices.xts <-Quandl(c(
'FRED/DTB3.1',
'NASDAQOMX/NQGI.1',
'NASDAQOMX/NQAU.1',
'NASDAQOMX/NQCA.1',
'NASDAQOMX/NQCN.1',
'NASDAQOMX/NQCZ.1',
'NASDAQOMX/NQEG.1',
'NASDAQOMX/NQFI.1',
'NASDAQOMX/NQFR.1',
'NASDAQOMX/NQDE.1',
'NASDAQOMX/NQGR.1',
'NASDAQOMX/NQHK.1',
'NASDAQOMX/NQIN.1',
'NASDAQOMX/NQID.1',
'NASDAQOMX/NQIL.1',
'NASDAQOMX/NQJP.1',
'NASDAQOMX/NQKR.1',
'NASDAQOMX/NQMY.1',
'NASDAQOMX/NQNL.1',
'NASDAQOMX/NQPH.1',
'NASDAQOMX/NQPL.1',
'NASDAQOMX/NQPT.1',
'NASDAQOMX/NQRU.1',
'NASDAQOMX/NQSG.1',
'NASDAQOMX/NQES.1',
'NASDAQOMX/NQSE.1',
'NASDAQOMX/NQCH.1',
'NASDAQOMX/NQTW.1',
'NASDAQOMX/NQTH.1',
'NASDAQOMX/NQTR.1',
'NASDAQOMX/NQGB.1'
),
type="xts",
order="asc",
start_date = '2003-12-01',
end_date = '2018-05-11'
)
head(dprices.xts)
tail(dprices.xts)

#
# Write daily prices
#
colnames (dprices.xts) <-assetdata.df[,2]
write.zoo(dprices.xts,filename_daily_prices_raw,index.name="Date",row.names=FALSE,col.names=TRUE,sep=",",append=FALSE)

#
# Read daily price data
#
prices.tS            <-as.timeSeries(dprices.xts)
prices.tS            <-window(prices.tS, start = scenario_start_date , end = scenario_end_date)
prices.tS            <-timeSeries(prices.tS) #, zone="America/New_York",FinCenter="America/New_York")
prices.ALN           <-align(x=prices.tS,by='1d',method='before',include.weekends=FALSE)
prices.tS            <-prices.ALN
prices.xts           <-as.xts(prices.tS)
head(dprices.xts)
tail(dprices.xts)

#
# Compute returns for Rmetrics - timeSeries
#
returns.tS <-returns(prices.tS,method = 'discrete')

#
# Set non finite values (NaN, -Inf, Inf) to zero
#
which(!is.finite(returns.tS))
returns.tS[which(!is.finite(returns.tS))]<-0
which(!is.finite(returns.tS))
returns100.tS <-100 * returns.tS

#
# Define prices and returns for performance analytics - xts
#
prices.xts  <-as.xts(prices.tS)
returns.xts <-as.xts(returns.tS)

#
# Write output files
#
write.zoo(as.xts(prices.tS),filename_daily_prices,index.name='Date',sep=",")
write.zoo(as.xts(returns.tS),filename_daily_returns,index.name='Date',sep=",")

#

#
# End of job
#


# PAWS preprocessing - habitat
# Lily Xu
# December 2018

# few important functions
#aggregate(),setextent(),resample()

### setup
library(sp)
library(raster)
library(rgdal)
library(gdalUtils)
library(maptools)

outFilepath  <- paste(path, outputPath, "habitat/", sep="")

# create 'habitat' folder if it does not exist
if (!dir.exists(outFilepath)) {
  dir.create(outFilepath)
}

#if you have HDF file and want to convert it to .tif file
#sds <- get_subdatasets("MCD12Q1.A2013001.h18v08.051.2014308191113.hdf")
#gdal_translate(sds[1],dst_dataset = "anything.tif")

visualizeAndSave <- function(outFilepath, raster, filename, boundary) {
  # mask tif according to boundary
  raster <- mask(raster, boundary)

  # visualize
  png(file=paste(outFilepath, "plot_", filename, ".png", sep=""),
      width=800, height=600)
  plot(raster, main=filename)
  lines(boundary)
  dev.off()

  rasterCSV <- rasterToPoints(raster)
  rasterCSV <- as.data.frame(rasterCSV)

  # ensure x, y values are ints, not floats
  rasterCSV["x"] <- round(rasterCSV["x"], 0)
  rasterCSV["y"] <- round(rasterCSV["y"], 0)

  write.csv(rasterCSV, file=paste(outFilepath, filename, ".csv", sep=""))
}

calculateSlope <- function(elevationMapFilename, rast, crs_use, outFilepath) {
  # read tif file and boundary
  elevationMap <- raster(elevationMapFilename)
  elevationMap <- projectRaster(elevationMap, crs=crs_use, method="bilinear")

  slopeMap <- terrain(elevationMap, opt="slope")

  # resample it to get the same dimensions
  slopeMap <- resample(slopeMap, rast, method="bilinear")

  # set any NA values to 0
  slopeMap[is.na(slopeMap)] <- 0

  visualizeAndSave(outFilepath, slopeMap, "slope_map", boundary)
}

# discretize provided image, like elevation map or geoTIFF
discretizeImage <- function(imageFilename, name, boundary, rast, crs_use) {
  # read tif file
  image <- raster(imageFilename)
  image <- projectRaster(image, crs=crs_use, method="bilinear")

  # resample it to get the same dimensions
  image <- resample(image, rast, method="bilinear")

  visualizeAndSave(outFilepath, image, name, boundary)
}

# used to read elevation map, Google Earth Engine GeoTIFF output (like GPP)
discretizeImageNoSave <- function(imageFilename, boundary, rast, crs_use) {
  # read tif file
  image <- raster(imageFilename)
  image <- projectRaster(image, crs=crs_use, method="bilinear")

  # resample it to get the same dimensions
  image <- resample(image, rast, method="bilinear")

  # mask tif according to boundary
  image <- mask(image, boundary)

  imageDataFrame <- as.data.frame(image, xy=TRUE)
  imageDataFrame <- na.omit(imageDataFrame)

  # # ensure x, y values are ints, not floats
  # imageDataFrame["x"] <- round(imageDataFrame["x"], 0)
  # imageDataFrame["y"] <- round(imageDataFrame["y"], 0)

  return(imageDataFrame)
}

# extract month-by-month data from GeoTIFF images
getMonthlyGeotiff <- function(boundary, rast, start_year, end_year, crs_use) {
  for (year in start_year:end_year) {
    # # last year may not be complete?
    # if (year == end_year) {
    #   months = 1:end_month
    # } else {
    #   months = 1:12
    # }
    for (month in 1:12) {
      imageFilename <- print(sprintf("~/Downloads/large_GPP/GPP_%04d_%d.tif", year, month))

      image <- discretizeImageNoSave(imageFilename, boundary, rast, crs_use)

      # if first iteration
      if (year == start_year & month == 1) {
        allMonths <- image[,ncol(1:2)]
      }

      # last column of data frame
      allMonths[sprintf("%04d_%02d", year, month)] <- image[,ncol(image)]
    }
  }

  write.csv(allMonths, paste(outFilepath, "GPP.csv", sep=""))
}

# generally we'd always use slope, not elevation map
discretizeElevationMap <- function(elevationMapFilename, boundary, rast, crs_use) {
  discretizeImage(elevationMapFilename, "elevation_map", boundary, rast, crs_use)
}

discretizeForestCover <- function(forestCover, rast, outFilepath, crs_use) {
  forestCover <- spTransform(forestCover, CRS(crs_use))

  # background=0 will set missing values (gaps) to 0
  forestCoverRaster <- rasterize(forestCover, rast, "NEW_FCODE", background=0)

  visualizeAndSave(outFilepath, forestCoverRaster, "forest_cover", boundary)
}

rast <- loadGridRast(gridFilename, crs_use)
calculateSlope(elevationMapFilename, rast, crs_use, outFilepath)
discretizeElevationMap(elevationMapFilename, boundary, rast, crs_use)
discretizeForestCover(forestCover, rast, outFilepath, crs_use)


# BASGRA Parameter check

library(matrixStats)
library(tidyverse)
library(kableExtra)
# library(broom)
# library(flextable)

outfile <- "check_variables"

# my parameter files
my_par <- arrange(read_tsv(paste(scenario, "/parameters_All.txt", sep="")), PARAMETER) %>%
  mutate(NZMIN=pmin(Scott, Lincoln, Northland),
         NZMAX=pmax(Scott, Lincoln, Northland))
my_bc <- arrange(read_tsv(paste(scenario, "/parameters_BC.txt", sep=""), skip=1, col_names=FALSE), X1)
names(my_bc) <- c("PARAMETER", "MIN", "MODE", "MAX", "SHAPE", "SITES")

# check against fortran parameter list (order matters)
my_par_raw <- read_tsv(paste(scenario, "/parameters_All.txt", sep=""))
for_par <- tibble(line=readLines("model/set_params.f90")) %>%
  filter(str_detect(line, "=[:blank:]pa\\(")) %>%
  mutate(var=str_extract(line,"[:alnum:]+"),
         pa=str_extract(line,"pa\\([:digit:]+\\)"),
         index=as.numeric(str_sub(pa,4,-2)))
stopifnot(all(my_par_raw$PARAMETER==for_par$var)) # check my_par matches fortran

# check fortan output list
out_var <- read_tsv("model/output_names.tsv")
for_out<- tibble(line=readLines("model/BASGRA.f90")) %>%
  filter(str_detect(line, "y\\(day,[:space:]*[:digit:]+\\)")) %>%
  mutate(yday=str_extract(line,"y\\(day,[:space:]*[:digit:]+\\)"),
         index=as.numeric(str_sub(yday,7,-2)),
         rhs=str_sub(str_extract(line,"=\\s.+"),3,-1),
         var=str_extract(rhs,"[:alnum:]+")
  )
stopifnot(all(out_var$varname==for_out$var)) # check out_var matches fortran

# variables Simon renamed
newnames <- c("K"="KLAI", "SHAPE"="LSHAPE", "gamma"="KTSNOW")

# official parameter files (original version)
orig_par <- read_tsv("model_inputs/parameters_Gri_Saerheim.txt", skip=1, col_names=FALSE)
names(orig_par) <- c("PARAMETER", paste("SITE", 1:(ncol(orig_par)-1), sep=""))
orig_par$MINSITE <- rowMins(as.matrix(orig_par[,2:ncol(orig_par)]))
orig_par$MAXSITE <- rowMaxs(as.matrix(orig_par[,2:ncol(orig_par)]))
i <- match(names(newnames), orig_par$PARAMETER)
orig_par$PARAMETER[i[!is.na(i)]] <- newnames[!is.na(i)]
orig_par <- arrange(orig_par, PARAMETER)
orig_bc <- read_tsv("model_inputs/parameters_BC_Gri_Saerheim.txt", col_names=FALSE)
names(orig_bc) <- c("PARAMETER", "MIN", "MODE", "MAX", "SITES")
i <- match(names(newnames), orig_bc$PARAMETER)
orig_bc$PARAMETER[i[!is.na(i)]] <- newnames[!is.na(i)]
orig_bc <- arrange(orig_bc, PARAMETER)

# official parameter files (nutritive version)
new_par <- read_tsv("model_inputs/parameters_Saerheim_nutritive.txt", skip=1, col_names=FALSE)
names(new_par) <- c("PARAMETER", paste("SITE", 1:(ncol(new_par)-1), sep=""))
new_par$MINSITE <- rowMins(as.matrix(new_par[,2:ncol(new_par)]))
new_par$MAXSITE <- rowMaxs(as.matrix(new_par[,2:ncol(new_par)]))
i <- match(names(newnames), new_par$PARAMETER)
new_par$PARAMETER[i[!is.na(i)]] <- newnames[!is.na(i)]
new_par <- arrange(new_par, PARAMETER)
new_bc <- read_tsv("model_inputs/parameters_BC_Saerheim_nutritive.txt", col_names=FALSE)
names(new_bc) <- c("PARAMETER", "MIN", "MODE", "MAX", "SITES")
i <- match(names(newnames), new_bc$PARAMETER)
new_bc$PARAMETER[i[!is.na(i)]] <- newnames[!is.na(i)]
new_bc <- arrange(new_bc, PARAMETER)

# check internal consistency
print("Consistency of my_bc")
errors <- my_bc %>%
  filter(!((MIN<=MODE)&(MODE<=MAX)))
print(errors)

print("Consistency of my_par and my_bc")
errors <- left_join(my_bc, my_par) %>%
  filter(!((MIN<=NZMIN)&(NZMAX<=MAX)))
print(errors)

print("Consistency of orig_bc")
errors <- orig_bc %>%
  filter(!((MIN<=MODE)&(MODE<=MAX)))
print(errors)

print("Consistency of orig_par and orig_bc")
errors <- left_join(orig_bc, orig_par) %>%
  dplyr::select(PARAMETER, MIN, MODE, MAX, MINSITE, MAXSITE) %>%
  filter(!((MIN<=MINSITE)&(MAXSITE<=MAX)))
print(errors)

print("Consistency of new_bc")
errors <- new_bc %>%
  filter(!((MIN<=MODE)&(MODE<=MAX)))
print(errors)

print("Consistency of new_par and new_bc")
errors <- left_join(new_bc, new_par) %>%
  dplyr::select(PARAMETER, MIN, MODE, MAX, MINSITE, MAXSITE) %>%
  filter(!((MIN<=MINSITE)&(MAXSITE<=MAX)))
print(errors)

# consistency between sets
print("Consistency of my_par and orig_bc")
errors <- left_join(orig_bc, my_par) %>%
  filter(!((MIN<=NZMIN)&(NZMAX<=MAX)))
print(errors)

print("Consistency of my_par and new_bc")
errors <- left_join(new_bc, my_par) %>%
  filter(!((MIN<=NZMIN)&(NZMAX<=MAX)))
print(errors)

print("Comparison of my_par and orig_par")
errors <- left_join(dplyr::select(orig_par, PARAMETER, MINSITE, MAXSITE), my_par) %>%
  mutate(change=pmax(abs(NZMAX/MINSITE),
                     abs(MINSITE/NZMAX),
                     abs((MINSITE-NZMAX)/MINSITE),
                     abs((MINSITE-NZMAX)/NZMAX),
                     abs(NZMIN/MAXSITE),
                     abs(MAXSITE/NZMIN),
                     abs((MAXSITE-NZMIN)/MAXSITE),
                     abs((MAXSITE-NZMIN)/NZMIN)
         )) %>%
  arrange(desc(change))
print(errors, n=100)

print("Comparison of my_par and new_par")
errors <- left_join(dplyr::select(new_par, PARAMETER, MINSITE, MAXSITE), my_par) %>%
  mutate(change=pmax(abs(NZMAX/MINSITE),
                     abs(MINSITE/NZMAX),
                     abs((MINSITE-NZMAX)/MINSITE),
                     abs((MINSITE-NZMAX)/NZMAX),
                     abs(NZMIN/MAXSITE),
                     abs(MAXSITE/NZMIN),
                     abs((MAXSITE-NZMIN)/MAXSITE),
                     abs((MAXSITE-NZMIN)/NZMIN)
  )) %>%
  arrange(desc(change))
print(errors, n=100)

# print("Comparison of my_bc and official orig_par")
# errors <- left_join(dplyr::select(orig_par, PARAMETER, MINSITE, MAXSITE), my_bc) %>%
#   mutate(change=pmax(abs(Scott/MINSITE),
#                      abs(MINSITE/Scott),
#                      abs((MINSITE-Scott)/MINSITE),
#                      abs((MINSITE-Scott)/Scott),
#                      abs(Scott/MAXSITE),
#                      abs(MAXSITE/Scott),
#                      abs((MAXSITE-Scott)/MAXSITE),
#                      abs((MAXSITE-Scott)/Scott)
#   )) %>%
#   arrange(desc(change))
# print(errors, n=20)

# read old parameters
# file_params    <- 'model_inputs/parameters.txt' # can contain multiple columns
# parcol       <- 1 # which one are we going to use? (row names are ignored)
# orig_params      <- read.table(file_params,header=T,sep="\t",row.names=1)

# summary
all <- dplyr::select(arrange(orig_par, PARAMETER), PARAMETER, origMINSITE=MINSITE, origMAXSITE=MAXSITE) %>%
  left_join(dplyr::select(orig_bc, PARAMETER, origMIN=MIN, origMODE=MODE, origMAX=MAX)) %>%
  full_join(dplyr::select(arrange(new_par, PARAMETER), PARAMETER, newMINSITE=MINSITE, newMAXSITE=MAXSITE)) %>%
  left_join(dplyr::select(new_bc, PARAMETER, newMIN=MIN, newMODE=MODE, newMAX=MAX)) %>%
  full_join(dplyr::select(arrange(my_par, PARAMETER), PARAMETER, NZMINSITE=NZMIN, NZMAXSITE=NZMAX)) %>%
  left_join(dplyr::select(my_bc, PARAMETER, NZMIN=MIN, NZMODE=MODE, NZMAX=MAX, NZSHAPE=SHAPE)) %>%
  left_join(dplyr::select(my_par, PARAMETER, Units, Description))
write_tsv(all, paste(scenario, "/check_variables.tsv", sep=""))
headings <- c("PARAMETER",
                "MIN", "MAX", "LOWER", "MODE", "UPPER",
                "MIN", "MAX", "LOWER", "MODE", "UPPER",
                "MIN", "MAX", "LOWER", "MODE", "UPPER", "SHAPE",
                "UNITS", "DESCRIPTION")

# https://cran.r-project.org/web/packages/kableExtra/vignettes/awesome_table_in_html.html
my_format <- function(x){
  y <- format(x, digits=3, scientific=FALSE, TRIM=TRUE)
  y[is.na(x)] <- ""
  y
}

# format values by row
# all_formatted <- all %>%
#   `row.names<-`(.$PARAMETER) %>% # set row names for transpose
#   dplyr::select(-PARAMETER, -Units, -Description) %>% # only numeric columns
#   t() %>% # transpose
#   tidy() %>% # convert to tibble (creates .rownames column)
#   modify(my_format) %>% # apply format function to each column of values in place
#   `row.names<-`(.$.rownames) %>% # set row names for transpose
#   dplyr::select(-.rownames) %>% # drop rownames column
#   t() %>% # transpose
#   tidy() %>% # convert to tibble (creates .rownames column)
#   dplyr::select(-.rownames) %>% # drop rownames
#   add_column(PARAMETER=all$PARAMETER, .before=1) %>% # add back nonnumeric columns
#   add_column(UNITS=if_else(!is.na(all$Units), all$Units, ""),
#              DESCRIPTION=if_else(!is.na(all$Description), all$Description, ""))
all_formatted <- all %>%
  rename(UNITS=Units,
         DESCRIPTION=Description) %>%
  mutate(UNITS=if_else(!is.na(UNITS), UNITS, ""),
         DESCRIPTION=if_else(!is.na(DESCRIPTION), DESCRIPTION, "")) %>%
  mutate_all(as.character) %>%
  mutate(NZSHAPE=if_else(!is.na(NZSHAPE), NZSHAPE, ""))
cols <- 2:(ncol(all)-3)
row <- 1
for (row in 1:nrow(all)){
  all_formatted[row,cols] <- my_format(as.numeric(all[row,cols]))
}

if (FALSE){
  all_formatted <- tibble(
    PARAMETER=c("1","2"),
    MIN1=c("1","2"),
    MAX1=c("1","2"),
    LOWER1=c("1","2"),
    MODE1=c("1","2"),
    UPPE1R=c("1","2"),
    MIN2=c("1","2"),
    MAX2=c("1","2"),
    LOWER2=c("1","2"),
    MODE2=c("1","2"),
    UPPER2=c("1","2"),
    VAL3=c("1","2"),
    LOWER3=c("1","2"),
    MODE3=c("1","2"),
    UPPER3=c("1","2"),
    SHAPE=c("1","2"),
    UNITS=c("1","2"),
    DESCRIPTION=c("1","2")
  )
}

this_dir <- getwd() # avoid path bug in save_kable
all_formatted %>%
  kable(col.names=headings) %>%
  kable_styling(
    bootstrap_options = c("condensed", "striped", "hover"),
    full_width=FALSE, position="left", font_size=12) %>%
  add_header_above(header=c("Parameter" = 1, "Original" = 5, "Nutritive" = 5, "NZ" = 6, "Details"=2),
                   align="left", bold=TRUE) %>%
  column_spec(19, width="20cm") %>%
  save_kable(file=paste(this_dir, "/", scenario, "/", outfile, ".html", sep=""),
             bs_theme="Cosmo", # https://bootswatch.com/
             self_contained=TRUE) # very slow

write_tsv(all_formatted, paste(scenario, "/", outfile, ".tsv", sep=""))


##http://github.com/velaraptor/nba_mvp_metric

##get opponent totals

library(XML)

##season totals for each player, according to basketball-reference.com,Tm-Team,G-Game,GS-Game Started,MP-Minutes Played, FG-Field Goals,FGA-Field Goals Attempted,3P-3 pointers,FT-Free Throws,ORB-Offensive Rebounds,DRB-Defensive Rebounds, TRB-Total Rebounds, AST-Assists,STL-Steals,BLK-Blocks,TOV-Turnovers,PF-Fouls, PTS-Points

season.totals<-file.path("http://www.basketball-reference.com/leagues",c("NBA_1980_totals.html","NBA_1981_totals.html","NBA_1982_totals.html","NBA_1983_totals.html","NBA_1984_totals.html","NBA_1985_totals.html","NBA_1986_totals.html","NBA_1987_totals.html","NBA_1988_totals.html","NBA_1989_totals.html","NBA_1990_totals.html","NBA_1991_totals.html","NBA_1992_totals.html","NBA_1993_totals.html","NBA_1994_totals.html","NBA_1995_totals.html","NBA_1996_totals.html","NBA_1997_totals.html","NBA_1998_totals.html","NBA_1999_totals.html","NBA_2000_totals.html","NBA_2001_totals.html","NBA_2002_totals.html","NBA_2003_totals.html","NBA_2004_totals.html","NBA_2005_totals.html","NBA_2006_totals.html","NBA_2007_totals.html","NBA_2008_totals.html","NBA_2009_totals.html","NBA_2010_totals.html","NBA_2011_totals.html","NBA_2012_totals.html","NBA_2013_totals.html"))
season<-lapply(season.totals,readHTMLTable)
s<-lapply(season,as.data.frame)
names(s)<-gsub(".*/(.*)\\..*","\\1", season.totals)
lapply(names(s),function(X) write.csv(s[[X]],file=paste0(X,".csv")))

##season advanced statistics for each player,PER -- Player Efficiency Rating; a measure of per-minute production standardized such that the league average is 15,TS% -- True Shooting Percentage; a measure of shooting effeciency that takes into account 2-point field goals, 3-point field goals, and free throws, eFG% -- Effective Field Goal Percentage; this statistic adjusts for the fact that a 3-point field goal is worth one more point than a 2-point field goal, FTr -- Free Throw Attempt Rate-Number of FT Attempts Per FG Attempt,3PAr -- 3-Point Attempt Rate-Percentage of FG Attempts from 3-Point Range,ORB% -- Offensive Rebound Percentage; an estimate of the percentage of available offensive rebounds a player grabbed while he was on the floor, DRB% -- Defensive Rebound Percentage; an estimate of the percentage of available defensive rebounds a player grabbed while he was on the floor, TRB% -- Total Rebound Percentage; an estimate of the percentage of available rebounds a player grabbed while he was on the floor,AST% -- Assist Percentage; an estimate of the percentage of teammate field goals a player assisted while he was on the floor, STL% -- Steal Percentage; an estimate of the percentage of opponent possessions that end with a steal by the player while he was on the floor, BLK% -- Block Percentage; an estimate of the percentage of opponent two-point field goal attempts blocked by the player while he was on the floor,TOV% -- Turnover Percentage; an estimate of turnovers per 100 plays,USG% -- Usage Percentage; an estimate of the percentage of team plays used by a player while he was on the floor,ORtg -- Offensive Rating: An estimate of points produced (players) or scored (teams) per 100 possession,DRtg -- Defensive Rating: An estimate of points allowed per 100 possessions, OWS -- Offensive Win Shares; an estimate of the number of wins contributed by a player due to his offense.,DWS -- Defensive Win Shares; an estimate of the number of wins contributed by a player due to his defense,WS -- Win Shares; an estimate of the number of wins contributed by a player,WS/48 -- Win Shares Per 48 Minutes; an estimate of the number of wins contributed by a player per 48 minutes (league average is approximately .100)

season.advanced<-file.path("http://www.basketball-reference.com/leagues",c("NBA_1980_advanced.html","NBA_1981_advanced.html","NBA_1982_advanced.html","NBA_1983_advanced.html","NBA_1984_advanced.html","NBA_1985_advanced.html","NBA_1986_advanced.html","NBA_1987_advanced.html","NBA_1988_advanced.html","NBA_1989_advanced.html","NBA_1990_advanced.html","NBA_1991_advanced.html","NBA_1992_advanced.html","NBA_1993_advanced.html","NBA_1994_advanced.html","NBA_1995_advanced.html","NBA_1996_advanced.html","NBA_1997_advanced.html","NBA_1998_advanced.html","NBA_1999_advanced.html","NBA_2000_advanced.html","NBA_2001_advanced.html","NBA_2002_advanced.html","NBA_2003_advanced.html","NBA_2004_advanced.html","NBA_2005_advanced.html","NBA_2006_advanced.html","NBA_2007_advanced.html","NBA_2008_advanced.html","NBA_2009_advanced.html","NBA_2010_advanced.html","NBA_2011_advanced.html","NBA_2012_advanced.html","NBA_2013_advanced.html"))
season.ad<-lapply(season.advanced,readHTMLTable)
s.a<-lapply(season.ad,as.data.frame)
names(s.a)<-gsub(".*/(.*)\\..*","\\1", season.advanced)
lapply(names(s.a),function(X) write.csv(s.a[[X]],file=paste0(X,".csv")))

##season ratings is team ratings for each season, W-L% -- Win-Loss Percentage, MOV -- Margin of Victory, ORtg -- Offensive Rating: An estimate of points produced (players) or scored (teams) per 100 possessions, DRtg -- Defensive Rating: An estimate of points allowed per 100 possessions, NRtg -- Net Rating; an estimate of point differential per 100 possessions., MOV/A -- Adjusted Margin of Victory; margin of victory adjusted for strength of opponent., ORtg/A -- Adjusted Offensive Rating; an estimate of points scored per 100 possessions adjusted for strength of opponent defense., DRtg/A -- Adjusted Defensive Rating; an estimate of points allowed per 100 possessions adjusted for strength of opponent offense., NRtg/A -- Adjusted Net Rating; an estimate of point differential per 100 possessions adjusted for strength of opponent.

season.ratings<-file.path("http://www.basketball-reference.com/leagues",c("NBA_1980_ratings.html","NBA_1981_ratings.html","NBA_1982_ratings.html","NBA_1983_ratings.html","NBA_1984_ratings.html","NBA_1985_ratings.html","NBA_1986_ratings.html","NBA_1987_ratings.html","NBA_1988_ratings.html","NBA_1989_ratings.html","NBA_1990_ratings.html","NBA_1991_ratings.html","NBA_1992_ratings.html","NBA_1993_ratings.html","NBA_1994_ratings.html","NBA_1995_ratings.html","NBA_1996_ratings.html","NBA_1997_ratings.html","NBA_1998_ratings.html","NBA_1999_ratings.html","NBA_2000_ratings.html","NBA_2001_ratings.html","NBA_2002_ratings.html","NBA_2003_ratings.html","NBA_2004_ratings.html","NBA_2005_ratings.html","NBA_2006_ratings.html","NBA_2007_ratings.html","NBA_2008_ratings.html","NBA_2009_ratings.html","NBA_2010_ratings.html","NBA_2011_ratings.html","NBA_2012_ratings.html","NBA_2013_ratings.html"))
season.ra<-lapply(season.ratings,readHTMLTable)
s.r<-lapply(season.ra,as.data.frame)
names(s.r)<-gsub(".*/(.*)\\..*","\\1", season.ratings)
lapply(names(s.r),function(X) write.csv(s.r[[X]],file=paste0(X,".csv")))

##mvp winners
mvp<-as.data.frame(readHTMLTable("http://bkref.com/pi/shareit/vRg8Z"))
write.csv(mvp,file="mvp.csv")

##award voting
award.voting<-file.path("http://www.basketball-reference.com/awards",c("awards_1980.html","awards_1981.html","awards_1982.html","awards_1983.html","awards_1984.html","awards_1985.html","awards_1986.html","awards_1987.html","awards_1988.html","awards_1989.html","awards_1990.html","awards_1991.html","awards_1992.html","awards_1993.html","awards_1994.html","awards_1995.html","awards_1996.html","awards_1997.html","awards_1998.html","awards_1999.html","awards_2000.html","awards_2001.html","awards_2002.html","awards_2003.html","awards_2004.html","awards_2005.html","awards_2006.html","awards_2007.html","awards_2008.html","awards_2009.html","awards_2010.html","awards_2011.html","awards_2012.html"))
award.vt<-lapply(award.voting,readHTMLTable)

clean.list.multiple.tables<-function(list){
	l<-list();
	total<-length(list);
	for(i in 1:total){
		l[[i]]<-list[[i]]$mvp;
	}
	return(l);
}
la<-clean.list.multiple.tables(award.vt)
l.a<-lapply(la,as.data.frame)
names(l.a)<-gsub(".*/(.*)\\..*","\\1", award.voting)
lapply(names(l.a),function(X) write.csv(l.a[[X]],file=paste0(X,".csv")))

## fix the data and clean it

##changes type for each column from factor to numeric
change.num.totals<-function(list){
	team<-list;
	for( i in c(4,6:length(team))){
		team[,i]<-as.character(team[,i]);
		team[,i]<-as.numeric(team[,i]);
	}
	return(team)
}

change.num.advanced<-function(list){
	team<-list;
	for( i in c(4,6:length(team))){
		team[,i]<-as.character(team[,i]);
		team[,i]<-as.numeric(team[,i]);
	}
	return(team)
}

change.num.ratings<-function(list){
	team<-list;
	for( i in c(5:length(team))){
		team[,i]<-as.character(team[,i]);
		team[,i]<-as.numeric(team[,i]);
	}
	return(team)
}

s.fix<-lapply(s,change.num.totals)
sa.fix<-lapply(s.a,change.num.advanced)
sr.fix<-lapply(s.r,change.num.ratings)

##deletes rows that are headers with no data
delete.row<-function(list){
	team<-list;
	team.1<-team[-grep("Player",team[,2]),]
	return(team.1)
}

s.fix.1<-lapply(s.fix,delete.row)
sa.fix.1<-lapply(sa.fix,delete.row)

##fixes Player name which has a star after their name
has.star<-function(list){
	team<-list;
	team[,2]<-as.character(team[,2]);
	check.star<-grep("\\*$",team[,2]);
	team[check.star,2]<-gsub("\\*$","",team[check.star,2]);
	return(team);
}

s.fix.1<-lapply(s.fix.1,has.star)
sa.fix.1<-lapply(sa.fix.1,has.star)

has.multiple.entry<-function(list){
	team<-list;
	team<-team[!duplicated(team[,2]),];
	return(team);

}
fixed.s<-lapply(s.fix.1,has.multiple.entry)
fixed.sa<-lapply(sa.fix.1,has.multiple.entry)

nba_1980<-merge(fixed.s[[1]],fixed.sa[[1]],by.x="totals.Player",by.y="advanced.Player")
nba_1981<-merge(fixed.s[[2]],fixed.sa[[2]],by.x="totals.Player",by.y="advanced.Player")
nba_1982<-merge(fixed.s[[3]],fixed.sa[[3]],by.x="totals.Player",by.y="advanced.Player")
nba_1983<-merge(fixed.s[[4]],fixed.sa[[4]],by.x="totals.Player",by.y="advanced.Player")
nba_1984<-merge(fixed.s[[5]],fixed.sa[[5]],by.x="totals.Player",by.y="advanced.Player")
nba_1985<-merge(fixed.s[[6]],fixed.sa[[6]],by.x="totals.Player",by.y="advanced.Player")
nba_1986<-merge(fixed.s[[7]],fixed.sa[[7]],by.x="totals.Player",by.y="advanced.Player")
nba_1987<-merge(fixed.s[[8]],fixed.sa[[8]],by.x="totals.Player",by.y="advanced.Player")
nba_1988<-merge(fixed.s[[9]],fixed.sa[[9]],by.x="totals.Player",by.y="advanced.Player")
nba_1989<-merge(fixed.s[[10]],fixed.sa[[10]],by.x="totals.Player",by.y="advanced.Player")
nba_1990<-merge(fixed.s[[11]],fixed.sa[[11]],by.x="totals.Player",by.y="advanced.Player")
nba_1991<-merge(fixed.s[[12]],fixed.sa[[12]],by.x="totals.Player",by.y="advanced.Player")
nba_1992<-merge(fixed.s[[13]],fixed.sa[[13]],by.x="totals.Player",by.y="advanced.Player")
nba_1993<-merge(fixed.s[[14]],fixed.sa[[14]],by.x="totals.Player",by.y="advanced.Player")
nba_1994<-merge(fixed.s[[15]],fixed.sa[[15]],by.x="totals.Player",by.y="advanced.Player")
nba_1995<-merge(fixed.s[[16]],fixed.sa[[16]],by.x="totals.Player",by.y="advanced.Player")
nba_1996<-merge(fixed.s[[17]],fixed.sa[[17]],by.x="totals.Player",by.y="advanced.Player")
nba_1997<-merge(fixed.s[[18]],fixed.sa[[18]],by.x="totals.Player",by.y="advanced.Player")
nba_1998<-merge(fixed.s[[19]],fixed.sa[[19]],by.x="totals.Player",by.y="advanced.Player")
nba_1999<-merge(fixed.s[[20]],fixed.sa[[20]],by.x="totals.Player",by.y="advanced.Player")
nba_2000<-merge(fixed.s[[21]],fixed.sa[[21]],by.x="totals.Player",by.y="advanced.Player")
nba_2001<-merge(fixed.s[[22]],fixed.sa[[22]],by.x="totals.Player",by.y="advanced.Player")
nba_2002<-merge(fixed.s[[23]],fixed.sa[[23]],by.x="totals.Player",by.y="advanced.Player")
nba_2003<-merge(fixed.s[[24]],fixed.sa[[24]],by.x="totals.Player",by.y="advanced.Player")
nba_2004<-merge(fixed.s[[25]],fixed.sa[[25]],by.x="totals.Player",by.y="advanced.Player")
nba_2005<-merge(fixed.s[[26]],fixed.sa[[26]],by.x="totals.Player",by.y="advanced.Player")
nba_2006<-merge(fixed.s[[27]],fixed.sa[[27]],by.x="totals.Player",by.y="advanced.Player")
nba_2007<-merge(fixed.s[[28]],fixed.sa[[28]],by.x="totals.Player",by.y="advanced.Player")
nba_2008<-merge(fixed.s[[29]],fixed.sa[[29]],by.x="totals.Player",by.y="advanced.Player")
nba_2009<-merge(fixed.s[[30]],fixed.sa[[30]],by.x="totals.Player",by.y="advanced.Player")
nba_2010<-merge(fixed.s[[31]],fixed.sa[[31]],by.x="totals.Player",by.y="advanced.Player")
nba_2011<-merge(fixed.s[[32]],fixed.sa[[32]],by.x="totals.Player",by.y="advanced.Player")
nba_2012<-merge(fixed.s[[33]],fixed.sa[[33]],by.x="totals.Player",by.y="advanced.Player")

fix.award<-function(list){
	team<-list;
	team<-team[,c(2,5,6)];
	return(team);
}
l<-lapply(l.a,fix.award)

ndf<-list(nba_1980,nba_1981,nba_1982,nba_1983,nba_1984,nba_1985,nba_1986,nba_1987,nba_1988,nba_1989,nba_1990,nba_1991,nba_1992,nba_1993,nba_1994,nba_1995,nba_1996,nba_1997,nba_1998,nba_1999,nba_2000,nba_2001,nba_2002,nba_2003,nba_2004,nba_2005,nba_2006,nba_2007,nba_2008,nba_2009,nba_2010,nba_2011,nba_2012)

fix.mvp<-function(mvp){
	mvp<-mvp;
	mvp[,2]<-as.character(mvp[,2]);
	mvp[,2]<-as.numeric(mvp[,2]);
	mvp[,3]<-as.character(mvp[,3]);
	mvp[,3]<-as.numeric(mvp[,3]);
	colnames(mvp)[3]<-"Pts.Won"
	return(mvp);
}
l.1<-lapply(l,fix.mvp)

fix.columns.ndf<-function(list){
	x<-list;
	x<-data.frame(x,0);
	colnames(x)[55]<-"Pts.Won";
	colnames(x)[1]<-"Player";
	x$totals.Rk<-NULL;
	x$advanced.Rk<-NULL;
	x$advanced.Pos<-NULL;
	x$advanced.Age<-NULL;
	x$advanced.Tm<-NULL;
	x$advanced.G<-NULL;
	x$advanced.MP<-NULL;
	return(x);
}

ndf.1<-lapply(ndf,fix.columns.ndf)

clean<-function(totals,mvp){
	x<-totals;
	x<-x[x$Player %in% mvp$Player,];
	return(x)}

x<-mapply(clean,totals=ndf.1,mvp=l.1)
x.1<-t(x)

cleanup<-function(x){
	lis<-vector("list",33)
	for(i in 1:33){
		d<-data.frame(x[i,])
		lis[[i]]<-d
		}
		return(lis)
}

clee<-cleanup(x.1)
names(clee)<-c("1980","1981","1982","1983","1984",'1985',"1986","1987","1988","1989","1990","1991","1992","1993","1994",'1995',"1996","1997","1998","1999","2000","2001","2002","2003","2004","2005","2006","2007","2008","2009","2010","2011","2012")

lapply(names(clee),function(X) write.csv(clee[[X]],file=paste0(X,".csv")))

normalizevotes<-function(list){
	x<-list;
	y<-sum(x$Pts.Won);
	x$Pts.Won<-(x$Pts.Won/y)
	return(x)
}
l.2<-lapply(l.1,normalizevotes)
lapply(names(l.2),function(X) write.csv(l.2[[X]],file=paste0(X,".csv")))


# Date functions for parsing like: mdy, ymd, ydm, dmy, mdy

month_seq <- seq(as.Date("2000-01-01"), as.Date("2000-12-31"), "month")
months <- factor(months(month_seq), levels = months(month_seq))
months_abbr <- factor(months(month_seq, TRUE), levels = months(month_seq, TRUE))

wday_seq <- seq(as.Date("2000-01-02"), as.Date("2000-01-08"), "day")
wdays <- factor(weekdays(wday_seq), levels = weekdays(wday_seq))
wdays_abbr <- factor(weekdays(wday_seq, TRUE), levels = weekdays(wday_seq, TRUE))

second <- function(x) as.POSIXlt(x)$sec
minute <- function(x) as.POSIXlt(x)$min
hour <- function(x) as.POSIXlt(x)$hour
yday <- function(x) as.POSIXlt(x)$yday + 1
wday <- function(x) as.POSIXlt(x)$wday + 1
mday <- function(x) as.POSIXlt(x)$mday
week <- function(x) yday(x) %/% 7 + 1
month <- function(x) as.POSIXlt(x)$mon + 1
year <- function(x) as.POSIXlt(x)$year + 1900
tz <- function(x) {
	tzs <- attr(as.POSIXlt(x),"tzone")
	tzs[length(tzs)]
}

"second<-" <- function(x, value) as.POSIXlt(x) - (second(x) - value)
"minute<-" <- function(x, value) as.POSIXlt(x) - (minute(x) - value) * 60
"hour<-" <- function(x, value) as.POSIXlt(x) - (hour(x) - value) * 3600
"yday<-" <- function(x, value) as.POSIXlt(x) - (yday(x) - value) * 3600 * 24
"wday<-" <- function(x, value) as.POSIXlt(x) - (wday(x) - value) * 3600 * 24
"mday<-" <- function(x, value) as.POSIXlt(x) - (mday(x) - value) * 3600 * 24
"week<-" <- function(x, value) as.POSIXlt(x) - (week(x) - value) * 3600 * 24 * 7
"month<-" <- function(x, value) {
	ISOdatetime(year(x) + (value - 1) %/% 12,  (value - 1) %% 12 + 1, mday(x), hour(x), minute(x), second(x), tz(x))
}
"year<-" <- function(x, value) {
	ISOdatetime(value,  month(x), mday(x), hour(x), minute(x), second(x), tz(x))
}
"tz<-" <- function(x, value) {
	ISOdatetime(year(x),  month(x), mday(x), hour(x), minute(x), second(x), value)
}


#  James Rekow

#  switched to comparing diss instead of over, switch back if this doesn't seem promising, or add
#  this choice as a function input

treatmentArrayListCreator = function(M = 80, N = 20, iStrength = 1, univ = 1, sigmaMax = 0.1,
                                     thresholdMult = 10 ^ (-1), maxSteps = 10 ^ 4, tStep = 10 ^ (-2),
                                     intTime = 1, interSmplMult = 0.01, lambda = 10 ^ (-1),
                                     synthM = floor(M / 4), numSynthChrt = 10, numSample = 100,
                                     maxIters = 100){

  #  ARGS:
  #
  #  RETURNS:

  source("conGraphCreator.r")
  source("DOCNSDFListCreator.r")

  ##  define tests to apply to each treatment

  se = function(x){

    #  ARGS: x - a numeric vector
    #
    #  RETURNS: stdError - the standard error of x

    stdError = sd(x) / sqrt(length(x))

    return(stdError)

  } #  end se function

  #correctMeans = function(DFList) mean(DFList[[1]]$x) < mean(DFList[[2]]$x)
  correctMeans = function(DFList) mean(DFList[[1]]$y) > mean(DFList[[2]]$y)

  seTestDiff = function(DFList){

    over1 = DFList[[1]]$y
    over2 = DFList[[2]]$y
    sigDiff = abs(mean(over1) - mean(over2)) > max(se(over1), se(over2))

    return(sigDiff)

  } #  end seTestDiff function

  tTestDiff = function(DFList){

    over1 = DFList[[1]]$y
    over2 = DFList[[2]]$y
    sigDiff = t.test(over1, over2)$p.value < 0.05

    return(sigDiff)

  } #  end tTestDiff function

  ksTestDiff = function(DFList){

    over1 = DFList[[1]]$y
    over2 = DFList[[2]]$y
    sigDiff = ks.test(over1, over2)$p.value < 0.05

    return(sigDiff)

  } #  end ksTestDiff function

  #  store the three test functions in a vector
  testVec = c(seTestDiff, tTestDiff, ksTestDiff)

  # lambdaVec = c(0.05, 0.1, 0.15)
  # graphTypeVec = c("smallWorld", "scaleFree", "gnp", "gnm")
  # meanDegreeVec = c(2, 4, 6)

  lambdaVec = c(0.05, 0.1, 0.15)
  graphTypeVec = c("smallWorld", "scaleFree", "gnp", "gnm")
  meanDegreeVec = c(4, 6)

  x1 = 1:length(lambdaVec)
  x2 = 1:length(graphTypeVec)
  x3 = 1:length(meanDegreeVec)

  g = function(x, y) sapply(1:length(x), function(n) list(append(x[[n]], y[[n]])))

  coordArray = outer(x1, outer(x2, x3, g), g)

  countSuccessfulTests = function(coords){

    #  ARGS:
    #
    #  RETURNS:

    source("conGraphCreator.r")
    source("DOCNSDFListCreator.r")

    #  unlist the coordinates in the input
    coords = unlist(coords)

    #  extract the parameter values corresponding to the coordinate vector
    lambda = lambdaVec[coords[1]]
    graphType = graphTypeVec[coords[2]]
    meanDegree = meanDegreeVec[coords[3]]

    # NOTE: coords in array of the from c(lambda, graphType, meanDegree)

    #  create connectivity graph using the graph type and mean degree parameters
    conGraph = conGraphCreator(graphType = graphType, meanDegree = meanDegree, v = M)

    testVecCreator = function(x = NULL){

      DOCNSDFList = DOCNSDFListCreator(conGraph = conGraph, M = M, N = N, iStrength = iStrength,
                                       univ = univ, sigmaMax = sigmaMax,
                                       thresholdMult = thresholdMult, maxSteps = maxSteps,
                                       tStep = tStep, intTime = intTime,
                                       interSmplMult = interSmplMult, lambda = lambda,
                                       synthM = synthM, numSynthChrt = numSynthChrt,
                                       numSample = numSample, maxIters = maxIters)

      cMean = correctMeans(DOCNSDFList)

      #  store the test results in a vector
      #  accurateTestVec is of the form c(se, t, ks)
      accurateTestVec = sapply(testVec, function(f) f(DOCNSDFList))

      successfulTestVec = cMean & accurateTestVec

      return(successfulTestVec)

    } #  end testVecCreator function

    testVecList = lapply(as.list(1:10), testVecCreator)

    successfulTestCounter = function(n) sum(sapply(testVecList, "[[", n))

    #  output is a list of the form list(se, t, ks)
    successfulTests = lapply(as.list(1:3), successfulTestCounter)

    return(successfulTests)

  } #  end countSuccessfulTests function

  # cl = makeCluster(8, type = "SOCK")
  #
  # clusterExport(cl = cl, list = ls(.GlobalEnv), envir = .GlobalEnv)
  #
  # successfulTestCounts = parApply(cl = cl, coordArray, 1:3, countSuccessfulTests)
  #
  # stopCluster(cl = cl)

  successfulTestCounts = apply(coordArray, 1:3, countSuccessfulTests)

  extractResults = function(n){

    extractor = function(listedTestVec) unlist(listedTestVec)[n]

    testResults = apply(successfulTestCounts, 1:3, extractor)

    return(testResults)

  } #  end extractResults function

  testResultsList = lapply(as.list(1:3), extractResults)
  names(testResultsList) = c("seTest", "tTest", "ksTest")

  return(testResultsList)

} #  end treatmentArrayListCreator function


accumulatorFactory <- function(init) {
  currentSum <- init
  function(add) {
    currentSum <<- currentSum + add
    currentSum
  }
}


## Usage: Rscript this.r <output_prefix> <in1_foreground_prefix> <in2_background_prefix> [pos_range]

options(stringsAsFactors=FALSE)

library(HDInterval)

`%.%` <- function(x,y) paste0(x,y)

join = function(sep, vec, ...) paste(collapse=sep, c(vec, ...))
cat0 = function(...) cat(sep="", ...)

echo_str <- function(x, sep=" =\t", collapse=", ") deparse(substitute(x)) %.% sep %.% join(collapse, x)
echo <- function(x, sep=" =\t", collapse=", ") cat0(deparse(substitute(x)), sep, join(collapse, x), "\n");

str_trim_left = function(str, trimLen){
	strlen = nchar(str)
	start = pmin(strlen, trimLen) + 1
	end = strlen
	substr(str, start, end)
}
str_trim_right = function(str, trimLen){
	strlen = nchar(str)
	start = 1
	end = pmax(0, strlen - trimLen)
	substr(str, start, end)
}
str_left = function(str, len){
	strlen = nchar(str)
	start = 1
	end = pmin(len, strlen)
	substr(str, start, end)
}
str_right = function(str, len){
	strlen = nchar(str)
	start = pmax(1, strlen - len + 1)
	end = strlen
	substr(str, start, end)
}

### ref: http://varianceexplained.org/r/bayesian_fdr_baseball/
cummean = function(vec){
	cumsum(vec) / (1:length(vec))
}
PEP_to_qvalues = function(PEP_vec){
	order_vec = order(PEP_vec)
	ans = rep(NA, length(PEP_vec))
	PEP_ordered = PEP_vec[order_vec]
	qvalue_ordered = cummean(PEP_ordered)
	ans[order_vec] = qvalue_ordered
	ans
}

if(interactive()==FALSE){
	args = commandArgs(TRUE)
}
if(length(args) < 3){
	stop("Usage: Rscript this.r <output_prefix> <in1_foreground_prefix> <in2_background_prefix> [pos_range]")
}

output_prefix = args[1]
input_foreground_prefix = args[2]
input_background_prefix = args[3]

pos_range = NULL
if(length(args) >= 4){
	pos_range = args[4]
	tmp = as.integer(strsplit(pos_range, "[:-]")[[1]])
	if(length(tmp)==1){
		# good, do nothing
		# 2019-08-21, Yyx debug, pos_range will be character without converting
		pos_range = as.integer(tmp[1])
	}else if(length(tmp)==2){
		pos_range = tmp[1]:tmp[2]
	}else{
		stop("Cannot recognize pos_range = " %.% pos_range)
	}
}

input_foreground_stat_DF = read.delim(input_foreground_prefix %.% ".all.stat.txt")
echo(dim(input_foreground_stat_DF))
input_background_stat_DF = read.delim(input_background_prefix %.% ".all.stat.txt")
echo(dim(input_background_stat_DF))
stopifnot(nrow(input_foreground_stat_DF)==nrow(input_background_stat_DF))

names(input_foreground_stat_DF) = "in1." %.% names(input_foreground_stat_DF)
names(input_background_stat_DF) = "in2." %.% names(input_background_stat_DF)   # there is a bug in previous version, and debugged on 2019-08-29
input_DF = cbind(input_foreground_stat_DF, input_background_stat_DF)
echo(dim(input_DF))

input_DF$in1.simu_num = NA
input_DF$in1.mu_mean = NA
input_DF$in1.mu_LB = NA
input_DF$in1.mu_UB = NA
input_DF$in2.simu_num = NA
input_DF$in2.mu_mean = NA
input_DF$in2.mu_LB = NA
input_DF$in2.mu_UB = NA
input_DF$muDiff.simu_num = NA
input_DF$muDiff_mean = NA
input_DF$muDiff_LB = NA
input_DF$muDiff_UB = NA
input_DF$muDiff_gt0_posterior = NA
input_DF$muDiff_gt0_01_posterior = NA
input_DF$muDiff_gt0_05_posterior = NA
input_DF$muDiff_gt0_1_posterior = NA

real_pos_range = 1:nrow(input_DF)
if(!is.null(pos_range)){
	real_pos_range = pos_range[pos_range %in% 1:nrow(input_DF)]
}

for(i in real_pos_range){
	echo(i)
	try({
	mcmc_1 = read.delim(input_foreground_prefix %.% ".site_" %.% i %.% ".mcmc_rlt.tsv")
	input_DF$in1.simu_num[i] = nrow(mcmc_1)
	input_DF$in1.mu_mean[i] = mean(mcmc_1$mu)
	tmp = hdi(mcmc_1$mu)
	input_DF$in1.mu_LB[i] = tmp[1]
	input_DF$in1.mu_UB[i] = tmp[2]
	})

	try({
	mcmc_2 = read.delim(input_background_prefix %.% ".site_" %.% i %.% ".mcmc_rlt.tsv")
	input_DF$in2.simu_num[i] = nrow(mcmc_2)
	input_DF$in2.mu_mean[i] = mean(mcmc_2$mu)
	tmp = hdi(mcmc_2$mu)
	input_DF$in2.mu_LB[i] = tmp[1]
	input_DF$in2.mu_UB[i] = tmp[2]
	})

	try({
	NS = min(c(nrow(mcmc_1), nrow(mcmc_2)))
	muDiff_vec = mcmc_1$mu[1:NS] - mcmc_2$mu[1:NS]
	input_DF$muDiff.simu_num[i] = NS
	input_DF$muDiff_mean[i] = mean(muDiff_vec)
	tmp = hdi(muDiff_vec)
	input_DF$muDiff_LB[i] = tmp[1]
	input_DF$muDiff_UB[i] = tmp[2]
	input_DF$muDiff_gt0_posterior[i] = mean(muDiff_vec > 0)
	input_DF$muDiff_gt0_01_posterior[i] = mean(muDiff_vec > 0.01)
	input_DF$muDiff_gt0_05_posterior[i] = mean(muDiff_vec > 0.05)
	input_DF$muDiff_gt0_1_posterior[i] = mean(muDiff_vec > 0.1)
	})
}
write.table(input_DF[real_pos_range,], file=output_prefix %.% ".final_" %.% min(pos_range) %.% "_" %.% max(pos_range) %.% ".stat.txt", row.names=FALSE, sep="\t", quote=FALSE)

for(gt_str in c("0", "0_01", "0_05", "0_1")){
	input_DF[["muDiff_gt" %.% gt_str %.% "_PEP"]] = 1 - input_DF[["muDiff_gt" %.% gt_str %.% "_posterior"]]
	input_DF[["muDiff_gt" %.% gt_str %.% "_FDR"]] = PEP_to_qvalues(input_DF[["muDiff_gt" %.% gt_str %.% "_PEP"]])
}
write.table(input_DF[real_pos_range,], file=output_prefix %.% ".final_" %.% min(pos_range) %.% "_" %.% max(pos_range) %.% ".stat.txt", row.names=FALSE, sep="\t", quote=FALSE)


library(dplyr)
library(ggplot2)

tdpos <- read.csv("TDs-8threfposition.csv", encoding = "UTF-8") #data fro the IT

numpercons <- tdpos %>%
  group_by(Constituency) %>%
  summarise(ntd = n())

tdpos4 <- tdpos %>%
  group_by(Q.1, Constituency) %>%
  summarise(count=n()) %>%
  left_join(numpercons, by="Constituency") %>%
  mutate(perctd = 100*count/ntd)

prelim <- read.csv("prelim2.csv")
prelim$pc <- "% Yes vote"
prelim$consord <- factor(prelim$Constituency, levels=prelim$Constituency[order(prelim$percyes)])

tdpos4 <- tdpos4 %>%
  left_join(prelim, by='Constituency')

#1st plot: unordered

(p= ggplot(tdpos4, aes(x=Constituency, fill=Q.1, y=perctd)) +
    geom_bar(stat='identity', alpha=0.65) +
    scale_fill_manual(values=c("red3", "cornflower blue", "forest green"), name="TDs' stated position") +
    theme_minimal() +
    ylab("% Yes vote \n TD positions") +
    theme(axis.text.x = element_text(angle = 80, hjust = 1, size=7)) +
    ggtitle("Do TDs' positions on the 8th match their constituents'?", subtitle=" Ireland's 8th Amendment repeal referendum 2018 \n Source: Irish Times Abortion Referendum Tracker")+
    geom_point(data=prelim ,inherit.aes=F, aes(x=Constituency, y=percyes, colour=pc), size=6) +
    scale_colour_manual(values="yellow2", name= "Referendum vote")
)

ggsave("tdvsconstit8th.png", plot=p, device="png", height=7, width=11,dpi=300)

#2nd plot: ordered by yes vote

(p= ggplot(tdpos4, aes(x=consord, fill=Q.1, y=perctd)) +
    geom_bar(stat='identity', alpha=0.65) +
    scale_fill_manual(values=c("red3", "cornflower blue", "forest green"), name="TDs' stated position") +
    theme_minimal() +
    ylab("% Yes vote \n TD positions") +
    theme(axis.text.x = element_text(angle = 80, hjust = 1, size=7)) +
    ggtitle("Do TDs' positions on the 8th match their constituents'?", subtitle=" Ireland's 8th Amendment repeal referendum 2018 \n Source: Irish Times Abortion Referendum Tracker")+
    geom_point(data=prelim ,inherit.aes=F, aes(x=Constituency, y=percyes, colour=pc), size=6) +
    scale_colour_manual(values="yellow2", name= "Referendum vote") +
    xlab("Constituency")
)

ggsave("tdvsconstit8thord.png", plot=p, device="png", height=7, width=11,dpi=300)


executeKMeans <- function (dataSetTransformed, base, definitions, executionStatus) {

  # loading packages
  loadRankingPackages()

  # loading functions
  source(here("R/functions", "coverage.r"))
  source(here("R/functions", "utils.r"))
  source(here("R/functions", "chart.r"))

  # generating a random folder name
  folderName <- randomName()
  folderName <- paste("K", executionStatus$BaseSelected, folderName, sep="_")
  createPath(here("R/results", executionStatus$Tecnique, folderName))

  executionStatus$IdExecution <- folderName

  # CONSTANTS
  K <- executionStatus$params$tecnique$k
  numberOfAttributes <- length(as.array(names(dataSetTransformed)))

  # execução do k-means
  test <- kmeans(dataSetTransformed[,2:numberOfAttributes], centers = K)

  # cluster of ideal system
  get_cluster <- head(test$cluster,1)

  # recuperando os sistemas no mesmo cluster
  systems_candidates <- dataSetTransformed[test$cluster==get_cluster,]

  #mostrando os sistemas candidatos
  #View(systems_candidates)

  #plotcluster(systems_candidates[,2:numberOfAttributes], test$cluster)

  #clusplot(systems_candidates[,2:numberOfAttributes], test$cluster, color=TRUE, shade=TRUE,  labels=4, lines=0)

  executionStatus$AmountOfRecomendedSystems <- nrow(systems_candidates)

  if(nrow(systems_candidates) < executionStatus$amountOfCandidatesRecomendation)
  closest_systems_candidates <- systems_candidates[0:nrow(systems_candidates),]
  else
    closest_systems_candidates <- systems_candidates[0:executionStatus$amountOfCandidatesRecomendation,]

  # coverage status
  executionStatus <- calculateCoverageStatus(closest_systems_candidates, executionStatus, folderName)

  # generate HeatMap
  generateHeatMap(closest_systems_candidates, executionStatus, folderName)

  executionStatus
}


# There are some config parameters that depends on the data it-self. In this file we are going to create the functions
# that allow us to compute the best config parameter for Data Processing in the doubletScores step.

# To identify intelligently the treshold we are going to use the logic inside scDblFinder, which creates a classification
# (singlet our doublet) [ref: https://bioconductor.org/packages/release/bioc/vignettes/scDblFinder/inst/doc/2_scDblFinder.html#thresholding-and-local-calibration]
# To set the auto value we are going to use as a threshold the maximun score that is given to a singlet.

doubletScores_config <- function(scdata, config){

    # Minimun score that has a singlet
    probabilityThreshold <-  max(scdata$doublet_scores[scdata$doublet_class%in%"singlet"])
    # update config
    config$filterSettings$probabilityThreshold <- probabilityThreshold

    return(config)
}


## Calling Libraries
library('dplyr')
library('tidyr')
library('highcharter')
library('rio')

setwd("/home/rstudio/homework-1") # Change Working Directory
raw <-rio::import("臺北捷運每日分時各站OD流量統計資料_202008_UTF8.csv") # Import Raw Data - Variable = raw
raw <- raw %>% rename(
  日期 = V1,
  時段 = V2,
  進站 = V3,
  出站 = V4,
  人次 = V5
)

raw = subset(raw, select = -c(日期))

# 南京復興 出站 - 所有進站
南京復興_出站 <-arrange(filter(raw,出站=='南京復興'))
南京復興_出站 = subset(南京復興_出站, select = -c(進站, 出站))
南京復興_出站 <- (南京復興_出站 %>% group_by(時段) %>%
  complete(時段 = 0:max(時段), fill = list(人次 = 0)) %>%
  summarise_all(sum)
)

# 淡水 出站 - 所有進站
淡水_出站 <-arrange(filter(raw,出站=='淡水'))
淡水_出站 = subset(淡水_出站, select = -c(進站, 出站))
淡水_出站 <- (淡水_出站 %>% group_by(時段) %>%
  complete(時段 = 0:max(時段), fill = list(人次 = 0)) %>%
  summarise_all(sum)
)

# 新店 出站 - 所有進站
新店_出站 <-arrange(filter(raw,出站=='新店'))
新店_出站 = subset(新店_出站, select = -c(進站, 出站))
新店_出站 <- (新店_出站 %>% group_by(時段) %>%
  complete(時段 = 0:max(時段), fill = list(人次 = 0)) %>%
  summarise_all(sum)
)

highchart() %>% hc_xAxis(categories = 南京復興_出站$時段, title = list(text = "小時(整點)")) %>%
  hc_yAxis(title = list(text = "人次")) %>%
  hc_add_series(name = "南京復興出站", data = 南京復興_出站$人次)%>%
  hc_add_series(name = "淡水出站", data = 淡水_出站$人次)%>%
  hc_add_series(name = "新店出站", data = 新店_出站$人次)


#' @title Calculate the number of eligible controls for each case for a nested
#' case control study
#'
#' @description
#' \code{ncc_eligible_controls} calculates the number of eligible controls for each
#' case for a nested case control study. Given time of entry, time of exit, and
#' exit status,
#' risk sets are computed at each failure time. If matching variables are specified,
#' \code{ncc_eligible_controls} creates matched or stratified risk sets,
#' which are computed separately within matching strata.
#'
#' @param entry time of entry to follow-up
#' @param exit time of exit from follow-up
#' @param fail indicator of status on exit from follow-up (censored=0, fail=1)
#' @param origin the origin of the analysis time-scale. For instance, date of
#' birth, if age is the desired time-scale.
#' @param match a list of categorical variables for matching cases and controls
#' @param data a \code{\link{data.frame}} which contains the follow-up and
#' matching variables.
#' @param include a list of variables to include in the returned data.frame
#' @param silent if \code{FALSE}, provides entertainment by echoing a fullstop
#' to the screen as each risk set is generated. If TRUE, output to the
#' console is suppressed.
#'
#' @details
#' Given follow-up information from a cohort study, \code{ncc_eligible controls}
#'  generates
#' risk sets at each observed failure time, and counts the number of eligible
#' controls within each risk set. This information can be used to calculate the
#' probability of inclusion in the NCC study (see \code{\link{ncc_selection_prob}})
#'
#'
#' @return
#' A \code{data.frame} comprising:
#' \item{ncc_id}{a unique individual identifier}
#' \item{ncc_elig_co}{a count of the number of controls eligible for selection
#' in the set}
#'
#' followed by the variables specified in the \code{match} and \code{include}
#' lists.
#'
#' @author David C Muller
#'
#' @import data.table
#' @export
#'
ncc_eligible_controls <- function(entry = 0, exit, fail, origin = 0,
                       match = list(), include = list(), data = NULL,
                       silent = FALSE) {
  entry <- eval(substitute(entry), data)
  exit <- eval(substitute(exit), data)
  fail <- eval(substitute(fail), data)
  origin <- eval(substitute(origin), data)
  n <- length(fail)
# individual id for identifying sets of split records
  ncc_id <- 1:n
# add this id to the supplied data frame for later merging
  data <- data.table(data)
  data[, "ncc_id" := ncc_id]
  if (length(exit) != n) {
    stop("All vectors must have length")
  }
  if (length(entry) == 1) {
    entry <- rep(entry, n)
  }
  else {
    if (length(entry) != n) {
      stop("All vectors must have same length")
    }
  }
  if (length(origin) == 1) {
    origin <- rep(origin, n)
  }
  else {
    if (length(origin) != n)
      stop("All vectors must have same length")
  }
  t_entry <- as.numeric(entry - origin)
  t_exit <- as.numeric(exit - origin)

  # process matching vectors
  arg_match <- substitute(match)
  match <- lapply(arg_match, eval, data)
  names(match) <- as.character(arg_match)
  if (names(match[1]) == "list" && class(match[[1]]) == "function") {
    match[1] <- NULL
  }
  match_names <- names(match)

  # process 'included' vectors
  arg_inc <- substitute(include)
  include <- lapply(arg_inc, eval, data)
  names(include) <- as.character(arg_inc)
  if (names(include[1]) == "list" && class(include[[1]]) == "function") {
    include[1] <- NULL
  }
  inc_names <- names(include)

  grp <- rep(1, n)
  if (length(match) > 0) {
    grp <- as.numeric(factor(do.call(paste0, match)))
  }
  if (!silent) {
    cat("\nGenerating risk sets:\n")
  }
  fg <- unique(grp[fail != 0])
  gresult <- vector("list", length(fg))
  # index for groups
  gii <- 0
  set <- 0
  ties <- 0
  for (g in fg) {
    gii <- gii + 1
    ft <- unique(t_exit[(grp == g) & (fail != 0)])
    ft <- ft[order(ft)]
    tresult <- vector("list", length(ft))

    # index for times
    for (tii in 1:length(ft)) {
      t_end <- ft[tii]
      case <- (grp == g) & (t_exit == t_end) & (fail != 0)
      ncase <- sum(case)
      if (ncase > 1) {
        ties <- ties + 1
      }
      # split tied failures
      sresult <- vector("list", ncase)
      case_index <- cumsum(case)*case
      for (tjj in 1:ncase) {
        set <- set + 1
        if (!silent) {
          dots <- ifelse((set %% 50 == 0), ". 50\n", ".")
          cat(dots)
        }
        failure <- case & case_index==tjj
        noncase <- (grp == g) & (t_entry <= t_end) & (t_exit >= t_end) & !failure
        n_eligible <- sum(noncase)
        ineligible <- !failure & !noncase
        df <- data.frame(ncc_id   = ncc_id,
                         ncc_set  = set,
                         ncc_fail = failure,
                         nfail    = rep(sum(failure), length(failure)),
                         ncc_elig_co = rep(n_eligible, length(failure)),
                         ncc_time     = rep(t_end, length(failure)),
                         ineligible   = ineligible)
        sresult[[tjj]]<- df[df$ncc_fail==TRUE,,drop=FALSE]
      }
      tresult[[tii]] <- rbindlist(sresult)
    }
    gresult[[gii]] <- rbindlist(tresult)
    rm(tresult)
  }
  tsplit <- rbindlist(gresult)

  # we no longer need the number of failures per set
  #tsplit[, nfail := NULL]

  ncc_frame <- tsplit

  # coerce failure flag to numeric
  # (logical var for case status might confuse people)
  ncc_frame[, ncc_fail := as.numeric(ncc_fail)]

  # merge ncc frame with original data
  setkey(ncc_frame, ncc_id)
  setkey(data, ncc_id)
  res <- data[ncc_frame]
  res <- res[, c(names(ncc_frame), match_names, inc_names), with=FALSE]
  res <- res[order(ncc_set,-ncc_fail), ]
  setkey(res, ncc_set)

  return(res)
}


library(dplyr)
library(tidyr)
library(readr)
library(tibble)
library(ggplot2)
library(tibble)
library(tmap)
library(maptools)
library(rgeos)
library(rgdal)

library(tibble)
uvoz1 <- read_csv("podatki/povprecni_pridelek.csv",
                  locale=locale(encoding="Windows-1250"), na="-") %>%
  rename(kmetijska.kultura=`KMETIJSKE KULTURE`) %>% # presledki so nezaželeni v imenih stolpcev
  gather("leto.regija", "kolicina", -kmetijska.kultura, na.rm=TRUE) %>% # pretvorba v tidy data
  separate(leto.regija, c("leto", "regija"), "(?<=[0-9]) ") %>% # delimo po presledku za številko
  mutate(leto=parse_number(leto)) # leto pretvorimo v števila
uvoz2 <- read_csv("podatki/zivina.csv", # v enem od stolpcev ni podatkov, zato bo treba eksplicitno podati tipe:
                  col_types=cols(`VRSTA ŽIVINE`=col_character(), .default=col_integer()),
                  locale=locale(encoding="Windows-1250"), na=c("N", "z"))  %>%
  rename(vrsta.zivine=`VRSTA ŽIVINE`) %>%
  gather("leto.regija", "stevilo", -vrsta.zivine, na.rm=TRUE) %>%
  separate(leto.regija, c("leto", "regija"),
           " (?=[A-ZČŠŽ])(?!Slovenija)") %>% # delimo po presledku pred veliko črko, razen pred besedo "Slovenija"
  mutate(leto=parse_number(leto))

povprecja.kmetijskih.kultur <- uvoz1 %>% group_by(kmetijska.kultura,regija) %>% summarise(povprecje = mean(kolicina, na.rm = TRUE))
povprecje.kmetijskih.kultur <- povprecja.kmetijskih.kultur %>% group_by(kmetijska.kultura) %>% summarise(povprecje = mean(povprecje, na.rm = TRUE))

#zemljevide za nekaj najpogostejših kultur
povprecja.zivine <- uvoz2 %>% group_by(vrsta.zivine, regija) %>% summarise(povprecje =mean(stevilo, na.rm = TRUE))
povprecje.zivine <- povprecja.zivine %>% group_by(vrsta.zivine) %>% summarise(povprecje=mean(povprecje, na.rm = TRUE))

#kje je najbol razvito gospodarstvo:
povprecje.regije.pridelkov <- povprecja.kmetijskih.kultur %>% group_by(regija) %>% summarise(povprecje = mean(povprecje, na.rm = TRUE))

povprecje.regije.zivine <- povprecja.zivine %>% group_by(regija) %>% summarise(povprecje = mean(povprecje, na.rm = TRUE))
#diagram za povprecje kmetijskih kultur

graf.kultur <-  ggplot(aes(x = kmetijska.kultura, y = povprecje, group=1), data = povprecje.kmetijskih.kultur) + geom_col() + coord_flip() + ggtitle("Povprečje kmetijskih kultur")
graf.zivine <- ggplot(aes(x = vrsta.zivine, y = povprecje, group=1), data = povprecje.zivine) + geom_col() + ggtitle("Povprečje živine")

#preimenovanje regij tako kot v zemljevidu
povprecje.regije.pridelkov$regija[10] <- "Notranjsko-kraška"
povprecje.regije.pridelkov$regija[9] <- "Spodnjeposavska"

povprecje.regije.zivine$regija[10] <- "Notranjsko-kraška"
povprecje.regije.zivine$regija[9] <- "Spodnjeposavska"

zemljevid <- uvozi.zemljevid("https://biogeo.ucdavis.edu/data/gadm3.6/shp/gadm36_SVN_shp.zip", "gadm36_SVN_1", encoding = "UTF-8")

zemljevid1 <- tm_shape(merge(zemljevid, povprecje.regije.pridelkov, by.x="NAME_1", by.y="regija" )) + tm_polygons("povprecje",title="Povprečje") + tm_layout(title="Povprečna razširjenost kmetijskih izdelkov po regijah")

zemljevid2 <- tm_shape(merge(zemljevid, povprecje.regije.zivine, by.x="NAME_1", by.y="regija" )) + tm_polygons("povprecje",title="Povprečje") + tm_layout(title="Povprečna razširjenost živinorejskih pridelkov")


# Load Libraries
library(dplyr)
library(tidyr)
library(stringr)
library(leaflet) # interactive mapping

# read in data
# the data hraf_map.js is taken directly from javascript at https://ehrafworldcultures.yale.edu/ehrafe/mapCultures.do
raw_js = read.delim(
  'hraf_map.js',
  sep = '\t',
  skip = 7,
  stringsAsFactors = F,
  header = F
)

#string manupulation to convert js script into tibble dataframe
raw_js %>%
  as.tbl() %>%
  select(V2) %>%
  filter(str_detect(V2, pattern = 'owc|latitudes|longitudes')) %>%
  separate(
    V2,
    into = c('key', 'index', 'value'),
    sep = "\\[| = ",
    remove = T,
    convert = T,
    fill = "right"
  ) %>%
  mutate_all( ~ gsub("]|;", "", .)) %>%
  pivot_wider(names_from = key, values_from = value) -> clean_hraf

#plot interactive map using leaflet
leaflet(data = clean_hraf) %>%
  addTiles() %>%
  addMarkers( ~ as.numeric(longitudes),
              ~ as.numeric(latitudes),
              popup = ~ owcTerms)