# R script
#
# author: Xavier Devroey

library(ggplot2)
library(moments)
library(boot)
library(tidyverse)

source('dataclean.r')

colorpalette="Spectral" # Use photocopy friendly colors (http://colorbrewer2.org/)

# ------------------------------
# Functions definition
# ------------------------------

getMedian <- function(data,ind,formula){
  # ind is the random indexes for the bootstrap sample
  # samp <- sample(data,ind)
  return(median(data[ind]))
}

getTotalDf <- function(filtered_results){
  total <- data.frame(
    filtered_results %>%
      summarise(
        crashes = n_distinct(case),
        frames = n(),
        min = min(fitness_function_number_of_tries),
        max = max(fitness_function_number_of_tries),
        mean = mean(fitness_function_number_of_tries),
        median = median(fitness_function_number_of_tries),
        variance = var(fitness_function_number_of_tries),
        lowerquartile = quantile(fitness_function_number_of_tries, probs=0.25),
        upperquartile = quantile(fitness_function_number_of_tries, probs=0.75),
        skewness = skewness(fitness_function_number_of_tries),
        kurtosis = kurtosis(fitness_function_number_of_tries),
        cilower = 0,
        ciupper = 0
      )
  )

  b <- boot(data = filtered_results$fitness_function_number_of_tries, statistic=getMedian, R=100000)
  medianCi <- boot.ci(b, type = c("basic"))
  total$cilower <- medianCi$basic[4]
  total$ciupper <- medianCi$basic[5]

  return(total)
}

printApplicationTable <- function(filtered_results){
  df <- data.frame(
    filtered_results %>%
      group_by(application_factor, application_name) %>%
      # For each application, compute the following values
      summarise(
        crashes = n_distinct(case),
        frames = n(),
        min = min(fitness_function_number_of_tries),
        max = max(fitness_function_number_of_tries),
        mean = mean(fitness_function_number_of_tries),
        median = median(fitness_function_number_of_tries),
        variance = var(fitness_function_number_of_tries),
        lowerquartile = quantile(fitness_function_number_of_tries, probs=0.25),
        upperquartile = quantile(fitness_function_number_of_tries, probs=0.75),
        skewness = skewness(fitness_function_number_of_tries),
        kurtosis = kurtosis(fitness_function_number_of_tries),
        cilower = 0,
        ciupper = 0
      )
  )

  # Adding CI lower and higher values
  for (app in df$application_factor) {
    x <- filtered_results %>%
      filter(application_factor == app)
    b <- boot(data = x$fitness_function_number_of_tries, statistic=getMedian, R=100000)
    medianCi <- boot.ci(b, type = c("basic"))
    df$cilower[df$application_factor == app] <- medianCi$basic[4]
    df$ciupper[df$application_factor == app] <- medianCi$basic[5]
  }

  # Print table
  cat("\\begin{tabularx}{\\textwidth}{ l r r r R{1} r r R{1} r }", "\n")
  #cat("\\begin{tabularx}{\\textwidth}{ l r r r R{1} R{1} r R{1} r r r }", "\n")
  cat("\\hline", "\n")
  #cat("\\textbf{Applications} & \\textbf{st} & \\textbf{fr}& \\textbf{Min} & \\textbf{Lower Quart.} & \\textbf{Median CI} & \\textbf{Median} & \\textbf{Upper Quart.} & \\textbf{Max} & \\textbf{Skew.} & \\textbf{Kurt.} \\\\", "\n")
  cat("\\textbf{Applications} & \\textbf{st} & \\textbf{fr}& \\textbf{Min} & \\textbf{Lower Quart.} & \\textbf{Median CI} & \\textbf{Median} & \\textbf{Upper Quart.} & \\textbf{Max} \\\\", "\n")
  cat("\\hline", "\n")
  for (app in df$application_factor) {
    x <- df %>%
      filter(application_factor == app)
    cat("\\textbf{", x$application_name,"} & ");
    cat(x$crashes," & ");
    cat(x$frames," & ");
    cat(x$min," & ");
    cat(formatC(x$lowerquartile, digits=1, format="f", big.mark = ',')," & ");
    cat("[", formatC(x$cilower, digits=1, format="f", big.mark = ','),";", formatC(x$ciupper, digits=1, format="f", big.mark = ','), "]" ," & ", sep = "");
    cat(formatC(x$median, digits=1, format="f", big.mark = ',')," & ");
    cat(formatC(x$upperquartile, digits=1, format="f", big.mark = ',')," & ");
    cat(formatC(x$max, format="d", big.mark = ',')," ");
    # cat(formatC(x$max, format="d", big.mark = ',')," & ");
    # cat(formatC(x$skewness, digits=2, format="f", big.mark = ',')," & ");
    # cat(formatC(x$kurtosis, digits=2, format="f", big.mark = ',')," ");
    cat("\\\\", "\n")
  }
  x <- getTotalDf(filtered_results)
  cat("\\hline", "\n")
  cat("\\textbf{Total} & ");
  cat(x$crashes," & ");
  cat(x$frames," & ");
  cat(x$min," & ");
  cat(formatC(x$lowerquartile, digits=1, format="f", big.mark = ',')," & ");
  cat("[", formatC(x$cilower, digits=1, format="f", big.mark = ','),";", formatC(x$ciupper, digits=1, format="f", big.mark = ','), "]" ," & ", sep = "");
  cat(formatC(x$median, digits=1, format="f", big.mark = ',')," & ");
  cat(formatC(x$upperquartile, digits=1, format="f", big.mark = ',')," & ");
  cat(formatC(x$max, format="d", big.mark = ',')," ");
  # cat(formatC(x$max, format="d", big.mark = ',')," & ");
  # cat(formatC(x$skewness, digits=2, format="f", big.mark = ',')," & ");
  # cat(formatC(x$kurtosis, digits=2, format="f", big.mark = ',')," ");
  cat("\\\\", "\n")
  cat("\\hline", "\n")
  cat("\\end{tabularx}", "\n")
}

printExceptionTable <- function(filtered_results){
  df <- data.frame(
    filtered_results %>%
      group_by(exception_factor, exception) %>%
      # For each application, compute the following values
      summarise(
        crashes = n_distinct(case),
        frames = n(),
        min = min(fitness_function_number_of_tries),
        max = max(fitness_function_number_of_tries),
        mean = mean(fitness_function_number_of_tries),
        median = median(fitness_function_number_of_tries),
        variance = var(fitness_function_number_of_tries),
        lowerquartile = quantile(fitness_function_number_of_tries, probs=0.25),
        upperquartile = quantile(fitness_function_number_of_tries, probs=0.75),
        skewness = skewness(fitness_function_number_of_tries),
        kurtosis = kurtosis(fitness_function_number_of_tries),
        cilower = 0,
        ciupper = 0
      )
  )

  # Adding CI lower and higher values
  for (ex in df$exception_factor) {
    x <- filtered_results %>%
      filter(exception_factor == ex)
    b <- boot(data = x$fitness_function_number_of_tries, statistic=getMedian, R=100000)
    medianCi <- boot.ci(b, type = c("basic"))
    df$cilower[df$exception_factor == ex] <- medianCi$basic[4]
    df$ciupper[df$exception_factor == ex] <- medianCi$basic[5]
  }

  # Print table
  cat("\\begin{tabularx}{\\textwidth}{ l r r r R{1} r r R{1} r }", "\n")
  # cat("\\begin{tabularx}{\\textwidth}{ l r r r R{1} R{1} r R{1} r r r }", "\n")
  cat("\\hline", "\n")
  # cat("\\textbf{Exception kind} & \\textbf{st} & \\textbf{fr}& \\textbf{Min} & \\textbf{Lower Quart.} & \\textbf{Median CI} & \\textbf{Median} & \\textbf{Upper Quart.} & \\textbf{Max} & \\textbf{Skew.} & \\textbf{Kurt.} \\\\", "\n")
  cat("\\textbf{Exception kind} & \\textbf{st} & \\textbf{fr}& \\textbf{Min} & \\textbf{Lower Quart.} & \\textbf{Median CI} & \\textbf{Median} & \\textbf{Upper Quart.} & \\textbf{Max} \\\\", "\n")
  cat("\\hline", "\n")
  for (ex in df$exception_factor) {
    x <- df %>%
      filter(exception_factor == ex)
    cat("\\textbf{", x$exception,"} & ");
    cat(x$crashes," & ");
    cat(x$frames," & ");
    cat(x$min," & ");
    cat(formatC(x$lowerquartile, digits=1, format="f", big.mark = ',')," & ");
    cat("[", formatC(x$cilower, digits=1, format="f", big.mark = ','),";", formatC(x$ciupper, digits=1, format="f", big.mark = ','), "]" ," & ", sep = "");
    cat(formatC(x$median, digits=1, format="f", big.mark = ',')," & ");
    cat(formatC(x$upperquartile, digits=1, format="f", big.mark = ',')," & ");
    cat(formatC(x$max, format="d", big.mark = ',')," ");
    # cat(formatC(x$skewness, digits=2, format="f", big.mark = ',')," & ");
    # cat(formatC(x$kurtosis, digits=2, format="f", big.mark = ',')," ");
    cat("\\\\", "\n")
  }
  x <- getTotalDf(filtered_results)
  cat("\\hline", "\n")
  cat("\\textbf{Total} & ");
  cat(x$crashes," & ");
  cat(x$frames," & ");
  cat(x$min," & ");
  cat(formatC(x$lowerquartile, digits=1, format="f", big.mark = ',')," & ");
  cat("[", formatC(x$cilower, digits=1, format="f", big.mark = ','),";", formatC(x$ciupper, digits=1, format="f", big.mark = ','), "]" ," & ", sep = "");
  cat(formatC(x$median, digits=1, format="f", big.mark = ',')," & ");
  cat(formatC(x$upperquartile, digits=1, format="f", big.mark = ',')," & ");
  cat(formatC(x$max, format="d", big.mark = ',')," ");
  # cat(formatC(x$skewness, digits=2, format="f", big.mark = ',')," & ");
  # cat(formatC(x$kurtosis, digits=2, format="f", big.mark = ',')," ");
  cat("\\\\", "\n")
  cat("\\hline", "\n")
  cat("\\end{tabularx}", "\n")
}

plotFrameLevelsPerException <- function(majority){
  reproduction <- getReproduceStatus(majority) %>%
    filter(status == STATUS_LEVELS[2])
  # Add (all) applications
  # allApps <- reproduction %>%
  #   mutate(application_name = '(all)')
  # allApps$application_factor = factor(allApps$application_name, levels = c(levels(allApps$application_factor), '(all)'))
  # Add (all) exception
  allEx <- reproduction %>%
    mutate(exception = '(all)')
  allEx$exception_factor = factor(allEx$exception, levels = c(levels(allEx$exception_factor), '(all)'))
  df <- allEx %>%
    rbind(reproduction) %>%
    group_by(exception_factor, highest, status_factor) %>%
    summarise(n = n()) %>%
    mutate(Frequency = n / sum(n), label = paste0(n))
  p <- ggplot(df, aes(x = exception_factor, y = highest, size = n, label = n)) +
    geom_point(shape = 1, colour = "black", fill = "lightblue") +
    geom_text(color="black", size=3) +
    scale_size_continuous(range = c(5, 15)) +
    theme(legend.position="none", axis.text.x = element_text(angle = 45, hjust = 1)) +
    xlab(NULL) +
    ylab('Highest reproduced frame level')
  return(p)
}

plotFrameLevelsPerApplication <- function(majority){
  reproduction <- getReproduceStatus(majority) %>%
    filter(status == STATUS_LEVELS[2])
  # Add (all) applications
  allApps <- reproduction %>%
    mutate(application_name = '(all)')
  allApps$application_factor = factor(allApps$application_name, levels = c(levels(allApps$application_factor), '(all)'))
  # # Add (all) exception
  # allEx <- reproduction %>%
  #   mutate(exception = '(all)')
  df <- allApps %>%
    # rbind(allEx) %>%
    rbind(reproduction) %>%
    group_by(application_factor, highest, status_factor) %>%
    summarise(n = n()) %>%
    mutate(Frequency = n / sum(n), label = paste0(n))
  p <- ggplot(df, aes(x = application_factor, y = highest, size = n, label = n)) +
    geom_point(shape = 1, colour = "black", fill = "white") +
    geom_text(color="black", size=3) +
    scale_size_continuous(range = c(5, 15)) +
    theme(legend.position="none", axis.text.x = element_text(angle = 45, hjust = 1)) +
    xlab(NULL) +
    ylab('Highest reproduced frame level')
  return(p)
}

# ------------------------------
# Main function definition
# ------------------------------

main <- function(){
  results <- getResults()
  majority <- getMostFrequentResult()

  p <- plotFrameLevelsPerException(majority)
  ggsave(plot = p, filename = '../plots/rq1_framelvlex.pdf', width=100, height=100, units = "mm" )

  p <- plotFrameLevelsPerApplication(majority)
  ggsave(plot = p, filename = '../plots/rq1_framelvlapp.pdf', width=100, height=100, units = "mm" )

  # Filter results to keep only those that have been most frequently reproduced
  filtered_results <- results %>%
    semi_join(majority, by = c("case", "frame_level")) %>%
    filter(result == "reproduced")

  outputFile <- "../tables/tab-excepstats.tex"
  unlink(outputFile)
  # Redirect cat outputs to file
  sink(outputFile, append = TRUE, split = TRUE)
  printExceptionTable(filtered_results)
  # Restore cat outputs to console
  sink()

  outputFile <- "../tables/tab-appstats.tex"
  unlink(outputFile)
  # Redirect cat outputs to file
  sink(outputFile, append = TRUE, split = TRUE)
  printApplicationTable(filtered_results)
  # Restore cat outputs to console
  sink()

  p <- ggplot(filtered_results, aes(x = exception_factor, y = fitness_function_number_of_tries, fill = exception_factor)) +
    geom_boxplot() +
    scale_y_log10() +
    ylab("Number of fitness evaluation (log. scale)") +
    guides(fill=FALSE) +
    scale_fill_brewer(palette=colorpalette) +
    theme(axis.text.x = element_text(angle = 90, hjust = 1))
  ggsave(plot = p, filename = '../plots/rq2_excepstats.pdf', width=100, height=100, units = "mm" )

  p <- ggplot(filtered_results, aes(x = application_factor, y = fitness_function_number_of_tries, fill = application_factor)) +
    geom_boxplot() +
    scale_y_log10() +
    ylab("Number of fitness evaluation (log. scale)") +
    guides(fill=FALSE) +
    scale_fill_brewer(palette=colorpalette) +
    theme(axis.text.x = element_text(angle = 90, hjust = 1))
  ggsave(plot = p, filename = '../plots/rq2_appstats.pdf', width=100, height=100, units = "mm" )

  p <- ggplot(filtered_results, aes(x = application_factor, y = fitness_function_number_of_tries, fill = application_factor)) +
    geom_boxplot(outlier.shape = NA) +
    facet_grid(exception_factor ~ application_factor, scales="free_x", margins = TRUE) +
    scale_y_log10() +
    ylab("Number of fitness evaluation (log. scale)") +
    theme(axis.title.x=element_blank(),
          axis.text.x=element_blank(),
          axis.ticks.x=element_blank()) +
    guides(fill=FALSE) +
    scale_fill_brewer(palette=colorpalette)
  ggsave(plot = p, filename = '../plots/rq2_excepappstats.pdf', width=230, height=250, units = "mm" )

  # Getting extreme cases for each exception type
  for(ex in distinct(filtered_results, exception_factor)$exception_factor){
    cat("Costliest case for exception ", ex, "\n")
    df <- filtered_results %>%
      filter(exception_factor == ex) %>%
      top_n(1, fitness_function_number_of_tries) %>%
      select(application, case, frame_level, exception, exception_name, fitness_function_number_of_tries)
    print(df)
  }

  for(ex in distinct(filtered_results, exception_factor)$exception_factor){
    cat("Chepeast case for exception ", ex, "\n")
    df <- filtered_results %>%
      filter(exception_factor == ex) %>%
      arrange(fitness_function_number_of_tries) %>%
      slice(1) %>%
      select(application, case, frame_level, exception, exception_name, fitness_function_number_of_tries)
    print(df)
  }

  # Getting extreme cases for each application
  for(app in distinct(filtered_results, application)$application){
    cat("Extreme case for application ", app, "\n")
    df <- filtered_results %>%
      filter(application == app) %>%
      top_n(1, fitness_function_number_of_tries) %>%
      select(application, case, frame_level, exception, exception_name, fitness_function_number_of_tries)
    print(df)
  }

}

# ------------------------------
# Program
# ------------------------------

main()


library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(dplyr)
library(tidyr)
library(EnvStats)
library(scales)
library(stringr)
library(abind)

process_covariates <- function(countries, interventions, d, ifr.by.country,N2){
  serial.interval = read.csv("data/serial_interval.csv")
  # Pads serial interval with 0 if N2 is greater than the length of the serial
  # interval array
  if (N2 > length(serial.interval$fit)) {
    pad_serial.interval <- data.frame(
      "X"=(length(serial.interval$fit)+1):N2,
      "fit"=rep(1e-17, max(N2-length(serial.interval$fit), 0 ))
    )
    serial.interval = rbind(serial.interval, pad_serial.interval)
  }
  # various distributions required for modeling
  mean1 <- 5.1; cv1 <- 0.86; # infection to onset
  mean2 <- 17.8; cv2 <- 0.45 # onset to death
  x1 <- rgammaAlt(1e6,mean1,cv1) # infection-to-onset distribution
  x2 <- rgammaAlt(1e6,mean2,cv2) # onset-to-death distribution

  ecdf.saved <- ecdf(x1+x2)
  forecast <- 0
  dates <- list()
  reported_cases <- list()
  stan_data <- list(M=length(countries$Regions),N=NULL,deaths=NULL,f=NULL,
                   N0=6,cases=NULL,SI=serial.interval$fit[1:N2],features=NULL,
                   EpidemicStart = NULL, pop = NULL)
  deaths_by_country <- list()
  covariate_list <- list()
  k=1
  # going over each region
  for (Country in countries$Regions){
    IFR <- ifr.by.country$ifr[ifr.by.country$country == Country]
    region_pop <- ifr.by.country[ifr.by.country$country==Country,]
    region <- d[d$Country==Country,]
    region$DateRep <-region$DateRep
    region <-region[order(as.Date(region$DateRep)),]  # ensure date ordering

    # padding in raw data backwards ex. portugal
    date_min <- dmy('31/12/2019')
    if (region$DateRep[1] > date_min){
      print(paste(Country,'In padding ECDC data'))
      pad_days <-region$DateRep[1] - date_min
      pad_dates <- date_min + days(1:pad_days[[1]]-1)
      padded_data <- data.frame("Country" = rep(Country, pad_days),
                                "DateRep" = pad_dates,
                                "Cases" = as.integer(rep(0, pad_days)),
                                "Deaths" = as.integer(rep(0, pad_days)),
                                stringsAsFactors=F)

     region <- bind_rows(padded_data,region)
    }
    index = which(region$Cases>0)[1]
    index1 = which(cumsum(region$Deaths)>=10)[1] # also 5
    index2 = index1-30

    print(sprintf("First non-zero cases is on day %d, and 30 days before 10 deaths is day %d",index,index2))
    region=region[index2:nrow(region),]
    stan_data$EpidemicStart = c(stan_data$EpidemicStart,index1+1-index2)
    stan_data$pop = c(stan_data$pop,region_pop$popt)
    # NPI interventionss are being used
    interventions_region <- interventions[interventions$Country == Country, c(2,3,4,5,6)] # school, self-isolation, public, lockdown, social-distancing
    for (ii in 1:ncol(interventions_region)) {
      covariate = names(interventions_region)[ii]
      region[covariate] <- (region$DateRep >= interventions_region[1,covariate])*1  # should this be > or >=?
    }

    dates[[Country]] =region$DateRep
    # hazard estimation
    N = length(region$Cases)
    print(sprintf("%s has %d days of data",Country,N))
    forecast = N2 - N
    if(forecast < 0) {
      print(sprintf("%s: %d", Country, N))
      print("ERROR!!!! increasing N2")
      N2 = N
      forecast = N2 - N
    }

    # IFR is the overall probability of dying given infection
    convolution = function(u) (IFR * ecdf.saved(u))

    f = rep(0,N2) # f is the probability of dying on day i given infection
    f[1] = (convolution(1.5) - convolution(0))
    for(i in 2:N2) {
      f[i] = (convolution(i+.5) - convolution(i-.5))
    }
    reported_cases[[Country]] = as.vector(as.numeric(region$Cases))
    deaths=c(as.vector(as.numeric(region$Deaths)),rep(-1,forecast))
    cases=c(as.vector(as.numeric(region$Cases)),rep(-1,forecast))
    deaths_by_country[[Country]] = as.vector(as.numeric(region$Deaths))
    region_intervention <- as.data.frame(region[, colnames(interventions_region)])
    region_intervention[N:(N+forecast),] <- region_intervention[N,]
    school =region_intervention[,1]
    selfIsolation =region_intervention[,2]
    publicEvents = region_intervention[,3]
    lockdown = region_intervention[,4]
    socialDistancing = region_intervention[,5]
    firstIntervention = 1*((school+ selfIsolation+ publicEvents+ lockdown + socialDistancing) >= 1)
    ## append data
    stan_data$N = c(stan_data$N,N)
    # stan_data$x = cbind(stan_data$x,x)
    stan_data$f = cbind(stan_data$f,f)
    stan_data$deaths = cbind(stan_data$deaths,deaths)
    stan_data$cases = cbind(stan_data$cases,cases)

    stan_data$N2=N2
    stan_data$x=1:N2
    if(length(stan_data$N) == 1) {
      stan_data$N = as.array(stan_data$N)
    }
    df_features = data.frame('school' = school, 'selfIsolation' = selfIsolation, 'publicEvents' = publicEvents,
                             'firstIntervention' = firstIntervention, 'lockdown' = lockdown, 'socialDistancing' = socialDistancing)
    features <- as.matrix(df_features)
    covariate_list[[k]] <- features
    k <- k+1
  }
  stan_data$P = dim(features)[2]
  stan_data$X = array(NA, dim = c(stan_data$M , stan_data$N2 ,stan_data$P ))
  for (i in 1:stan_data$M){
    stan_data$X[i,,] = covariate_list[[i]]
  }
  return(list("stan_data" = stan_data, "dates" = dates, "reported_cases"=reported_cases, "deaths_by_country" = deaths_by_country))
}


#' linear_dirlichet_jags
#' Fits a multivariate dirlichet model to species relative abundances as a linear combination of predictors and parameters.
#' Models are fit in JAGS.
#' requires runjags package.
#' requires multiple other functinos in the NEFI_microbe/NEFI_functions directory.
#'
#' @param x_mu data.frame or matrix of predictors, with column names.
#' @param x_sd data.frame or matrix of predictor sd values. Column names should map from x_mu to x_sd as mat -> mat_sd or mat.sd or matSD (or similar)
#' @param y data.frame or matrix of species, with column names.
#' @param n.chains number of chains to run
#' @param adapt number of adaptive iterations
#' @param burnin number of burnin iterations
#' @param sample number of samples to draw post burnin
#'
#' @return returns a list containing the jags model, a list of parameter tables by species, a list of predicted, observed, residuals by species on (0-1) scale.
#' @export
#'
#' @examples
#' #load tedersoo data.
#' library(data.table)
#' d <- data.table(readRDS('/fs/data3/caverill/NEFI_microbial/prior_data/ted_all_prior_data.rds'))
#'
#' d <- d[,.(Ectomycorrhizal, Saprotroph, Arbuscular, Pathogen, mat, map, mat_sd, map_sd, cn, pH, doy)]
#' d <- d[complete.cases(d),]
#'
#' #define matrix of dependent variables (y)
#' y <- d[,.(Ectomycorrhizal, Saprotroph)]
#'
#' #setup predictors (x)
#' d$intercept <- rep(1,nrow(d))
#' x_mu <- d[,.(intercept,map)]
#'
#' #setup x_sd
#' x_sd <- d[,.(mat_sd,map_sd)]
#'
#' #Run function.
#' linear_dirlichet_jags(x_mu=x_mu, x_sd=x_sd, y=y, z.trans = T, sample = 800)

linear_dirlichet_jags <- function(y, x_mu, x_sd, z.trans = F, n.chains = 3, adapt = 100, burnin = 200, sample = 400, parallel = F){

  #source some other functions.
  source('/home/caverill/NEFI_microbe/NEFI_functions/crib_fun.r')
  source('/home/caverill/NEFI_microbe/NEFI_functions/z_transform.r')
  source('/home/caverill/NEFI_microbe/NEFI_functions/precision_matrix_match.r')

  #Requires first dealing with zero relative abundances dirlichet does not like.
  y <- data.frame(lapply(y, crib_fun))

  #Match up predictors and their SD. if no SD supplied we assign ~perfect precision.
  x_sd <- precision_matrix_match(x_mu,x_sd)

  #z-transform loop. transforms both x obs and associated sd.
  if(z.trans == T){
    sd.out <- data.frame(lapply(x_mu, sd))
    x_mu <- data.frame(lapply(x_mu, z_transform))
    #z-transform SD values in precision matrix.
    for(i in 1:ncol(x_sd)){
        x_sd[,i] <- x_sd[,i] / sd.out[i]
    }
  }

  #convert SD to precision values
  for(i in 1:ncol(x_sd)){
      x_sd[,i] <- 1/(x_sd[,i]^2)
  }
  x_precision <- x_sd

  #specify JAGS model. This is general for any linear combination of x's.
  jags.model = "
  model {
    #setup parameter priors for each species * predictor combination.
    for(j in 1:N.spp){
      for(k in 1:N.preds){
        m[k,j] ~ dnorm(0, 1.0E-4)
      }
    }

    #account for uncertainty in predictors
    for(j in 1:N.preds){
      for(i in 1:N){
        x[i,j] ~ dnorm(x_mu[i,j], x_precision[i,j])
      }
    }

    #go ahead and fit means of species abundances as a linear combination of predictors and parameters.
    for(i in 1:N){
        for(j in 1:N.spp){
             log(a0[i,j]) <- inprod(m[,j] , x[i,])
           }
    y[i,1:N.spp] ~ ddirch(a0[i,1:N.spp])
    }

  } #close model loop.
  "

  #setup JAGS data object.
  jags.data <- list(y = as.matrix(y), x_mu = as.matrix(x_mu), x_precision = as.matrix(x_precision),
                    N.spp = ncol(y), N.preds = ncol(x_mu), N = nrow(y))
  #parallel or not parallel.
  run.method <- ifelse(parallel == F,'rjags','rjparallel')

  #run jags model.
  jags.out <- runjags::run.jags(   model = jags.model,
                                    data = jags.data,
                                   adapt = adapt,
                                  burnin = burnin,
                                  sample = sample,
                                n.chains = n.chains,
                                  method = run.method,
                                 monitor = c('m'))
  #summarize output
  out <- summary(jags.out)

  #grab parmeters by species, make a list of species-parameter dataframes
  output.list <- list()
  for(i in 1:ncol(y)){
    z <- out[grep(paste0(',',i,']'),rownames(out)),]
    z <- cbind(names(x_mu),z)
    colnames(z)[1] <- 'predictor'
    output.list[[i]] <- data.frame(z)
  }
  #Species names are the list entry names.
  names(output.list) <- colnames(y)

  #get the matrix of predicted y values.
  pred.list <- list()
  for(i in 1:ncol(y)){
    pred <- exp(as.matrix(x_mu) %*% as.numeric(as.character(output.list[[i]][,4])))
    pred.list[[i]] <- pred
  }
  predicted <- do.call('cbind',pred.list)
  predicted <- predicted / rowSums(predicted)
  colnames(predicted) <- colnames(y)
  #get matrix of residuals
  resid <- y - predicted

  #make a super output that also returns model
  super.list <- list(jags.out, output.list,predicted,y,resid)
  names(super.list) <- c('jags_model','species_parameter_output','predicted','observed','residual')

  #return model and output
  return(super.list)

} ##end function.


# set ticket prices for adults and children
ticket_cost <- 12
ticket_cost_child <- 8

# list 5 of your favorite movies or shows
movies <- c('Public Enemies',
            'Free to Choose',
            'The Psychological Significance of the Biblical Stories',
            'Soft White Underbelly',
            'Scarface')

# how many screens does the theater have? (assume 1 per movie)
screens <- length(movies)

# how many seats does each screen have?
seats <- 50

# make a record book to store total revenue for each day
week_days <- rep(0, 7)

# iterate through each day of the week
for (day in 1:length(week_days)) {

  # keep track of total revenue for this day
  this_days_revenue <- 0

  # iterate through the each of your screens for this day
  for (s in 1:screens) {

    # calculate how many adults and how many children are watching this screen
    visitors_adults <- sample(seats, 1)
    visitors_children <- sample((seats - visitors_adults), 1)

    # calculate this screen's revenue for adults, and for children
    revenue_adults <- visitors_adults * ticket_cost
    revenue_children <- visitors_children * ticket_cost_child

    # calculate this screen's total revenue, and add to running total for the day
    this_screens_revenue_for_today <- revenue_adults + revenue_children
    this_days_revenue <- this_days_revenue + this_screens_revenue_for_today
  }
  # write today's total revenue at it's index in the record book
  week_days[day] <- this_days_revenue
}

# make a barchart showing total revenue per day
barplot(week_days,  # <- what's being plotted
        main = "Total Movie Revenue Per Day",  # chart title
        xlab = "Day of Week",  # x axis label
        ylab = "Revenue (USD)",  # y axis label
        names.arg = c("Sun", "Mon", "Tues", "Wed", "Thurs", "Fri", "Sat"),  # add day labels
        col = "lightblue",  # adjust color
        density = 20,  # adjust how filled in each bar is
        )

# make any other chart
plot(week_days)  # simple scatter plot

# which day had the highest revenue?
index_of_max_value <- which.max(week_days)  # <- asks, which index has the max value?
days_of_the_week <- c("Sun", "Mon", "Tues", "Wed", "Thurs", "Fri", "Sat")
days_of_the_week[index_of_max_value]


# Analyze Data

# Requires loading/entering/computing
#   MOD
#     -the model specification matrix
#     -based on RAM specification in "sem" package
#     -create mod from path diagram (see below)
#   Data
#     -the covariance matrix of the observed variables
#     -variable order should be consistent with MOD

###########################
##Load Required Packages ##
###########################

require('MASS') #Multivariate Normal Distributions
require('matrixcalc') #Special Matrices
require('numDeriv') #Needed to estimate SEs
source('scvm_functions.r') #Custom functions to fit CV models

#######################
## LOAD DATA & MODEL ##
#######################

#Enter data file name here:
Y = read.table('cv_sample_data.dat', header=TRUE)

#Specify MOD file here:
MOD <- read.delim("MOD.dat") ## Read in model here

################################
## Transform and Check Inputs ##
################################

Y = as.matrix(Y)
head(Y)
head(MOD)

###################################
## Count and Selection Variables ##
###################################

#sample size
N = nrow(Y)

#total number of variables
p = max(c(MOD$from,MOD$to))
cat(paste('Total Number of Variables: ',p))
# ***Assumes no unused variables

#number of observed variables
pOBS = ncol(Y)
cat(paste('Number of Observed Variables: ', pOBS))
# ***Assumes variables 1:pOBS are all observed and included in model

#Number of unique covariances
pSTAR = pOBS*(pOBS+1)/2
cat(paste('Number of Unique Covariance Terms: ', pSTAR))

#Select/Identify Paths and Vars
sel.ip  <- (MOD$code == 1)#paths from ivs
sel.dp  <- (MOD$code == 2)#paths between dvs
sel.cov <- (MOD$code == 3)#vars and covs of ivs

#Identify and count (strict) IVs
listIV = unique(MOD$from[sel.ip])
pIV = length(listIV) #includes errors
cat(paste('Number of Strictly Independent Variables: ', pIV))

#Identify and count (all) DVs
listDV = unique(MOD$to[MOD$code != 3])
pDV = length(listDV)
cat(paste('Number of Dependent Variables: ', pDV))

#Select/Identify Free Parameters
sel.fixed <- (MOD$index == 0)
sel.free <- !(sel.fixed)

#number of parameters
qTOT = nrow(MOD)
qFREE = sum(sel.free)
cat(paste('Number of Free Parameter: ', qFREE))
# *** Assumes no constraints on parameters

#df for chi-squared
df = pSTAR - qFREE
cat(paste('Number of Degrees of Freedom: ', df))

############################
## Some Useful Statistics ##
############################

#The mean
M = colMeans(Y)
#Warning: This doesn't return a transposable vector!
DmInv = diag(1/M)
cat('Sample Means:')
print(M)

#Sample Covariance Matrix
S = var(Y)
cat('Sample Covariance Matrix:')
print(S)

#Sample CV Matrix
PsyHat = DmInv %*% S %*% DmInv
cat('Sample Coefficient of Variation (CV) Matrix:')
print(PsyHat)

##########################
## Compute Start Values ##
##########################
MOD = getstart(MOD,S)

#############################################
## Define Matrices for Bentler-Weeks Model ##
#############################################

#Get Matrix G to Select Observed Variables
  G = matrix(0,pOBS,p)
  G[cbind(1:pOBS,1:pOBS)] <- 1
  # ***Assumes variables 1:pOBS are observed and included

#Get Matrix B to relate DVs with DVs (contains "beta and known 0s")
  B = matrix(0,p,p)
  B[cbind(MOD$to[sel.dp],MOD$from[sel.dp])]=MOD$value[sel.dp]

#Define Reindex Function
  #function to recode IVs for Gam, Phi
  reindex <- function(x) {
    #initialize
    xnew = x
    #get ordered list of unique xvals
    sux = sort(unique(x))
    #loop through x
    for(i in 1:length(x)) {
      #loop over unique values
      for(k in 1:length(sux)) {
        if(x[i] == sux[k])
          xnew[i] = k
      }
    }
    xnew
  }

#Get Matrix Gamma to relate IVs with DVs
  #Initialize
    Gam = matrix(0,p,pIV)
  #List IVs with New Unique Indices
    ivfrom = reindex(MOD$from[sel.ip])
  #Calculate Gamma
    Gam[cbind(MOD$to[sel.ip],ivfrom)] = MOD$value[sel.ip]
    Gam[cbind(MOD$from[sel.ip],ivfrom)] = MOD$value[sel.ip]

#Get CovMat Phi containing covs of IVs
  #Initialize
    Phi = diag(1,pIV,pIV)
  #Find Covariances
    these = c(unique(MOD$from[sel.ip]),MOD$to[sel.cov],MOD$from[sel.cov])
  #List Covariances with New Unique Indices
    Cindex = reindex(these)
    Cindex = Cindex[-(1:pIV)]
    Cindex = matrix(Cindex,ncol=2,byrow=F)
  #Put Covariances into Phi Matrix
    Phi[Cindex] = MOD$value[sel.cov]
    Phi = Phi + t(Phi) - diag(diag(Phi))

###########################################
## Get Sampling Variances for ADF Method ##
###########################################

#################
## SigmaHatPsy ##
#################

#Get SigmaPsyHat for CV-SEM Method
  #Identity
    Ip = diag(pOBS)
  #Kronecker Product of CV and Ip
    PsyHatI = kronecker(PsyHat,Ip)
  #Duplication and Elimination Matrices
    Dp = D.matrix(pOBS)
    Hp = solve(t(Dp) %*% Dp) %*% t(Dp)
  #Np (Funky Product of Dup Matrices)
    Np = Dp %*% solve( t(Dp) %*% Dp ) %*% t(Dp)
  #Lp
    Lp=matrix(0,pOBS^2,pOBS)
    for(i in 1:pOBS) {
      Lp = Lp + kronecker(Ip[,i],Ip[,i]) %*% t(Ip[,i])
    }
  #Transform Means Vector
    kronDmInv = kronecker(DmInv,DmInv)
  #Estimate Omegas [Prospectus (3.11) and (3.12)]
    #Get Sums of Products for OmegaHat12 and OmegaHat22
    sumthing12 = matrix(0,pOBS,pOBS^2)
    sumthing22 = matrix(0,pOBS^2,pOBS^2)
      for(i in 1:N) {
        #Precursors for Omega12
        ui = kronecker(Y[i,]-M,Y[i,] - M)
        prodthing12 = (Y[i,] - M) %*% t(ui)
        sumthing12 = sumthing12 + prodthing12
        #Precursors for Omega22
        prodthing22 = ui %*% t(ui)
        sumthing22 = sumthing22 + prodthing22
      }
    #Get OmegaHat12
      OmegaHat12 = N/((N-1)*(N-2))* sumthing12
      OmegaHat12str =DmInv %*% OmegaHat12 %*% kronDmInv
    #Get OmegaHat22
      OmegaHat22 = (sumthing22 - (N-2)*vec(S)%*%t(vec(S)) )/(N-pSTAR-1)
      OmegaHat22str = kronDmInv %*% OmegaHat22 %*% kronDmInv
  #Variance of CV Sampling Distribution [Prospectus (3.15)]
    SigmaHatPsy = (2*Np) %*% PsyHatI %*% Lp %*% PsyHat %*% t(Lp) %*%
      PsyHatI %*% (2*Np) +
      -t(OmegaHat12str) %*% t(Lp) %*% PsyHatI %*% (2*Np) +
      -(2*Np) %*% PsyHatI %*% Lp %*% OmegaHat12str + OmegaHat22str
    SHPinv = solve(Hp %*% SigmaHatPsy %*% t(Hp))
  #Variance of CV Sampling Distribution w/Normality [Prospectus (3.16)]
    SigmaHatPsyN = 2*Np %*% PsyHatI %*% Lp %*% PsyHat %*% t(Lp) %*%
      PsyHatI %*% (2*Np) +
      2*Np %*% kronecker(PsyHat,PsyHat)
    SHPNinv = solve(Hp %*% SigmaHatPsyN %*% t(Hp))

#########################################
## Fit CV Models and Examine Estimates ##
#########################################

#########################
## ADF - CV (Arbitrary)##
#########################

METH = 'ADF Estimation with Arbitrary Distribution'
#Fit Model Using ADFcv procedure
  theta = MOD$value[sel.free]
  rADFcv = plzcon(theta,fADFcv)
  rADFcv$METH = METH
#SEs of ADFcv Estimates
  DeltaADFcv = getDelta(rADFcv,SHPinv)
  rADFcv$SEs = sqrt(diag(DeltaADFcv)/N)
  rADFcv=compsings(rADFcv)
#Results
  printRES(rADFcv)
  cat('Sample CV Matrix:')
  print(PsyHat)
  cat('Reproduced CV Mat:')
  print(SIGMAof(rADFcv$pars))
  cat('Covariance Residuals:')
  sdres_ADF = (vech(PsyHat) - vech(SIGMAof(rADFcv$pars)))/sd(vech(PsyHat))
  print(PsyHat - SIGMAof(rADFcv$pars))
  cat('Covariance Residuals as Percent Difference:')
  print((PsyHat - SIGMAof(rADFcv$pars))*100/PsyHat)

#####################
## ADF - CV Normal ##
#####################

METH = 'ADF Estimation with Normal Distribution'
#Fit Model Using ADFcvn procedure
  theta = MOD$value[sel.free]
  rADFcvn = plzcon(theta,fADFcvn)
  rADFcvn$METH = METH
#SEs of ADF Estimates
  DeltaADFcvn = getDelta(rADFcvn,SHPNinv)
  rADFcvn$SEs = sqrt(diag(DeltaADFcvn)/N)
  rADFcvn=compsings(rADFcvn)
#Results
  printRES(rADFcvn)
  cat('Sample CV Matrix:')
  print(PsyHat)
  cat('Reproduced CV Mat:')
  print(SIGMAof(rADFcvn$pars))
  cat('Covariance Residuals:')
  sdres_ADFN = (vech(PsyHat) - vech(SIGMAof(rADFcvn$pars)))/sd(vech(PsyHat))
  print(PsyHat - SIGMAof(rADFcvn$pars))
  cat('Covariance Residuals as Percent Difference:')
  print((PsyHat - SIGMAof(rADFcvn$pars))*100/PsyHat)

##############
## GLS - CV ##
##############

METH = 'GLS Estimation'
#Fit Model Using GLS procedure
  theta = MOD$value[sel.free]
  rGLScv = plzcon(theta,fGLScv)
  rGLScv$METH = METH
#SEs of GLS Estimates
  DeltaGLScv = getDelta(rGLScv,solve(PsyHat))
  rGLScv$SEs = sqrt(diag(DeltaGLScv)/N)
  rGLScv=compsings(rGLScv)
#Results
  printRES(rGLScv)
  cat('Sample CV Mat:')
  print(PsyHat)
  cat('Reproduced CV Mat:')
  print(SIGMAof(rGLScv$pars))
  cat('Covariance Residuals:')
  sdres_GLS = (vech(PsyHat) - vech(SIGMAof(rGLScv$pars)))/sd(vech(PsyHat))
  print(PsyHat - SIGMAof(rGLScv$pars))
  cat('Covariance Residuals as Percent Difference:')
  print((PsyHat - SIGMAof(rGLScv$pars))*100/PsyHat)

#############
## ML - CV ##
#############

METH = 'Maximum Likelihood Estimation'
#Fit Model Using ML procedure
  theta = MOD$value[sel.free]
  rMLcv = plzcon(theta,fMLcv)
  rMLcv$METH = METH
#SEs of ML Estimates
  DeltaMLcv = getDelta(rMLcv,solve(SIGMAof(rMLcv$pars)))
  rMLcv$SEs = sqrt(diag(DeltaMLcv)/N)
  rMLcv=compsings(rMLcv)
#Result
  printRES(rMLcv)
  cat('Sample CV Mat:')
  print(PsyHat)
  cat('Reproduced CV Mat:')
  print(SIGMAof(rMLcv$pars))
  cat('Covariance Residuals:')
  sdres_ML = (vech(PsyHat) - vech(SIGMAof(rMLcv$pars)))/sd(vech(PsyHat))
  print(PsyHat - SIGMAof(rMLcv$pars))
  cat('Covariance Residuals as Percent Difference:')
  print((PsyHat - SIGMAof(rMLcv$pars))*100/PsyHat)

#Plot Histograms of Standardized Residuals
par(mfrow = c(2,2),
    mar=c(3, 4, 1.5, 1.5)+0.1,
    cex=0.9)
xtitle = "Standardized Residual"
hist(sdres_ADF,
     ylab=NULL,xlab=NULL,main=NULL,
     ylim=c(0,8),xlim=c(-0.5,0.5),
     col="gray")
mtext("AGLS",3,line=-1.5,cex=0.9)
mtext(xtitle,1,line=2,cex=0.9)
mtext("Frequency",2,line=2,cex=0.9)

hist(sdres_ADFN,
     ylab=NULL,xlab=NULL,main=NULL,
     ylim=c(0,8),xlim=c(-0.5,0.5),
     col="gray")
mtext("NGLS",3,line=-1.5,cex=0.9)
mtext(xtitle,1,line=2,cex=0.9)
mtext("Frequency",2,line=2,cex=0.9)

hist(sdres_GLS,
     ylab=NULL,xlab=NULL,main=NULL,
     ylim=c(0,8),xlim=c(-0.5,0.5),
     col="gray")
mtext("MGLS",3,line=-1.5,cex=0.9)
mtext(xtitle,1,line=2,cex=0.9)
mtext("Frequency",2,line=2,cex=0.9)

hist(sdres_ML,
     ylab=NULL,xlab=NULL,main=NULL,
     ylim=c(0,8),xlim=c(-0.5,0.5),
     col="gray")
mtext("MRLS",3,line=-1.5,cex=0.9)
mtext(xtitle,1,line=2,cex=0.9)
mtext("Frequency",2,line=2,cex=0.9)

Parameter_Table = rbind(rADFcv$pars, rADFcv$SEs,
                  rADFcvn$pars,rADFcvn$SEs,
                  rGLScv$pars, rGLScv$SEs,
                  rMLcv$pars,  rMLcv$SEs)
row.names(Parameter_Table) <- c('ADF Param Est',
                                'ADF SEs',
                                'Normal ADF Param Est',
                                'Normal ADF SEs',
                                'GLS Param Est',
                                'GLS SEs',
                                'ML Param Est',
                                'ML SEs')
View(Parameter_Table)

CV_Matrix_Table = t(cbind(vech(PsyHat),
                  vech(SIGMAof(rADFcv$pars)),
                  vech(SIGMAof(rADFcvn$pars)),
                  vech(SIGMAof(rGLScv$pars)),
                  vech(SIGMAof(rMLcv$pars))))
row.names(CV_Matrix_Table) = c(
                        'Sample CV Matrix',
                        'ADF Modeled CV Matrix',
                        'Normal ADF Modeled CV Matrix',
                        'GLS Modeled CV Matrix',
                        'ML Modeled CV Matrix')
View(CV_Matrix_Table)


#!/usr/bin/r

suppressMessages(library(Rcpp))
suppressMessages(library(inline))

foo <- '
    IntegerVector vec(10000);     // vec parameter viewed as vector of ints.
    int i = 0;
    for (int a = 0; a < 9; a++)
      for (int b = 0; b < 9; b++)
        for (int c = 0; c < 9; c++)
          for (int d = 0; d < 9; d++)
            vec(i++) = a*b - c*d;

    return vec;
'

funx <- cxxfunction(signature(), foo, plugin = "Rcpp" )

dd.inline.rcpp <- function() {
    res <- funx()
    tabulate(res)
}

print(mean(replicate(100,system.time(dd.inline.rcpp())["elapsed"]),trim=0.05))


# Loading data
library(dslabs)
data(murders)

# Loading dplyr
library(dplyr)

# Redefine murders so that it includes a column named rate with the per 100,000 murder rates
murders <- mutate(murders, rate = total / population *100000 )


# Plots Fig 1 - AOTs calculated by all methods for a range of visibilities

vis = seq(1, 50, 0.1)
k <- vis2aot_k(vis)
plot(vis, k, type='l', xlab="Horizontal visibility (km)", ylab="AOT", lty=1, col='red')
v6s <- vis2aot_sixs(vis)
lines(vis, v6s, lty=2, col='blue')
vv <- vis2aot_modtran(vis)
lines(vis, vv, lty=5, col='black')
legend('topright', c("Koschmieder", "6S", "MODTRAN"), lty=c(1, 2, 5), col=c('red', 'blue', 'black'))


#' all the below code is cannibalized from aRbor

#' this code attempts to detect whether data is discrete or continuous for use in calculating phylogenetic signal
#' it uses a rather heuristic method to determine if something is discrete, so be careful!

detectCharacterType<-function(dat) {
	if(is.factor(dat)) {
			charType<-"discrete"
	} else if(nlevels(as.factor(dat))/length(dat) < 0.1) {
			warning("Guessing that this is a discrete character based on repeated values")
			charType<-"discrete"
	} else {
			charType<-"continuous"
	}
	return(charType)
}	# needless to say, this is not yet robust

#' Function for calculating phylogenetic signal of discrete and continuous traits
#'
#' This function allows testing either Blomberg (for continuous), Pagel lambda (for both), or "garbage test" (for discrete)

physigArbor<-function(phy, dat, charType="fromData", signalTest="pagelLambda", discreteModelType="ER") {
	ctype = match.arg(charType, c("fromData", "discrete", "continuous"))

	if(ctype=="fromData") # then try to figure it out
		ctype<-detectCharacterType(dat)

	signalTest = match.arg(signalTest, c("pagelLambda", "Blomberg", "garbageTest"))
	discreteModelType = match.arg(discreteModelType, c("ER", "SYM", "ARD"))

	if(ctype=="discrete") {
		# this changes the discrete data to 1:n and remembers the original charStates
		dat<-as.factor(dat)
		charStates<-levels(dat)
		k<-nlevels(dat)

		ndat<-as.numeric(dat)
		names(ndat)<-names(dat)

		if(signalTest=="pagelLambda") {
			res<-discreteLambdaTest(phy, ndat, k, discreteModelType)
		} else if(signalTest=="garbageTest") {
			res<-discreteGarbageTest(phy, ndat, k, discreteModelType)
		} else if(signalTest=="Blomberg") {
			stop("Blomberg K should not be used for discrete characters")
		}
	}

	if(ctype=="continuous") {
		if(signalTest=="pagelLambda") {
			res<-continuousLambdaTest(phy, dat)
		} else if(signalTest=="garbageTest") {
			res<-continuousGarbageTest(phy, dat)
		} else if(signalTest=="Blomberg") {
			res<-continuousBlombergTest(phy, dat)
		}
	}

	return(res)

}

discreteLambdaTest<-function(phy, ndat, k, discreteModelType) {
	m1<-fitDiscrete(phy, ndat, model=discreteModelType)
	m2<-fitDiscrete(phy, ndat, model=discreteModelType, transform="lambda")

	chisqTestStat <- 2 * (m2$opt$lnL-m1$opt$lnL)
	chisqPVal <- pchisq(chisqTestStat, 1, lower.tail=F)

	aicScores<-c(m1$opt$aicc, m2$opt$aicc)
	names(aicScores)<-c("Mk", "Mk+lambda")

	res<-list(chisqTestStat= chisqTestStat, chisqPVal= chisqPVal, aicScores= aicScores)
	return(res)
}

discreteGarbageTest<-function(phy, ndat, k, discreteModelType) {
	m1<-fitDiscrete(phy, ndat, model=discreteModelType)
	m2<-fitDiscreteGarbageModel(phy, ndat)

	aiccScores<-c(m1$opt$aicc, m2$aicc)
	names(aiccScores)<-c("Mk", "Garbage")

	res<-list(aiccScores= aiccScores)
	return(res)
}

fitDiscreteGarbageModel<-function(phy, ndat) {
	tt <- table(ndat)
	prob <- tt/sum(tt)
	lnL <- sum(tt * log(prob))
	k <- length(tt)-1
	n <- length(ndat)
	aic <- -2 * lnL + 2 * k
	aicc <- aic + 2 * k * (k+1) / (n - k - 1)
	res<-list(prob=prob, lnL=lnL, k=k, aic=aic, aicc=aicc)
	return(res)
}

continuousLambdaTest<-function(phy, dat) {
	m1<-fitContinuous(phy, dat, model="BM")
	m2<-fitContinuous(phy, dat, model="lambda")

	chisqTestStat <- 2 * (m2$opt$lnL-m1$opt$lnL)
	chisqPVal <- pchisq(chisqTestStat, 1, lower.tail=F)

	aicScores<-c(m1$opt$aicc, m2$opt$aicc)
	names(aicScores)<-c("BM", "BM+lambda")

	res<-list(chisqTestStat= chisqTestStat, chisqPVal= chisqPVal, aicScores= aicScores)
	return(res)
}

continuousGarbageTest<-function(phy, dat) {
	m1<-fitContinuous(phy, dat)
	m2<-fitContinuous(phy, dat, model="white")

	aiccScores<-c(m1$opt$aicc, m2$opt$aicc)
	names(aiccScores)<-c("Mk", "WhiteNoise")

	res<-list(aiccScores= aiccScores)
	return(res)
}

continuousBlombergTest<-function(phy, dat) {
	res<-phylosignal(dat, phy)
	return(res)
}


library(dplyr)
source('R/plot_thread_cluster.r')

# Some plots and setting up the matrix to make predictions
#############################################################
# Plot individual relation between participation by cluster vs length
plot.whiskers_cluster_length(df.posts, df.users, df.threads)

# Plot cluster census by thread
plot.by_thread_cluster(df.posts, df.users)

# Create a dataset where features are the % of users within every role in the first posts
# of a thread, and output is the length of a thread
df.thread_cluster <- by_thread_cluster_nfirst(df.posts, nfirst=10) %>%
                     merge(df.users, by=c('user')) %>%
                     acast(thread~cluster) %>%
                     apply(1, function(x) x/sum(x)) %>%
                     t %>%
                     as.data.frame %>%
                     merge(df.threads, by.x="row.names", by.y="thread") %>% # add length
                     arrange(length) %>% # sort by length
                     select(-Row.names) #drop thread names

# Plot it with length column normalized to stay in the same color range than the rest
df.thread_cluster %>%
  mutate(length=length/max(length)) %>%
  as.matrix %>%
  heatmap(Colv=NA, Rowv=NA, labRow=NA, ylab="Threads", xlab="Roles",
          main = "Participations by role (10 first posts)")

dev.copy(png, paste0('2016-01-15-thread_role_composition_nfirst.png'), width=600)
dev.off()

##########################################
# Length prediction
###########################################
source('R/pred_regression.r')
# pred_regression(df.thread_cluster)

# Binary lengths
df.thread_cluster <- mutate(df.thread_cluster, length =factor(length > quantile(length,0.5)))

# SVM
######################
library('e1071')
if(FALSE){
  # Feature selection
  features <- 1:(ncol(df.thread_cluster)-1)
  idx <- sample(length(y))
  cut <- floor(length(idx)*0.7)
  idx.train <- idx[1:cut]
  idx.test <- idx[cut:length(idx)]
  y.train <- df.thread_cluster$length[idx.train]
  y.test <- df.thread_cluster$length[idx.test]
  X.train <- as.matrix(df.thread_cluster[idx.train,features])
  X.test <- as.matrix(df.thread_cluster[idx.test,features])

  bag <- vector()
  accuracy <- 0
  remaining.features <- features
  while(length(remaining.features)>0){
    cat("\n\n :::::::round:::::::")
    cat("\n", remaining.features)
    best.candidate.accuracy <- 0
    best.candidate <- remaining.features[i]
    for(i in 1:length(remaining.features)){
      cat('\n candidate', remaining.features[i])
      candidate <- remaining.features[i]
      current <- c(bag, candidate)
      preds <- predict(svm(X.train[,current], y.train))
      candidate.accuracy <- sum(y.train==preds)/length(y.train)
      cat("- acc:", candidate.accuracy)
      if (candidate.accuracy > best.candidate.accuracy){
        best.candidate.accuracy <- candidate.accuracy
        best.candidate <- candidate
        cat('**')
      }
    }
    bag <- c(bag, best.candidate)
    accuracy <- c(accuracy, best.candidate.accuracy)
    remaining.features <- remaining.features[remaining.features!=best.candidate]
    cat('\n selected features:', bag)
    cat('\n accuracy:', best.candidate.accuracy)
  }
  accuracy <- accuracy[-1]
  best <- which.max(accuracy)
  features <- bag[1:best]
  cat("Final selected features:", features)
  cat('Final accuracy:', max(accuracy))
  plot(accuracy, type='b', xaxt = "n")
  title("Forward feature selection")
  axis(1, at=1:length(features), labels=bag)

}

#######################
# Bootstrap for testing
#######################
accuracies <- vector()
features <- 1:(ncol(df.thread_cluster)-1)
for(i in 1:1000){
  # re-sample train/test
  idx <- sample(nrow(df.thread_cluster))
  cut <- floor(length(idx)*0.7)
  idx.train <- idx[1:cut]
  idx.test <- idx[cut:length(idx)]
  y.train <- df.thread_cluster$length[idx.train]
  y.test <- df.thread_cluster$length[idx.test]
  X.train <- as.matrix(df.thread_cluster[idx.train,features])
  X.test <- as.matrix(df.thread_cluster[idx.test,features])

  # Train model
  model <- svm(X.train, y.train, kernel='radial')

  # Accuracy in training
  preds <- predict(model)
  table(preds, y.train)
  cat("\nAccuracy:", sum(y.train==preds)/length(y.train))

  # Accuracy in test
  preds <- predict(model, X.test)
  table(preds, y.test)
  accuracies[i] <- sum(y.test==preds)/length(y.test)
  cat("\nAccuracy:", accuracies[i])
}
cat("Accuracy:", mean(accuracies), "sd:", sd(accuracies))


################################################################################
###   R code to perform Fisher exact test, log-linear model+ likelihood ratio test, Wilcoxon rank sum test to detect differential alternative splicing
################################################################################

################################################################################
###
### Fisher exact test (when only one replicate is available for each condition)
###

###
### One Tab delimited data file (DATA_FILE_COUNT) is required, containing raw counts of reads compatible with each of the two forms of local events
###
### Data file format
### Row - 1st row:header, from 2nd row: raw read count values (the two forms of each local event should be in consecutive rows)
### Column - 1st column:ID of each form of local event, 2nd and 3rd column: the two samples

### Specify data file paths
file_count <- DATA_FILE_COUNT
file_output <- OUTPUT_FILE_NAME

### Read data files
data_val <- read.delim(file_count,sep="\t",header=T,row.names=1,as.is=T)
data_val <- as.matrix(data_val)

### Conduct test

fisher.p <- bonp <- bhp <- matrix(0,nrow(data_val)/2,1)

for(j in seq(2,nrow(data_val),2)){

	print(j/2)

	fisher_mat <- matrix(c(round(as.numeric(unlist(data_val[j-1,1]))),round(as.numeric(unlist(data_val[j-1,2]))),round(as.numeric(unlist(data_val[j,1]))),round(as.numeric(unlist(data_val[j,2])))),nrow=2)
	fisher.p[j/2]<-fisher.test(fisher_mat,alternative="two.sided")$p.value
}

### Write output
output_mat <- cbind(rownames(data_val[seq(2,nrow(data_val),2),]),fisher.p,p.adjust(fisher.p,method="bonferroni"),p.adjust(fisher.p,method="BH"))
colnames(output_mat) <- c("ID","rawP","bonP","bhP")
write.table(output_mat, file_output,quote=F,row.names=F,sep="\t")

################################################################################
###
### Log linear model + likelihood ratio test (when two or more replicates are available for each condition)
###
library(multtest)
library(epicalc)
library(lmtest)
library(xtable)
library(MASS)

###
### Two Tab delimited data files are required, one with raw counts of reads compatible with each of the two forms of local events (DATA_FILE_COUNT_ONE), the other with raw counts of all reads mapped to the local events (DATA_FILE_COUNT_ALL)
### The two files should have the same dimensions, as well as same row and column names
###
### Data file format
### Row - 1st row:header, from 2nd row: raw read count values
### Column - 1st column:ID of each form of local event,from 2nd column: samples (all replicates from condition1 should come together first, followed by all replicates from condition2)

### Specify data file paths and number of replicates in each condition
file_count <- DATA_FILE_COUNT_ONE
file_count_norm <- DATA_FILE_COUNT_ALL
condition1_num <- CONDITION1_REPLICATES_NUMBER
condition2_num <- CONDITION2_REPLICATES_NUMBER
file_output <- OUTPUT_FILE_NAME

### Read data files
mat <- read.delim(file_count,sep="\t",header=T,row.names=1,as.is=T)
offset_val <- read.delim(file_count_norm,sep="\t",header=T,row.names=1,as.is=T)
mat<-as.matrix(mat)
offset_val<-as.matrix(offset_val)

### Load test function

lrt_test <- function(mat,offset_val,condition1_num,condition2_num){

    tissue <- c(rep(1,condition1_num),rep(2,condition2_num))
    rep <- c(seq(1:condition1_num),seq(1:condition2_num))

    pval <- stat <-  matrix(0,nrow(mat),1)

	for(d in 1:nrow(mat)){

		if(is.na(mat[d,1])==F){
			cat(d,"\n")

			m2 <- glm(formula = (as.numeric(unlist(mat[d, ]))) ~ tissue + rep, family="poisson",offset=offset_val[d,])
			m1 <- glm(formula = (as.numeric(unlist(mat[d, ]))) ~ rep, family="poisson",offset=offset_val[d,])

			if(is.na(lrtest(m1,m2)[2,5])==F){
				stat[d]<-lrtest(m1,m2)[2,4]
				pval[d] <- lrtest(m1,m2)[2,5]
			}

			if(is.na(lrtest(m1,m2)[2,5])==T){
				pval[d] <- 1
			}

		}
		if(is.na(mat[d,1])==T){
			stat[d] <- NA
			pval[d] <- NA
		}
	}

	return(cbind(stat,pval))
}

### Conduct test and write output
output_lrt <- lrt_test(round(mat)+1,log(round(offset_val)+1),condition1_num,condition2_num)
output_mat <- cbind(rownames(mat),output_lrt,p.adjust(output_lrt[,2],method="bonferroni"),p.adjust(output_lrt[,2],method="BH"))
colnames(output_mat) <- c("ID","LRT_statistics","rawP","bonP","bhP")
write.table(output_mat,file_output,quote=F,row.names=F,sep="\t")

################################################################################
###
### Wilcoxon rank sum test (when many replicates are available for each condition)
###

###
### One Tab delimited data file (DATA_FILE_REL) is required, containing estimated relative expression levels of each of the two forms of local events
###
### Data file format
### Row - 1st row:header, from 2nd row: estimated relative expression values
### Column - 1st column:ID of each form of local event,from 2nd column: samples (all replicates from condition1 should come together first, followed by all replicates from condition2)

### Specify data file paths and number of replicates in each condition
file_rel <- DATA_FILE_REL
condition1_num <- CONDITION1_REPLICATES_NUMBER
condition2_num <- CONDITION2_REPLICATES_NUMBER
file_output <- OUTPUT_FILE_NAME

### Read data files
mat <- read.delim(file_rel,sep="\t",header=T,row.names=1,as.is=T)
mat<-as.matrix(mat)

### Load Wilcoxon rank sum test function
my.wilcox.test.p.value <- function(...) {
    obj<-try(wilcox.test(...), silent=TRUE)
    if (is(obj, "try-error")) return(NA) else return(obj$p.value)
}

### Conduct test and write output
test<-matrix(nrow=nrow(mat),ncol=2)
for (i in 1:nrow(test)) {
	test[i,1]<-mean(mat[i,1:condition1_num])-mean(mat[i,condition1_num+(1:condition2_num)])
	test[i,2]<-my.wilcox.test.p.value(mat[i,1:condition1_num],mat[i,condition1_num+(1:condition2_num)])
}
test<-cbind(rownames(mat),test,p.adjust(test[,2],method="bonferroni"),p.adjust(test[,2],method="BH"))
colnames(test)<-c("ID","Diff","rawP","bonP","bhP")
write.table(test,file_output,quote=F,sep="\t",row.names=F)


#library(ggplot2)
#library(ggridges)
#library(plyr)
#library(reshape2)
##install.packages("countreg", repos="http://R-Forge.R-project.org")
#library(countreg)
#
##rtpois <- function(n, lambda) {
##  # simulate from zero-truncated poisson
##  x <- qpois(runif(n, dpois(0, lambda), 1), lambda)
##  x
##}
#
#rhurdle <- function(n, theta, lambda) {
#  # theta: probability of generating a 0
#  # lambda: poisson expectation
#
#  out <- array(dim = n)
#
#  # first theta
#  is.zero <- rbinom(n, 1, theta)
#
#  # then lambda
#  not.zero <- !is.zero
#  nz <- rztpois(sum(not.zero), lambda)
#
#  # put it together
#  out[is.zero == 1] <- 0
#  out[not.zero] <- nz
#
#  out
#}
#roverhurdle <- function(n, theta, mu, omega) {
#  # theta: probability of generating a 0
#  # lambda: poisson expectation
#
#  out <- array(dim = n)
#
#  # first theta
#  is.zero <- rbinom(n, 1, theta)
#
#  # then lambda
#  not.zero <- !is.zero
#  nz <- rztnbinom(sum(not.zero), mu = mu, theta = omega)
#
#  # put it together
#  out[is.zero == 1] <- 0
#  out[not.zero] <- nz
#
#  out
#}
#
#
## predict rhurdle
#predict.hurdle <- function(theta, lambda) {
#  ppc.p <- list()
#  for(jj in seq(nsim)) {
#    gg <- grab[jj]
#    oo <- c()
#    for(ii in seq(standata$N_train)) {
#      oo[ii] <- rhurdle(1,
#                        theta = post$theta[gg, ii],
#                        lambda = post$lambda_est[gg, ii])
#    }
#    ppc.p[[jj]] <- oo
#  }
#}
#
#
#
#
### hurdle with poisson
##
##n <- 1000
##theta <- c(0.1, 0.25, 0.5, 0.75, 0.9)
##lambda <- c(1, 2, 5, 7, 10)
##
##out <- list()
##for(ii in seq(length(lambda))) {
##  out[[ii]] <- alply(theta, 1, function(x) rhurdle(n, x, lambda[ii]))
##  names(out[[ii]]) <- as.character(theta)
##}
##names(out) <- as.character(lambda)
##out <- melt(out)[, -1]
##names(out) <- c('count', 'theta', 'lambda')
##out$theta <- factor(out$theta, levels = theta)
##out$lambda <- factor(out$lambda, levels = lambda)
##
##sim <- ggplot(out, aes(x = count, y = ..density..))
##sim <- sim + geom_histogram()
##sim <- sim + facet_grid(theta ~ lambda)
##sim <- sim + labs(y = 'Density of simultaed counts', x = 'Count')
##sim <- sim + theme_bw()
##sim <- sim + theme(strip.text = element_text(size = 25),
##                   axis.title = element_text(size = 30),
##                   axis.text = element_text(size = 20))
##ggsave(filename = '../doc/figure/hurdle_simulation.png',
##       plot = sim, height = 8, width = 10)
##
##
##
### hurdle with neg binom
##size <- c(1, 2, 5, 7, 10)
##prob <- theta
##
##out <- list()
##for(ii in seq(length(lambda))) {
##  out[[ii]] <- alply(prob, 1, function(x)
##                     roverhurdle(n, theta = 0.5, size[ii], x))
##  names(out[[ii]]) <- as.character(prob)
##}
##names(out) <- as.character(lambda)
##out <- melt(out)[, -1]
##names(out) <- c('count', 'prob', 'size')
##out$prob <- factor(out$prob, levels = prob)
##out$size <- factor(out$size, levels = size)
##
##sim2 <- ggplot(out, aes(x = count, y = ..density..))
##sim2 <- sim2 + geom_histogram()
##sim2 <- sim2 + facet_grid(prob ~ size)
##sim2 <- sim2 + labs(y = 'Density of simultaed counts', x = 'Count')
##sim2 <- sim2 + theme_bw()
##sim2 <- sim2 + theme(strip.text = element_text(size = 25),
##                     axis.title = element_text(size = 30),
##                     axis.text = element_text(size = 20))
##ggsave(filename = '../doc/figure/overhurdle_simulation.png',
##       plot = sim2, height = 8, width = 10)
##


options(scipen=999)

data <- c()
line <- readline()
while (line != "") {
  data[length(data) + 1] <- as.numeric(line)
  line <- readline()
}

for (i in 26:length(data)) {
  found <- FALSE
  for (s1 in (i-25):(i-1)) {
    for (s2 in (i-25):(i-1)) {
      if (!found && s1 != s2 && data[s1] + data[s2] == data[i]) {
        found <- TRUE
      }
    }
  }
  if (!found) {
    print(data[i])
  }
}


#Library

library(fastcluster)
library(rgdal)
library(FactoMineR)

coast <- readOGR("OH_2020/Data/EEA_Coastline_WGS84.gpkg")
coast <- raster::crop(coast, raster::extent(-8.2,-2.5,51.5,55.9))

classif <- function(raster, method.dist="euclidean", method.classif="ward.D2", nb.clust){
  df <- raster::as.data.frame(raster, xy=T)
  x <- is.na(maps::map.where(coast, df$x, df$y))
  df <- df[which(x),-c(1,2)]
  d <- dist(df,method=method.dist)
  clust <-fastcluster::hclust(d, method = method.classif)

  zones <- cutree(clust ,nb.clust)
  raster.cut <- raster[[1]]
  values(raster.cut) <- NA
  raster.cut[which(x)] <- zones
  return(raster.cut)
}

#CLASSIFICATION of the MODIST SST
#================================================================
sst.classif <- classif(mpa_sst,nb.clust = 5)

#CLASSIFICATION of the PRIMARY PRODUCTION
#================================================================
ppr.classif <- classif(mpa_ppr,nb.clust = 5)

#CLASSIFICATION of the SALINITY
#================================================================
salinity.classif <- classif(mpa_salinity,nb.clust = 5)

#CLASSIFICATION of the CHLA
#================================================================
chla.classif <- classif(mpa_chla,nb.clust = 5)

#CLASSIFICATION of the KD443
#================================================================
kd443.classif <- classif(mpa_kd443,nb.clust = 5)

#CLASSIFICATION of the Surface oxygene
#================================================================
oxygene.classif <- classif(mpa_oxygene,nb.clust = 5)

#CLASSIFICATION of the Surface bbp
#================================================================
bbp.classif <- classif(mpa_bbp,nb.clust = 5)

#CLASSIFICATION of the Surface adg
#================================================================
adg.classif <- classif(mpa_adg,nb.clust = 5)

#FINAL CLASSIFICATION#####
grid <- expand.grid(Long=seq(from=-8.1,to=-2.5,by=round(res(mpa_adg)[1],4)),Lat=seq(from=51.5,to=55.9,by=round(res(mpa_adg)[1],4)))

env.zones <- data.frame(grid,
                        SST=extract(sst.classif,grid),
                        PPR=extract(ppr.classif,grid),
                        SAL=extract(salinity.classif,grid),
                        CHL=extract(chla.classif,grid),
                        KD=extract(kd443.classif,grid),
                        OXY=extract(oxygene.classif,grid),
                        BBP=extract(bbp.classif,grid),
                        ADG=extract(adg.classif,grid))
env.zones <- na.omit(env.zones)

for(i in 3:10){
  env.zones[,i] <- paste(env.zones[,i],names(env.zones)[i],sep="_")
}

#MCA
mca <- MCA(env.zones[,-c(1,2)], ncp=999, method="Burt", graph=F)
#plotellipses(mca, axes = c(1,2))
#plotellipses(mca, axes = c(1,3))

#Final classif
d <- dist(mca$ind$coord)
clust <- fastcluster::hclust(d, method="ward.D2")
groups <- cutree(clust,6)

env.classif <- data.frame(env.zones[,c(1,2)],Clusters=factor(groups))
######

#TIME SERIES AND BOXPLOT DATA####
param <- c("SST","PPR","SAL","CHL","KD","OXY","BBP","ADG")
Env <- data.frame()
x <- is.na(maps::map.where(coast, grid$Long, grid$Lat))
marine.grid <- grid[which(x),]
t <- 0

for (i in list(mpa_sst,mpa_ppr,mpa_salinity,mpa_chla,mpa_kd443,mpa_oxygene,mpa_bbp,mpa_adg)){
  t <- t+1
  tmp <- data.frame(marine.grid,extract(i,marine.grid))
  tmp <- dplyr::left_join(env.classif,tmp,by=c("Long"="Long","Lat"="Lat"))
  tmp <- tidyr::pivot_longer(data=tmp, cols=4:dim(tmp)[2],names_to="Date", values_to="Values")
  tmp <- dplyr::mutate(tmp, Month=substr(Date,7,8),Year=substr(Date,2,5))
  tmp <- dplyr::select(tmp, -Date)
  tmp <- dplyr::mutate(tmp, Param=param[t])

  Env <- rbind(Env, tmp)
}
#####

#RETURN PLOTS#####

map <- ggplot()+
  geom_raster(data=env.classif,aes(x=Long,y=Lat,fill=Clusters))+
  geom_polygon(data=coast, aes(x=long, y=lat, group=group), fill="grey", col="black")+
  theme_minimal()+ggtitle("Final regionalization of the area with environmental parameters")+
  xlab("Longitude")+ylab("Latitude")+scale_fill_viridis_d()
print(map)

boxplots <- ggplot()+
  geom_boxplot(data=Env,aes(x=Clusters,y=Values,fill=Clusters))+
  facet_wrap(~Param,nrow=2, scale="free_y")+xlab("Clusters")+ylab("Parameters")+
  scale_fill_viridis_d()
print(boxplots)

Env$Date <- as.Date(paste(Env$Year,Env$Month,"01",sep="/"), format=c("%Y/%m/%d"))
ts <- ggplot(data=Env[Env$Param=="SST",])+
  geom_path(aes(x=Date,y=Values,col=Clusters))+
  scale_color_viridis_d()+facet_wrap(~Param, nrow = 8, scale="free_y")
print(ts)
#####


# 4. faza: Analiza podatkov

############################################################################################
#CCA aktivni Slovenija + napoved s pomocjo linearne regresije
akt <- data.frame("Aktivne_okuzbe"=c(Aktivne_okuzbe,CCA_aktivne_okuzbe) ,
                  "Realno stanje ali stanje pri konstantem testiranju"=
                    c(rep("realno testiranje",length(Aktivne_okuzbe)),
                      rep("konstanto testiranje",length(CCA_aktivne_okuzbe))),
                  "datum"=c(podatki$datum,podatki$datum))
aktivne_okuzbe_realnevsCCA <- ggplot(akt, aes(x=datum, y = Aktivne_okuzbe,col=Realno.stanje.ali.stanje.pri.konstantem.testiranju))+
  geom_line()+
  ylab("Aktivne okužbe")+
ggtitle("Groba ocena števila aktivnih okužb v Sloveniji")

#CCA AKTIVNI SVET + napoved s pomocjo linearne regresije
okuzeni_svet <- podatki_svet %>% group_by(date) %>% summarise(vsi_okuzeni = sum(total_cases),na.rm = TRUE)
CCA_okuzeni_svet <- podatki_svet %>% group_by(date) %>% summarise(vsi_okuzeni = sum(total_cases,na.rm = TRUE))
CCA_okuzeni_svet[15:219,2]<- CCA_okuzeni_svet[15:219,2] - CCA_okuzeni_svet[1:205,2]

#+ stat_smooth(method = "lm", col = "red")
df <- merge(okuzeni_svet,CCA_okuzeni_svet,by=c("date"))
df <- data.frame("okuzeni"=c(df$vsi_okuzeni.x, df$vsi_okuzeni.y),
                "date"=c(df$date,df$date),
                "tip"=c(rep("vsi",length(df$date)),rep("aktivni",length(df$date))))

Vsi_okuzeni_proti_aktivni <- ggplot(df,aes(x=date, y=okuzeni/10^3,col=tip))+
  geom_line()

#############################################################################################
death_rate_life_expectancy <-podatki_svet %>%
  mutate(death_rate = total_deaths_per_million/total_cases_per_million) %>%
  select(location,continent,death_rate,life_expectancy,extreme_poverty) %>%
  group_by(location,continent) %>%
  summarise(najvisji_death_rate = max(death_rate),life_expectancy = max(life_expectancy), revscina = max(extreme_poverty))

Death_rate_life_expectancy <- ggplot(death_rate_life_expectancy,aes(x=life_expectancy,y=najvisji_death_rate,col=continent))+
  geom_point()+
  ylab("Death rate")+
  ggtitle("Death rate glede na pricakovano zivljensko dobo")

Death_rate_poverty <- ggplot(death_rate_life_expectancy,aes(x=revscina,y=najvisji_death_rate,col=continent))+
  geom_point()+
  ylab("Death rate")+
  ggtitle("Death rate glede na revscino")

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

dnevi.v.tednu <- as.Date(0:6, origin="1900-01-01") %>% weekdays()

svetovno_testiranje_po_dnevih <-podatki_svet %>%

  mutate(dan_v_tednu=weekdays(date) %>% factor(levels=dnevi.v.tednu, ordered=TRUE)) %>%

  group_by(dan_v_tednu, continent) %>%

  summarise(stevilo_testov_po_dnevih=sum(new_tests, na.rm=TRUE)) %>%

  drop_na(continent)

svetovno_testiranje_po_dnevih <- merge(svetovno_testiranje_po_dnevih, population_by_continent, by="continent")
test_po_dnevih_svet <- ggplot(svetovno_testiranje_po_dnevih,
       aes(x=as.numeric(dan_v_tednu), y=stevilo_testov_po_dnevih, color=continent,size = population_continent)) +
  geom_line() +
  scale_x_continuous(breaks=1:7, labels=dnevi.v.tednu)+
  xlab("")+
  ylab("Skupno število testov")+
  ggtitle("Primerjava skupnega števila testov po dnevih glede na kontinent")
##########################################
#zemljevid % vseh pozitivnih testov
testi_po_drzavah = podatki_svet %>% group_by(iso_code,location) %>% summarise(vsi_testi = sum(new_tests,na.rm=TRUE))
okuzeni_po_drzavah = podatki_svet %>% group_by(iso_code,location) %>% summarise(vsi_okuzeni=max(total_cases,na.rm=TRUE))
testi_po_drzavah = testi_po_drzavah %>% filter(is.na(iso_code)==FALSE)
okuzeni_po_drzavah  = okuzeni_po_drzavah %>% filter(is.na(iso_code)==FALSE)
testi_okuzeni_po_drzavah = merge(testi_po_drzavah,okuzeni_po_drzavah,by=c("iso_code","location"))
testi_okuzeni_po_drzavah  = testi_okuzeni_po_drzavah  %>% filter(vsi_testi>0,vsi_testi>vsi_okuzeni)
testi_okuzeni_po_drzavah["odstotek_pozitivnih_testov"]<-100* testi_okuzeni_po_drzavah$vsi_okuzeni/testi_okuzeni_po_drzavah$vsi_testi
zemljevid_odstotka_pozitivnih_testov<- tm_shape(merge(World, testi_okuzeni_po_drzavah, by.x="iso_a3", by.y="iso_code")) +
  tm_polygons("odstotek_pozitivnih_testov")
##########################################
#Od vseh držav z več kot milijon prebivalci zračunej polinomski trend 3-je stopnje, poglej kdo ima na zadnji dan najbolj navpično
drzave = unique(podatki_svet$location)
trend=c()
datum = c()
for(drzava in drzave){
  podatki_za_Drzavo=((podatki_svet %>% filter(location==drzava))[,c(3,4,7)]) %>% filter(is.na(total_cases_per_million)==FALSE)
  if(nrow(podatki_za_Drzavo)>0){
  podatki_za_Drzavo$total_cases_per_million= c(podatki_za_Drzavo$total_cases_per_million[1], diff(podatki_za_Drzavo$total_cases_per_million))
  #total cases so sedaj new cases
  datum = c(datum,as.character(podatki_za_Drzavo$date[nrow(podatki_za_Drzavo)]))
  x=c(1,cumsum(as.integer(diff(podatki_za_Drzavo$date))))
  y=podatki_za_Drzavo$total_cases_per_million
  model <- lm(y ~ poly(x,3))
  zadnji_dan =max(x)
  trend = c(trend,(predict(model)[[length(predict(model))]]-predict(model)[[length(predict(model))-1]])/(x[length(x)]-x[length(x)-1]))
  }
  else{
    drzave=drzave[drzave != drzava]
  }
}
datum = as.Date(datum, format="%Y-%m-%d")
trend_drzav = data.frame("date"=datum,
                "trend"=trend,
                "location"=drzave)
zemljevid_trendov<- tm_shape(merge(World, trend_drzav, by.x="name", by.y="location",all.x=TRUE)) +
  tm_polygons("trend",midpoint = NA)
################################################################3


library(reshape2)
library(ggplot2)
library(data.table)

w241 <- read.csv(file='./results.csv',sep=',',header=T)
#w241.models <- read.csv(file='./Models.csv',sep=',',header=T)
str(w241)
w241 <- melt(w241,id.vars="Models")
names(w241)=c("Models","Treatment", "beta" )

w241 <- as.data.table(w241)
w241 <- w241[, std.error:= c(0.157, 0.157, 0.088,0.082, 0.155, 0.155, 0.088, 0.082)]
#w241 <- w241[, Model.Description:= c( "Model 1 without covariates" ,"Model 2 with covariates but no funding", "Model 3 with covariates and funding", "Model 4 with covariates and fixed effect for participants", "Model 1 - Full Model without covariates" ,"Model 2 - Full Model with covariates but no funding", "Model 3 - Full Model with covariates and funding", "Model 4 - Full Model with covariates and fixed effect for participants" )]

avg.ratings.plot <- ggplot(w241, aes(x=Models,y=beta,fill=Treatment))+ geom_bar(stat="identity",position="dodge")   + labs(x="Regression Models", y="Beta parameter", title="")
avg.ratings.plot <-avg.ratings.plot+theme(axis.text=element_text(size=12), axis.title=element_text(size=14,face="bold"))
avg.ratings.plot <-avg.ratings.plot+ geom_errorbar(aes(ymin=beta-1.96*std.error, ymax=beta+1.96*std.error),
                                                   width=.2,                    # Width of the error bars
                                                   position=position_dodge(.9))
#avg.ratings.plot <- avg.ratings.plot + ggtitle("Treatment Effects") + theme(plot.title = element_text(lineheight=3, face="bold", color="black", size=29))
avg.ratings.plot <- avg.ratings.plot + theme(axis.title.y = element_text(size = rel(1.8), angle = 90))
avg.ratings.plot <- avg.ratings.plot + theme(axis.title.x = element_text(size = rel(1.8), angle = 00))
avg.ratings.plot <- avg.ratings.plot+ theme(legend.text=element_text(size=12)) + theme(legend.title=element_text(size=15))
avg.ratings.plot

avg.ratings.plot = avg.ratings.plot +scale_fill_manual(
  "CI horizontal line", values=rep(1,4),
  guide=guide_legend(override.aes = list(colour=c("orange", "darkred")))
)

avg.ratings.plot

avg.ratings.plot = avg.ratings.plot + scale_fill_manual(
  name   = 'Margin',
  breaks = c('upper', 'lower'), # <<< corresponds to fill aesthetic labels
  values = c('#b0dd8d', '#fdba9a'),
  labels = c('Over', 'Under'))

avg.ratings.plot

avg.ratings.plot2 <- avg.ratings.plot + geom_point(data = w241.models$Description, aes(size="0", shape = NA), colour = "grey50")
avg.ratings.plot2

ggplot(tgc2, aes(x=dose, y=len, fill=supp)) +
  geom_bar(position=position_dodge(), stat="identity") +
  geom_errorbar(aes(ymin=len-se, ymax=len+se),
                width=.2,                    # Width of the error bars
                position=position_dodge(.9))

## Summarizes data.
## Gives count, mean, standard deviation, standard error of the mean, and confidence interval (default 95%).
##   data: a data frame.
##   measurevar: the name of a column that contains the variable to be summariezed
##   groupvars: a vector containing names of columns that contain grouping variables
##   na.rm: a boolean that indicates whether to ignore NA's
##   conf.interval: the percent range of the confidence interval (default is 95%)
summarySE <- function(data=NULL, measurevar, groupvars=NULL, na.rm=FALSE,
                      conf.interval=.95, .drop=TRUE) {
  library(plyr)

  # New version of length which can handle NA's: if na.rm==T, don't count them
  length2 <- function (x, na.rm=FALSE) {
    if (na.rm) sum(!is.na(x))
    else       length(x)
  }

  # This does the summary. For each group's data frame, return a vector with
  # N, mean, and sd
  datac <- ddply(data, groupvars, .drop=.drop,
                 .fun = function(xx, col) {
                   c(N    = length2(xx[[col]], na.rm=na.rm),
                     mean = mean   (xx[[col]], na.rm=na.rm),
                     sd   = sd     (xx[[col]], na.rm=na.rm)
                   )
                 },
                 measurevar
  )

  # Rename the "mean" column
  datac <- rename(datac, c("mean" = measurevar))

  datac$se <- datac$sd / sqrt(datac$N)  # Calculate standard error of the mean

  # Confidence interval multiplier for standard error
  # Calculate t-statistic for confidence interval:
  # e.g., if conf.interval is .95, use .975 (above/below), and use df=N-1
  ciMult <- qt(conf.interval/2 + .5, datac$N-1)
  datac$ci <- datac$se * ciMult

  return(datac)
}

tg <- ToothGrowth
head(tg)
# summarySE provides the standard deviation, standard error of the mean, and a (default 95%) confidence interval
tgc <- summarySE(tg, measurevar="len", groupvars=c("supp","dose"))
tgc

# Standard error of the mean
ggplot(tgc, aes(x=dose, y=len, colour=supp)) +
  geom_errorbar(aes(ymin=len-se, ymax=len+se), width=.1) +
  geom_line() +
  geom_point()

# The errorbars overlapped, so use position_dodge to move them horizontally
pd <- position_dodge(0.1) # move them .05 to the left and right

ggplot(tgc, aes(x=dose, y=len, colour=supp)) +
  geom_errorbar(aes(ymin=len-se, ymax=len+se), width=.1, position=pd) +
  geom_line(position=pd) +
  geom_point(position=pd)

# Use 95% confidence interval instead of SEM
ggplot(tgc, aes(x=dose, y=len, colour=supp)) +
  geom_errorbar(aes(ymin=len-ci, ymax=len+ci), width=.1, position=pd) +
  geom_line(position=pd) +
  geom_point(position=pd)

# Black error bars - notice the mapping of 'group=supp' -- without it, the error
# bars won't be dodged!
ggplot(tgc, aes(x=dose, y=len, colour=supp, group=supp)) +
  geom_errorbar(aes(ymin=len-ci, ymax=len+ci), colour="black", width=.1, position=pd) +
  geom_line(position=pd) +
  geom_point(position=pd, size=3)


library(data.table)
library(boot)

replicates = 1000 # TODO
#filename = 'sha1-32bit-out12bitREF.csv'
filename = 'sha1-32bit-out8bitREF.csv'

#raw_data = read.csv('sha1-16bit-nores.csv')
raw_data = read.csv(filename)
# Columns
#  - rounds     number of rounds
#  - time       time to solve

tbl = data.table(raw_data)
groupped = tbl[,list(times=list(time)), by=rounds]
groupped = groupped[order(rounds)] # Sort by number of rounds, for plotting

bca_mean <- function(data, indices) {
    filtered_data <- data[indices]
    return(mean(filtered_data))
}

times_stat <- function(times) {
    if (length(unique(times)) > 1) {
        bobj = boot(data=times, statistic=bca_mean, R=replicates)
        ci = boot.ci(bobj, type="bca", conf=0.95)
        return(list(mean=mean(times), ci_low=ci$bca[4], ci_high=ci$bca[5]))
    } else {
        return(list(mean=mean(times), ci_low=mean(times), ci_high=mean(times)))
    }
}

for(r in groupped$rounds) {
    times <- unlist(groupped[groupped$rounds==r]$times)
    #print(r)
    #print(times)
    stat = times_stat(times)
    groupped[groupped$rounds==r, "mean"] = stat$mean
    groupped[groupped$rounds==r, "ci_low"] = stat$ci_low
    groupped[groupped$rounds==r, "ci_high"] = stat$ci_high
}

plot(x = 1,
     #log = "y",
     xlim = range(groupped$rounds),
     ylim = range(groupped$ci_low, groupped$ci_high),
     xlab = "Number of rounds",
     ylab = "Time [seconds]",
     main = paste("Solving time vs. #rounds [", filename, "]", sep=""),
     type = "n",
     xaxt = "n")
axis(side = 1,
     at = groupped$rounds)
polygon(x = c(groupped$rounds, rev(groupped$rounds)),
        y = c(groupped$ci_low, rev(groupped$ci_high)),
        col = "grey",
        border = NA)
lines(groupped$rounds, groupped$ci_low, type="l", lty=2)
lines(groupped$rounds, groupped$ci_high, type="l", lty=2)
lines(groupped$rounds, groupped$mean, type="o", pch=20, bg="black")


setwd('C:/Users/Rui/Desktop/nba')
library(clValid)
library(ape)
library(colorRamps)
library(colorspace)
csvfiles<-"C:/Users/Rui/Desktop/nba/021617allcluster.csv"
MyData <- read.csv(file=csvfiles, header=TRUE, sep=",")
head(MyData,5)
players <- subset( MyData, select = -X )
row.names(players) <-MyData$'X'

players <- subset( players, select = -total )
players <- subset( players, select = -X.all )
##players <- subset( players, select = -run.D )
##players <- subset( players, select = -r.dif )
##players <- subset( players, select = -dist.D )
##players <- subset( players, select = -X.diff )
##players2<-scale(players, center = TRUE, scale = TRUE)
medians = apply(players,2,median)
mads = apply(players,2,mad)
players2 = scale(players,center=medians,scale=mads)
players3<-data.frame(players2)
players3$X.diff<-players3$X*sqrt(10)
clmethods <- c("hierarchical","kmeans","pam")
intern <- clValid(players2, nClust = 5:8,
              clMethods = clmethods, validation = "internal")
# Summary
summary(intern)
plot(intern)
stab <- clValid(players2, nClust = 5:8, clMethods = clmethods,
                validation = "stability")
optimalScores(stab)
plot(stab)

player_clusters <- dist(players2, method = "euclidean")
res.hc <- hclust(player_clusters, method = "ward.D2" )
# Cut tree into 4 groups
grp <- cutree(res.hc, k = 5)
# Visualize
##tiff("plotcluster5.tiff",width = 1800, height = 1800, res = 300)
##plot(res.hc, cex = 0.3, hang=-1) # plot tree
##rect.hclust(res.hc, k = 5, border = 2:5) # add rectangle
##dev.off()

source("plotBranchbyTrait.R") # load source
tiff("plotcluster5d9.tiff",width = 1800, height = 1800, res = 300)
plotBranchbyTrait(res.hc,players$X.,mode="edges",palette="colord")
##rect.hclust(res.hc, k = 5, border = 2:5) # add rectangle
dev.off()

players4<-data.frame(players,grp)
c1<-players4[players4$grp==1,]
c2<-players4[players4$grp==2,]
c3<-players4[players4$grp==3,]
c4<-players4[players4$grp==4,]
c5<-players4[players4$grp==5,]
c6<-players4[players4$grp==6,]
c7<-players4[players4$grp==7,]
c8<-players4[players4$grp==8,]
colMeans(c1)
colMeans(c2)
colMeans(c3)
colMeans(c4)
colMeans(c5)
colMeans(c6)
colMeans(c7)
colMeans(c8)

> colMeans(c1)
          X.        r.dif       dist.D        run.D          grp
-0.002972003  0.779608493  0.475163940  0.820582384  1.000000000
> colMeans(c2)
         X.       r.dif      dist.D       run.D         grp
-0.02943269  1.93048969 -0.35912726  0.11342435  2.00000000
> colMeans(c3)
         X.       r.dif      dist.D       run.D         grp
-0.11646847  0.01004611 -0.25688115  0.99473698  3.00000000
> colMeans(c4)
         X.       r.dif      dist.D       run.D         grp
 0.07063814 -1.00812463 -1.20201093  0.11980896  4.00000000
> colMeans(c5)
        X.      r.dif     dist.D      run.D        grp
0.06591457 0.89286663 2.26391636 0.21181662 5.00000000


context("Trans")

test_that("Transformed ranges silently drop out-of-domain values", {
  r1 <- trans_range(log_trans(), -1:10)
  expect_that(r1, equals(log(c(1e-100, 10))))

  r2 <- trans_range(sqrt_trans(), -1:10)
  expect_that(r2, equals(sqrt(c(0, 10))))
})


#### This script outputs the PLS components of the simulation file in addition to the RMSEP plots which we can refer to when deciding the number of components to retain.
## Example (in terminal): Rscript find_pls.r 2pop_simpleModel_4params_simulatedSumStats.txt
## Lines which may need to be modified are line 20 (# of PLS components), line 22 (working directory), line 32 (positional (column) indicator of first summary statistics entry) and line 36 (positional (column) indicator of free parameters)

# First, we install libraries if needed and load them
need.pkg <- c("MASS", "pls")
inst.pkg <- which(!need.pkg %in% installed.packages())
if (length(inst.pkg) > 0) {cat("\nyou lack some R packages, installing...\n") ; install.packages(need.pkg[inst.pkg], repos="http://cran.rstudio.com/")}
cat("\nloaded packages and versions:\n")
for (i in need.pkg) {
  suppressWarnings(suppressPackageStartupMessages(do.call(library, list(i))))
  cat(i)
  cat(paste0(" v", packageVersion(i)))
  cat("\n")
  rm(i)
}
cat("\n")

#open File
numComp<-5;

directory<-"/path/";

filename<-commandArgs()[length(commandArgs())];
#filename<-"2pop_simpleModel_4params_simulatedSumStats.txt"
print(paste("Reading file '", filename, "'", sep=""));

#read input (summary statistics) file
a<-read.table(paste(directory, filename, sep=""), header=T);

# Define the starting column for the summary statistics
firstStat<-13;
stats<-a[,firstStat:length(a[1,])];

# Define the columns holding the free parameters
p<-c(2,3,4,5);
if(length(p)==1){
  params <- data.frame(x=a[,p]); names(params)<-names(a)[p];
} else {
  params<-a[,p];
}
print(names(params));

#standardize the params
for(i in 1:length(params)){params[,i]<-(params[,i]-mean(params[,i]))/sd(params[,i]);}

#force stats in [1,2]
myMax<-c(); myMin<-c(); lambda<-c(); myGM<-c();
for(i in 1:length(stats)){
  myMax<-c(myMax, max(stats[,i]));
  myMin<-c(myMin, min(stats[,i]));
  stats[,i]<-1+(stats[,i]-myMin[i])/(myMax[i]-myMin[i]);
}

#transform statistics via boxcox
library("MASS");
for(i in 1:length(stats)){
  d<-cbind(stats[,i], params);
  mylm<-lm(as.formula(d), data=d)
  myboxcox<-boxcox(mylm, lambda=seq(-50, 80, 1/10), plotit=T, interp=T, eps=1/50);
  lambda<-c(lambda, myboxcox$x[myboxcox$y==max(myboxcox$y)]);
  print(paste(names(stats)[i], myboxcox$x[myboxcox$y==max(myboxcox$y)]));
  myGM<-c(myGM, exp(mean(log(stats[,i]))));
}

#standardize the BC-stats
myBCMeans<-c(); myBCSDs<-c();
for(i in 1:length(stats)){
  stats[,i]<-(stats[,i]^lambda[i] - 1)/(lambda[i]*myGM[i]^(lambda[i]-1));
  myBCSDs<-c(myBCSDs, sd(stats[,i]));
  myBCMeans<-c(myBCMeans, mean(stats[,i]));
  stats[,i]<-(stats[,i]-myBCMeans[i])/myBCSDs[i];
}

#perform pls
library("pls");
#myPlsr<-plsr(as.matrix(params) ~ as.matrix(stats), scale=F, ncomp=numComp, validation="LOO");
myPlsr<-plsr(as.matrix(params) ~ as.matrix(stats), scale=F, ncomp=numComp);

#write pls to a file
myPlsrDataFrame<-data.frame(comp1=myPlsr$loadings[,1]);
for(i in 2:numComp) { myPlsrDataFrame<-cbind(myPlsrDataFrame, myPlsr$loadings[,i]); }
write.table(cbind(names(stats), myMax, myMin, lambda, myGM, myBCMeans, myBCSDs, myPlsrDataFrame), file=paste(directory, "PLSdef_", filename, sep=""), col.names=F, row.names=F, sep="\t", quote=F);

#make RMSE plot
pdf(paste(directory, "RMSE_", filename, ".pdf", sep=""));
plot(RMSEP(myPlsr), ylim=c(0,1));
dev.off();


# run with `Rscript 6.r`
iterations <- 79
file <- "6.in"
state <- as.numeric(read.csv(file, header = FALSE, sep = ",")[1,])
state <- state + replicate(length(state), 1)

# brute force is too slow for part two :(
for (iter in 0:iterations)
{
    state_length <- length(state)
    # print(state_length)
    # internal state is all initialized to 7
    internal_state <- replicate(state_length, 7)

    # print(state)
    # print(typeof(state))
    # print(replicate(state_length, -1))
    state <- state - replicate(state_length, 1)

    zeros <- sum(state == 0)
    # print(zeros)
    # change 0s to internal state + 2
    # print(state)
    for (i in seq_along(state))
    {
        # print(state[i])
        if (state[i] == 0)
        {
            internal_state[i] = internal_state[i] + 2
            state[i] = internal_state[i]
        }
    }
    if (zeros != 0) {
        new_items <- replicate(zeros, 7)
        internal_state <- append(internal_state, new_items)
        state <- append(state, new_items)
    }
    # internal_state <- append(internal_state, new_items)
    # state <- append(state, new_items)
    # print(zeros)
    # print(state)
    # print("------")
}
print(length(state))


#Objetivo1:  resolver el tema de los NAs  y si se debe ordenar ascendente o descendente
#Objetivo2:  aplicar a todas las variables

#limpio la memoria
rm(list=ls())
gc()

library("data.table")

#cargo los datos
dataset <- fread("201902.txt")

#creo una clase que se 1 cuando es BAJA+2   , y  0 en caso contrario
#esto me simplifica las cuentas
dataset[ , clase01:= as.numeric(clase_ternaria=="BAJA+2") ]

#creo una variable azar que me va a ser util

#inicializo el generador de numeros aleatorios
set.seed( 102191 )
dataset[ , azar   := runif(nrow(dataset)) ]

#calculos basicos
universo  <-  nrow(dataset )
pos_total <-  sum(dataset$clase01 )
neg_total <-  universo -  pos_total

#-------------------------------------------------------------
# Creo una funcion para automatizar
graficar_init  = function()
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  #la diagonal
  azar_neg <- c( 0, neg_total )
  azar_pos <- c( 0, pos_total )

  #grafico
  plot( azar_neg,
        azar_pos,
        type="n",
        main=paste( "ROC Curve" ),
        xlab="neg",
        ylab="pos",
        pch=19)

  lines( azar_neg, azar_pos,   type="l" , col="black", lwd=2)
}
#----------------------

columna_graficar  = function(dataset, pcolumna )
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  #ordeno por  <pcolumna, azar>
  univar <- dataset[ order(get(pcolumna), na.last=FALSE, azar),   c("clase01", pcolumna), with=FALSE]

  neg_acum  <- cumsum( 1- univar$clase01 )
  pos_acum  <- cumsum( univar$clase01 )

  lines( neg_acum, pos_acum,   type="l" , col="red", lwd=2)

  AUC_vector <-  ( pos_acum*neg_acum + (pos_acum+pos_total)*(neg_total-neg_acum) ) / (2*pos_total*neg_total)

  return(  list( "variable"= pcolumna,
                 "valor"   = univar[ which.max( AUC_vector ),  get(pcolumna)],
                 "AUC_max" = max( AUC_vector)
               ) )
}
#----------------------

graficar_init()
columna_graficar(  dataset, "Visa_cuenta_estado"  )

#Los primeros son los = Na's
#La  gran linea que luego cruza el azar es  = 10
#La ultima peque?a linea que sube hasta el (1,1)  son los  { 11, 12, 19 }

columna_metricas  = function(pcolumna, dataset)
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  pos_na    <-  sum(  dataset[ is.na( get(pcolumna) ), clase01 ],  na.rm=TRUE )
  neg_na    <-  sum(  1- dataset[ is.na( get(pcolumna) ), clase01 ],  na.rm=TRUE  )

  va_ultimo <-  pos_na/( pos_na + neg_na + 1 )   <   pos_total/neg_total

  #ordeno creciente por  <pcolumna, azar>
  univar <- dataset[ order(get(pcolumna), na.last=va_ultimo, azar),   c("clase01", pcolumna), with=FALSE]

  neg_acum  <- cumsum( 1- univar$clase01 )
  pos_acum  <- cumsum( univar$clase01 )

  gan_acum  <- 19500*pos_acum - 500*neg_acum

  AUC_vector <-  ( pos_acum*neg_acum + (pos_acum+pos_total)*(neg_total-neg_acum) ) / (2*pos_total*neg_total)
  AUC_creciente_max <-  max( AUC_vector)
  gan_creciente_max <-  max( gan_acum )

  #ordeno DEcreciente por  <pcolumna, azar>
  univar <- dataset[ order(-get(pcolumna), na.last=va_ultimo, azar),   c("clase01", pcolumna), with=FALSE]

  neg_acum  <- cumsum( 1- univar$clase01 )
  pos_acum  <- cumsum( univar$clase01 )

  gan_acum  <- 19500*pos_acum - 500*neg_acum

  AUC_vector <-  ( pos_acum*neg_acum + (pos_acum+pos_total)*(neg_total-neg_acum) ) / (2*pos_total*neg_total)
  AUC_decreciente_max <-  max( AUC_vector)
  gan_decreciente_max <-  max( gan_acum )

  return(  list(  "columna"  = pcolumna,
                  "AUC_max"  = pmax( AUC_creciente_max, AUC_decreciente_max) ,
                  "gan_max"  = pmax( gan_creciente_max, gan_decreciente_max)
               )
        )

}
#----------------------

columna_metricas( "mcuentas_saldo",  dataset )

metricas <- lapply( colnames( dataset) , columna_metricas,  dataset )

metricas <- rbindlist( metricas )

metricas <- metricas[ order( -AUC_max ), ]
metricas[ 1:10, ]

metricas <- metricas[ order( -gan_max ), ]
metricas[ 1:10, ]

columna_metricas( "ttarjeta_visa",  dataset )

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

columna_graficar_ganancia_n  = function(dataset, pcolumna, pcantidad )
{
  #calculos basicos
  universo  <-  nrow(dataset )
  pos_total <-  sum(dataset$clase01 )
  neg_total <-  universo -  pos_total

  #ordeno por  <pcolumna, azar>
  univar <- dataset[ order(get(pcolumna), na.last=FALSE, azar),   c("clase01", pcolumna), with=FALSE]

  #acumulo positivos y negativos,  operacion vectorial
  neg_acum  <- cumsum( 1- univar$clase01 )
  pos_acum  <- cumsum( univar$clase01 )

  gan_acum  <- 19500*pos_acum - 500*neg_acum

  #grafico
  plot( seq(pcantidad),
        gan_acum[1:pcantidad],
        type="n",
        main=paste( "Ganancia ordenado por", pcolumna  ),
        xlab="registros",
        ylab="Ganancia",
        pch=19)

  lines( seq(pcantidad), gan_acum[1:pcantidad],   type="l" , col="blue", lwd=2)

  return(  list( "variable"= pcolumna,
                 "valor"   = univar[ which.max( gan_acum ),  get(pcolumna)],
                 "gan_max" = max( gan_acum),
                 "regis"   = which.max( gan_acum )
               )
         )
}
#---------------------

columna_graficar_ganancia_n( dataset, "tmovimientos_ultimos90dias", 35000  )
columna_graficar_ganancia_n( dataset, "mcuentas_saldo", 1275.59  )

#Y ahora la tabla de contingencia

ftable(dataset[ tmovimientos_ultimos90dias <= 20, clase_ternaria])
ftable(dataset[ tmovimientos_ultimos90dias  > 20, clase_ternaria])


# Assignment: ASSIGNMENT 3
# Name: Pahmer, David
# Date: 2022-4-3

## Load the ggplot2 package
library(ggplot2)
theme_set(theme_minimal())

## Set the working directory to the root of your DSC 520 directory
setwd("C:/users/pahme/onedrive/documents/github/dsc520")

## Load the `data/r4ds/heights.csv` to
heights_df <- read.csv("data/r4ds/heights.csv")

# https://ggplot2.tidyverse.org/reference/geom_point.html
## Using `geom_point()` create three scatterplots for
## `height` vs. `earn`
ggplot(heights_df, aes(x=height, y=earn)) + geom_point()
ggsave("earn vs height.jpg")

## `age` vs. `earn`
ggplot(heights_df, aes(y=earn, x=age)) + geom_point()
ggsave("earn vs age.jpg")

## `ed` vs. `earn`
ggplot(heights_df, aes(y=earn, x=ed)) + geom_point()
ggsave("earn vs ed.jpg")

## Re-create the three scatterplots and add a regression trend line using
## the `geom_smooth()` function
## `height` vs. `earn`
ggplot(heights_df, aes(x=height, y=earn)) + geom_point() + geom_smooth()
ggsave("earn vs height and reg.jpg")

## `age` vs. `earn`
ggplot(heights_df, aes(y=earn, x=age)) + geom_point() + geom_smooth()
ggsave("earn vs age and reg.jpg")

## `ed` vs. `earn`
ggplot(heights_df, aes(y=earn, x=ed)) + geom_point() + geom_smooth()
ggsave("earn vs ed and reg.jpg")

## Create a scatterplot of `height`` vs. `earn`.  Use `sex` as the `col` (color) attribute
ggplot(heights_df, aes(x=height, y=earn, col=sex)) + geom_point()
ggsave("earn vs height and sex.jpg")

## Using `ggtitle()`, `xlab()`, and `ylab()` to add a title, x label, and y label to the previous plot
## Title: Height vs. Earnings
## X label: Height (Inches)
## Y Label: Earnings (Dollars)
ggplot(heights_df, aes(x=height, y=earn, col=sex)) + geom_point() + ggtitle("Earnings vs. Height") +
  xlab("Height (inches)") + ylab("Earnings (Dollars)")
ggsave("earn vs height with labels.jpg")

# https://ggplot2.tidyverse.org/reference/geom_histogram.html
## Create a histogram of the `earn` variable using `geom_histogram()`
ggplot(heights_df, aes(earn)) + geom_histogram()
ggsave("earn histogram.jpg")

## Create a histogram of the `earn` variable using `geom_histogram()`
## Use 10 bins
ggplot(heights_df, aes(earn)) + geom_histogram(bins = 10)
ggsave("earn histogram 10 bins.jpg")

# https://ggplot2.tidyverse.org/reference/geom_density.html
## Create a kernel density plot of `earn` using `geom_density()`
ggplot(heights_df, aes(earn)) + geom_density()
ggsave("earn density.jpg")


#Copyright 2016 Lingjiao Chen, Arun Kumar, Jeffrey Naughton, and Jignesh M. Patel, Version 0.8.
#All rights reserved.
#
#Licensed under the Apache License, Version 2.0 (the "License");
#you may not use this file except in compliance with the License.
#You may obtain a copy of the License at
#
#    http://www.apache.org/licenses/LICENSE-2.0
#
#Unless required by applicable law or agreed to in writing, software
#distributed under the License is distributed on an "AS IS" BASIS,
#WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
#See the License for the specific language governing permissions and
#limitations under the License.

##############################################################
print('Logistic Regression on dataset Movie')

##############################################################
# Load in Packages
print('Loading Packages...')
library("Matrix");
library("matrixStats");
library(data.table);
MyDir = getwd();
SrcDir = paste(getwd(),'/src',sep="");
setwd(SrcDir)
file.sources = list.files(pattern="*.r",recursive=TRUE)
sapply(file.sources,source,.GlobalEnv)
setwd(MyDir)
# Parameter Setting
options(digits = 15)
options(scipen=20)
print('Loading Packages is done')

##############################################################
# Load in Data
##############################################################
print("Loading data...");
S = matrix(0,0,0);

FK1dir = './Data/MovieLens1M/MLFK1.csv';
R1dir = './Data/MovieLens1M/MLR1Sparse.txt';
JSet1 = as.matrix(read.table(FK1dir,header=TRUE));
nS = nrow(JSet1);
nR1 = max(JSet1);
FK1 = sparseMatrix(i=c(1:nS),j=JSet1,x=1,dims=c(nS,nR1));
R1S = readMM(file=R1dir)+0;

FK2dir = './Data/MovieLens1M/MLFK2.csv';
R2dir = './Data/MovieLens1M/MLR2Sparse.txt';
JSet2 = as.matrix(read.table(FK2dir,header=TRUE));
nS = nrow(JSet2);
nR2 = max(JSet2);
FK2 = sparseMatrix(i=c(1:nS),j=JSet2,x=1,dims=c(nS,nR2));
R2S = readMM(file=R2dir)+0;

Ydir = './Data/MovieLens1M/MLY.csv';
Ytest = as.matrix(( fread(Ydir)));
Y = (Ytest > 2.5)+0;
print("Loading data is done");

#############################################################
# Creating Materialized data table and normalized matrix
print("Creating Materialized data table and normalized matrix");
T = cbind(FK1%*%R1S,FK2%*%R2S);
TNM = NormalMatrix(EntTable=list(S),AttTables=list(R1S,R2S),KFKDs=list(FK1,FK2),Sparse=TRUE);
print("Creating Materialized data table and normalized matrix is done");

#############################################################
# Parameter
winit = Matrix(rnorm(ncol(T),2),ncol(T),1,sparse=TRUE);
gamma0 = 0.000001;
Max_Iter = 2;
Result_eps = 1e-6;

#############################################################
# Materilaized Version
print("Materialized Version:");
Material_Time1 = Sys.time();
Material_Result = LogisticRegression(T,Max_Iter, winit, gamma0, Y);
Material_RunTime = Sys.time()-Material_Time1;
print("Materialized Version is done\n");
print("Materialization Runtime:");
print(Material_RunTime);

#############################################################
# Morpheus
print("Morpheus:\n");
Morpheus_Time1 = Sys.time();
Morpheus_Result = LogisticRegression(TNM,Max_Iter, winit, gamma0, Y);
Morpheus_RunTime = Sys.time()-Morpheus_Time1;
print("Morpheus is done\n");
print("Morpheus Runtime: ");
print(Morpheus_RunTime);

if(norm(as.matrix(Material_Result[[1]] - Morpheus_Result[[1]]),'F')<Result_eps*(1+norm(as.matrix(Material_Result[[1]]),'F')) )
{
	print("Pass verification (Both approches return the same ML model).");
}else
{
	print("Fail to pass verification (Both approches return different models).");
}


group_sum <- function(elem) {
#  a <- k_cast(k_reshape(k_sum(elem), c(1, 1) ), k_floatx())
#  a <- tf$RaggedTensor$from_tensor(k_reshape(k_sum(elem), c(1, 1) ) )

#  browser()
#  nr <- k_constant(k_int_shape(elem)[1])
#  ret <- tf$cond(
#    k_equal(nr, 1.),
#      function() {
#        a
#      },
#      function() {
#        k_concatenate(
#            list(a, k_zeros(c(k_shape(elem)[1] - 1L, 1L))), 1)
#      })

#  print(ret)
  tf$RaggedTensor$from_tensor(k_repeat_elements(k_reshape(k_sum(elem), c(1L, 1L)),
    k_shape(elem)[1], 0))

}

tf_identity <- function(elem) {
  k_flatten(elem)
}

#' @importFrom keras k_sum k_log k_map_fn
#' @importFrom tensorflow tf
neg_log_prop_haz_lik <- function(y_true, y_pred) {
  y_time <- y_true[, 1]
  y_status <- y_true[, 2]
  nr <- k_shape(y_true)[1]
#  y_pred <- y_pred / k_cast(nr, k_dtype(y_pred))
  sv <- tf$math$top_k(y_time, nr, TRUE)
  sorted_time <- sv[0]
  sorted_indices <- sv[1]
  sorted_status <- k_gather(y_status, sorted_indices)
  sorted_preds <- k_cast(k_gather(y_pred, sorted_indices), "float64")
  thetas <- k_exp(sorted_preds) #k_exp(k_cast(sorted_preds, "float64"))
  theta_sum <- k_cumsum(thetas)
  sorted_status <- k_reshape(sorted_status, c(k_shape(sorted_status)[1], 1L))
  k_max(
    list(
      -k_sum(k_cast(sorted_status, k_dtype(sorted_preds)) * sorted_preds -
                    k_log(theta_sum)),
      -10.e6))
}

neg_log_prop_haz_lik_ref <- function(y_true, y_pred) {
  y_time <- y_true[,1]
  y_status <- y_true[,2]
  sum_thetas <- vapply(y_time,
    function(t) {
      sum(exp(y_pred[ t <= y_time ]))
    },
    NA_real_)
  print(sort(sum_thetas))
  preds <- y_pred * y_status
  -sum(preds - log(sum_thetas))
}