library(tidyverse)
library(data.table)
library(USAboundaries)
library(USAboundariesData)
library(tigris)
library(albersusa)
library(scales)
library(viridisLite)

large_text_theme = theme(
  plot.title = element_text(size = 24),
  plot.subtitle = element_text(size = 18, face = 'italic'),
  plot.caption = element_text(size = 13, face = 'italic', hjust = 0),
  axis.text = element_text(size = 16),
  axis.title = element_text(size = 18)
)
library(cowplot)

setwd("~/Public_Policy/Projects/Affordable Care Act/data")
list.files()
medicaid_expansion_data = read_csv('medicaid_expansion_states.csv')
national_uninsured_stats_files = list.files("national characteristics of uninsured", pattern = '_data.*.csv', full.names = T)
county_uninsured_stats_files = list.files("county characteristics of uninsured, 5-year", pattern = '_data.*.csv', full.names = T)
state_uninsured_stats_files = list.files("state characteristics of uninsured, 5-year", pattern = '_data.*.csv', full.names = T)

get_stacked_acs_data = function(filenames) {

  all_stacked_uninsured_data = map(filenames, function(the_file){
    print(the_file)

    headers = read_csv(the_file, n_max = 1)
    # t(headers) %>% View()
    uninsured_data = read_csv(the_file, col_names = F, skip = 2, na = c('', 'NA', 'null'))
    names(uninsured_data) = names(headers)

    uninsured_data = rename(uninsured_data, total_population = S2702_C01_001E, uninsured = S2702_C02_001E) %>%
      mutate(
        total_population = as.numeric(total_population),
        uninsured = as.numeric(uninsured),
        year = str_extract(the_file, 'ACSST[0-9+]{1}Y[0-9]{4}') %>% str_remove('ACSST[0-9]{1}Y') %>% as.numeric()
      ) %>%
      select(GEO_ID, NAME, year, total_population, uninsured)
  }) %>%
    bind_rows() %>%
    mutate(
      percent_uninsured = uninsured / total_population,
      fips = str_extract(GEO_ID, 'US[0-9]+') %>% str_remove('US')
    )
  return(all_stacked_uninsured_data)
}

national_uninsured_data = get_stacked_acs_data(national_uninsured_stats_files)
state_uninsured_data = get_stacked_acs_data(state_uninsured_stats_files) %>% filter(!is.na(total_population))
county_uninsured_data = get_stacked_acs_data(county_uninsured_stats_files) %>% filter(!is.na(total_population))

# View(state_uninsured_data)
# View(county_uninsured_data)

##### Plot overall uninsured stats #####

ggplot(national_uninsured_data, aes(year, percent_uninsured)) +
  theme_bw() +
  large_text_theme +
  theme(panel.grid.minor = element_blank()) +
  geom_bar(stat = 'identity', fill = 'steelblue', colour = 'black', width = 0.75) +
  geom_text(
    aes(label = paste0(comma(uninsured/1e6, accuracy = 0.1), 'M')),
    vjust = -0.5, size = 5
  ) +
  labs(
    x = '', y = 'Uninsured Population (%)',
    title = 'Trend in the U.S. Uninsured Population',
    subtitle = 'The Affordable Care Act (Obamacare) became law in 2010 and went into effect in 2014.',
    caption = 'Chart: Taylor G. White\nData: Census ACS 1-Year Estimates'
  ) +
  scale_y_continuous(labels = percent, breaks = seq(0, 0.15, by = 0.025)) +
  scale_x_continuous(breaks = unique(stacked_uninsured_data$year))

setwd("~/Public_Policy/Projects/Affordable Care Act/output")

ggsave('total_effects_uninsured.png', height = 9, width = 12, units = 'in', dpi = 600)

## get shapefile data ##
# us_counties_shp = us_counties()
# us_states_shp = us_states()
# us_map = USAboundaries::us_boundaries()
# us_states_tigris = tigris::states()
# us_counties_tigris = tigris::counties()

us_sf <- usa_sf("laea")
# plot(us_sf)
cty_sf <- counties_sf("aeqd")

View(state_uninsured_data)

state_uninsured_stats = group_by(state_uninsured_data, GEO_ID, fips, NAME         ) %>%
  summarize(
    obs = n(),
    latest_year = max(year),
    delta_uninsured_pct = percent_uninsured[year == max(year)] - percent_uninsured[year == min(year)],
    delta_uninsured = uninsured [year == max(year)] - uninsured [year == min(year)],
  ) %>%
  ungroup() %>%
  left_join(medicaid_expansion_data, by = c('NAME' = 'Name')) %>%
  arrange(delta_uninsured_pct) %>%
  mutate(
    state_name_factor = factor(NAME, levels = NAME)
  )
state_uninsured_stats$NAME

county_uninsured_stats = group_by(county_uninsured_data, GEO_ID, fips) %>%
  summarize(
    obs = n(),
    latest_year = max(year),
    delta_uninsured_pct = percent_uninsured[year == max(year)] - percent_uninsured[year == min(year)],
    delta_uninsured = uninsured [year == max(year)] - uninsured [year == min(year)],
  ) %>%
  ungroup()

View(county_uninsured_data)

county_map_data = left_join(cty_sf, county_uninsured_stats)
state_map_data = left_join(us_sf, state_uninsured_stats, by = c('fips_state' = 'fips'))

ggplot(state_uninsured_stats, aes(NAME, delta_uninsured_pct)) +
  geom_bar(stat = 'identity')

ggplot(state_map_data) +
  large_text_theme +
  theme_map() +
  theme(
    plot.title = element_text(size = 24),
    plot.subtitle = element_text(size = 18, face = 'italic'),
    plot.caption = element_text(size = 13, face = 'italic', hjust = 0),
  ) +
  geom_sf(aes(fill = delta_uninsured_pct)) +
  geom_sf_text(data = filter(state_map_data, Status == 'Not Adopted'), aes(label = 'No Exp.'), fontface = 'bold', size = 3.5) +
  scale_fill_viridis_c(direction = -1, option = 'D', labels = percent, name = 'Change in Uninsured\nPopulation') +
  labs(
    title = 'Percent Change in Uninsured Population, 2013-2018',
    subtitle = 'States that did not expand Medicaid are marked "No Exp."',
    caption = 'Chart: Taylor G. White\nData: Census ACS 5-Year Estimates, Kaiser Family Foundation'
  )
ggsave('change_in_uninsured_2013_2018_map.png', height = 9, width = 12, units = 'in', dpi = 600)

ggplot(county_map_data) +
  geom_sf(aes(fill = delta_uninsured_pct)) +
  scale_fill_viridis_c()

##### create map for all 50 states #####
US_state_data = left_join(us_sf, latest_state_data, by = c('iso_3166_2' = 'location')) %>% left_join(state_geo_center, by = c('iso_3166_2' = 'state_abbr'))

ggplot() +
  geom_sf(data = US_state_data, aes(fill = log(cases_per_100k)), alpha = 0.75, size = 0.25) +
  scale_fill_viridis(guide = F, option = 'C') +
  geom_sf_text(data = US_state_data, aes(long, lat, label = comma(cases_per_100k, accuracy = 1)),
               colour = 'black', fontface='bold', size = 2) +
  theme_map() +
  labs(x = '', y = '',
       caption = 'Chart: Taylor G. White\nData: covidtracking.com',
       title = 'U.S. COVID-19 Cases by State, Per 100k Population', subtitle = sprintf('As of %s',
                                                                                unique(format(latest_state_data$date, '%B %d')))) +
  theme(
    axis.ticks = element_blank(),
    axis.text = element_blank(),
    title = element_text(size = 16),
    plot.subtitle = element_text(size = 11),
    plot.caption = element_text(hjust = 0, face = 'italic', size = 10)
  )


install.packages("devtools")
install.packages("devtools", lib="~/R/lib")
library(devtools)
devtools::use_rcpp()
devtools::install_github("cran/rgdal")

install.packages("RcppCCTZ") #for parseDatetime
install.packages("ggplot2")
install.packages("spatstat")
install.packages("RColorBrewer")
install.packages("raster") #for loading and plotting geotiff
install.packages("png")
install.packages("stringr") # for srt_pad

library(RcppCCTZ)
library(ggplot2)
library(spatstat)
library(RColorBrewer)
library(raster)
library(png)
library(stringr)

setwd("~/projects/stay-safe/heatmap-creation/")

data <- read.csv('../data/objectstream.csv', header = T)
data$timestamp2 <- parseDatetime(data$timestamp, "%Y-%m-%dT%H:%M:%SZ");
min_x <- min(data$x)
max_x <- max(data$x)
min_y <- min(data$y)
max_y <- max(data$y)

#
# constant colors
#
norm_palette <- colorRampPalette(c("white", "yellow", "orange","red"))
pal_opaque <- norm_palette(4)
pal_trans <- norm_palette(4)
pal_trans[1] <- "#FFFFFF00" #was originally "#FFFFFF"
pal_trans2 <- paste(pal_opaque,"50",sep = "")

#
# find max quantiles
#

from_timestamp <- "2018-06-21T16:19:50Z"
to_timestamp <- "2018-06-21T16:20:00Z"
filter_from <- parseDatetime(from_timestamp, "%Y-%m-%dT%H:%M:%SZ");
filter_to <- parseDatetime(to_timestamp, "%Y-%m-%dT%H:%M:%SZ");

data_subset <- subset(data, timestamp2 >= filter_from & timestamp2 <= filter_to)
data_points <- data.frame(x=data_subset$x, y=data_subset$y)

P <- as.ppp(data_points, c(min_x,max_x,min_y,max_y), checkdup=F)
Z <- density(P, bw=.5)

col_breakes
col_breakes <- as.vector(quantile(Z, probs = (0:4)/4))

#
# filtering data
#
for (from_hour in 6:23){
  for (from_minute in 0:59){
    for (from_second in 0:5){

      #from_hour <- 0
      #from_minute <- 59
      #from_second <- 5

      from_second <- from_second * 10

      to_hour <- from_hour
      to_minute <- from_minute
      to_second <- from_second + 10

      if(from_second == 50){
        to_second <- 0
        to_minute <- from_minute +1
        if(from_minute == 59){
          to_minute <- 0
          to_hour <- from_hour + 1
        }
      }

      from_hour_str <- str_pad(from_hour, 2, pad = "0")
      to_hour_str <- str_pad(to_hour, 2, pad = "0")
      from_minute_str <- str_pad(from_minute, 2, pad = "0")
      to_minute_str <- str_pad(to_minute, 2, pad = "0")
      from_second_str <- str_pad(from_second, 2, pad = "0")
      to_second_str <- str_pad(to_second, 2, pad = "0")

      from_time<- paste(from_hour_str, ":", from_minute_str, ":", from_second_str, sep="")
      to_time<- paste(to_hour_str, ":", to_minute_str, ":", to_second_str, sep="")

      print(paste("from", from_time, "to", to_time))

      from_timestamp <- paste("2018-06-21T",from_time,"Z", sep="")
      to_timestamp <- paste("2018-06-21T",to_time,"Z", sep="")
      filter_from <- parseDatetime(from_timestamp, "%Y-%m-%dT%H:%M:%SZ");
      filter_to <- parseDatetime(to_timestamp, "%Y-%m-%dT%H:%M:%SZ");

      data_subset <- subset(data, timestamp2 >= filter_from & timestamp2 <= filter_to)
      data_points <- data.frame(x=data_subset$x, y=data_subset$y)

      #
      # plot
      #
      filename <- paste("plots/", from_time,".png", sep = "")
      png(filename=filename, width = 800, height = 180)

      P <- as.ppp(data_points, c(min_x,max_x,min_y,max_y), checkdup=F)
      Z <- density(P, bw=.5)

      par(mar=c(0,0,1.5,0))
      if(nrow(data_subset) == 0){
        next
        plot(P,
             #col = pal_opaque,
             breaks = col_breakes,
             legend = col_breakes,
             zlim=c(min(col_breakes), max(col_breakes))
        )
      }else{
        Q <- quadratcount(P, nx= 6, ny=3)
        plot(intensity(Q, image=TRUE), main = from_timestamp,
             col = pal_opaque,
             #breaks = c(0.001,0.002,0.003,0.004,0.005) #col_breakes
             breaks = col_breakes,
             legend = col_breakes,
             zlim=c(min(col_breakes), max(col_breakes))
        )
        plot(P, pch=20, cex=0.3, add=T)
      }

      dev.off()

    }
  }
}

#
# geotiff -> skipped!
#
geotiff <- raster("../data/aerial-photo.geotiff")
aerial_photo <- readPNG("../data/aerial-photo.png")
plot(aerial_photo)


{% case args.infmt %}
# full
{% when 'full' %}
mat = read.table({{i.infile | quote}}, row.names = 1, header = T, check.names = F, sep = "\t")

# upper
{% when 'upper' %}
mat = read.table({{i.infile | quote}}, row.names = 1, header = T, check.names = F, sep = "\t", fill = T)
mat[lower.tri(mat)] <- t(mat)[lower.tri(mat)]

# lower
{% when 'lower' %}
mat = read.table({{i.infile | quote}}, row.names = 1, header = T, check.names = F, sep = "\t", fill = T)
mat[upper.tri(mat)] <- t(mat)[upper.tri(mat)]

# pair
{% when 'pair' %}
mat0 <- read.table({{i.infile | quote}}, header=F, row.names=NULL, stringsAsFactor=F, check.names=F)
name1 = as.character (mat0[, 1])
name2 = as.character (mat0[, 2])
names = unique(union(name1, name2))
nlen  = length(names)
mat   = matrix(NA, ncol = nlen, nrow = nlen)
rownames(mat) = names
colnames(mat) = names
diag(mat)     = 0
mat[as.matrix(mat0[,1:2,drop=F])] = mat0[,3]

ut = upper.tri(mat)
lt = lower.tri(mat)

utdata = mat[ut]
ltdata = mat[lt]

uttdata = t(mat)[ut]
lttdata = t(mat)[lt]

utdata[is.na(utdata)] = uttdata[!is.na(uttdata)]
ltdata[is.na(ltdata)] = lttdata[!is.na(lttdata)]

mat[ut] = utdata
mat[lt] = ltdata

{% endcase %}

coords = cmdscale(mat, k={{args.k}})
coords = round(coords, 3)
write.table (coords, {{o.outfile | quote}}, col.names=T, row.names=T, quote=F, sep="\t", na="")


# calculate_compensation_website.r
#
# Copyright (c) 2020 VIB (Belgium) & Babraham Institute (United Kingdom)
#
# Software written by Carlos P. Roca, as research funded by the European Union.
#
# This software may be modified and distributed under the terms of the MIT
# license. See the LICENSE file for details.

# Runs a calculation of compensation with autospill, creating all figures and
# tables used in autospill website.
#
# Requires being called as a batch script, and assumes fixed values for the
# following two variables (see below):
#     control.dir    directory with the set of single-color controls
#     control.def.file    csv file defining the names and channels of the
#         single-color controls

library( autospill )

# set parameters

asp <- get.autospill.param( "website" )

asp

# read flow controls

control.dir <- "./samples/"
control.def.file <- "./fcs_control.csv"

flow.control <- read.flow.control( control.dir, control.def.file, asp )

names( flow.control )

flow.control$antigen
flow.control$autof.marker.idx
str( flow.control$event )
flow.control$event.n
flow.control$event.number.width
table( flow.control$event.sample )
flow.control$expr.data.max
flow.control$expr.data.max.ceil
flow.control$expr.data.min
str( flow.control$expr.data.tran )
str( flow.control$expr.data.untr )
flow.control$figure.scatter.dir
str( flow.control$flow.set, max.level = 1 )
str( flow.control$gate.parameter )
flow.control$marker
flow.control$marker.n
flow.control$marker.original
flow.control$sample
flow.control$scatter.and.marker
flow.control$scatter.and.marker.label
flow.control$scatter.and.marker.original
flow.control$scatter.parameter
str( flow.control$transform )
str( flow.control$transform.inv )
flow.control$wavelength

# gate events before calculating spillover

flow.gate <- gate.flow.data( flow.control, asp )

str( flow.gate )

# get initial spillover matrices from untransformed and transformed data

marker.spillover.unco.untr <- get.marker.spillover( TRUE, flow.gate,
    flow.control, asp )
marker.spillover.unco.tran <- get.marker.spillover( FALSE, flow.gate,
    flow.control, asp )

str( marker.spillover.unco.untr$inte )
str( marker.spillover.unco.untr$coef )

str( marker.spillover.unco.tran$inte )
str( marker.spillover.unco.tran$coef )

# refine spillover matrix iteratively

refine.spillover.result <- refine.spillover( marker.spillover.unco.untr,
    marker.spillover.unco.tran, flow.gate, flow.control, asp )

str( refine.spillover.result )

# output session info

sessionInfo()


## to be sourced from main analysis script

gee_multi_plate <- function(data, levels) {
    fit <- geeglm(
        rel_lum ~ factor(allele, levels=levels) + factor(plate_id),
        data=data,
        id=factor(plate_id):factor(clone_id),
        family=gaussian(link="log"),
        corstr="exchangeable",
        std.err="san.se",
        zcor=NULL
    )
    return(fit)
}

gee_single_plate <- function(data, levels) {
    fit <- geeglm(
        rel_lum ~ factor(allele, levels=levels),
        data=data,
        id=factor(clone_id),
        family=gaussian(link="log"),
        corstr="exchangeable",
        std.err="san.se",
        zcor=NULL
    )
    return(fit)
}

fit_gee <- function(data) {
    if (length(levels(factor(data$plate_id))) > 1) {
        cat("testing multi plate experiment\n")
        if (length(levels(factor(data$allele))) == 3) {
            cat("testing tri alleleic site\n")
            levs <- levels(factor(data$allele))
            fit1 <- gee_multi_plate(data, levs)
            idx <- data$allele %in% levs[2:3]
            fit2 <- gee_multi_plate(data[idx, ], levs[2:3])
            fit <- setNames(list(fit1, fit2), c("default", "extra"))
        } else {
            cat("testing bi alleleic site\n")
            levs <- levels(factor(data$allele))
            fit <- gee_multi_plate(data, levs)
        }
    } else {
        cat("testing single plate experiment\n")
        if (length(levels(factor(data$allele))) == 3) {
            cat("testing tri alleleic site\n")
            levs <- levels(factor(data$allele))
            fit1 <- gee_single_plate(data, levs)
            idx <- data$allele %in% levs[2:3]
            fit2 <- gee_single_plate(data[idx, ], levs[2:3])
            fit <- setNames(list(fit1, fit2), c("default", "extra"))
        } else {
            cat("testing bi alleleic site\n")
            levs <- levels(factor(data$allele))
            fit <- gee_single_plate(data, levs)
        }
    }
    return(fit)
}

fit_parser <- function(fit) {
    df <- summary(fit)$coefficients
    df <- df[2:nrow(df), ]
    colnames(df) <- c("Effect", "SE", "Wald_Stat", "pval")
    df$Locus_Cell <- paste(unname(unlist(
        fit$data[1, c("locus", "orientation", "cell_line")]
    )), collapse="_")
    df$A1 <- levels(fit$model[ , "factor(allele, levels = levels)"])[1]
    df$A2 <- unlist(lapply(strsplit(rownames(df), ")"), "[[", 2))
    df$Label <- paste(df$Locus_Cell, paste(df$A1, df$A2, sep="_"), sep="::")
    col_order <- c(
        "Label", "Locus_Cell", "A1", "A2", "Effect", "SE", "Wald_Stat", "pval"
    )
    df <- df[col_order]
    i <- suppressWarnings(which(is.na(as.numeric(df$A2))))
    df <- df[i, ]
    return(df)
}

parse_gee <- function(fit) {
    if (class(fit)[1] == "list") {
        cat("extracting coefficient summary for tri alleleic site\n")
        df <- lapply(fit, fit_parser)
    } else {
        cat("extracting coefficient summary for bi alleleic site\n")
        df <- fit_parser(fit)
    }
    return(df)
}

write_gee <- function(sums, target) {
    obj <- lapply(sums, FUN <- function(sum) {
        if (class(sum) == "list") {
            df <- do.call(rbind, sum)
        } else {
            df <- sum
        }
        return(df)
    })
    df <- do.call(rbind, obj)
    write.table(
        df, file=target, quote=FALSE, sep="\t", row.names=FALSE, col.names=TRUE
    )
    cat("table written to", target, "\n")
}


install.packages(c("statebins", "viridis"))

library(statebins) # https://rpubs.com/sdtanner/Statebin_project
library(viridis)

source("../utility_scripts/data_prep.r")
source("../utility_scripts/annotation_defaults.r")

data <- scent_data %>%
  select(state, trial) %>%
  distinct(trial, .keep_all=TRUE) %>%
  group_by(state) %>%
  summarize(number_of_trials = n()) %>%
  ungroup() %>%
  arrange(desc(number_of_trials))
head(data)

plot <- statebins(
    state_data = data,
    value_col = "number_of_trials",
    ggplot2_scale_function = scale_fill_viridis,
    light_label = "white",
    dark_label = "white",
    font_size = 5,
    round = TRUE) +
  scale_fill_viridis(option="turbo", name="Number of trials") +
  theme_statebins() +
  theme(
    legend.position = 'right',
    legend.text = element_text(size=9, color="black"),
    legend.key.height = unit(1.2, "cm")
  )

annotated_plot <- getAnnotatedPlot(
  plot,
  title="Number of NACSW Trials by State",
  subtitle="State-wise count of all trials since 2009")
annotated_plot

ggsave("trials_across_space_states.png", plot=annotated_plot, path=".", width=4194, height=3226, units="px",
       bg="white")


#' Create a new (empty) medley object
#'
#' @param x matrix of predictors
#' @param y vector of response values
#' @param label a unique label for this medley (used in status messages)
#' @param errfunc an error metric for this medley
#' @param base.model a function to use as a baseline model
#' @param folds the default number of cross-validation folds to use
#' @export
#' @examples
#' require(e1071);
#' data(swiss);
#' x <- swiss[,1:5];
#' y <- swiss[,6];
#' train <- sample(nrow(swiss), 30);
#' m <- create.medley(x[train,], y[train]);
#' for (gamma in c(1e-3, 2e-3, 5e-3, 1e-2, 2e-2, 5e-2, 1e-1, 2e-1, 5e-1, 1)) {
#'   m <- add.medley(m, svm, list(gamma=gamma));
#' }
#' p <- predict(m, x[-train,]);
#' rmse(p, y[-train]);
create.medley <- function (x, y, label='', errfunc=rmse, base.model=NULL, folds=8) {
  if (!is.null(base.model)) {
    base.y <- predict(base.model, x);
  } else {
    base.y <- rep(0, length(y));
  }
  object <- list(
    x=as.matrix(x),
    y=y,
    base.y=base.y,
    mod.y=y - base.y,
    errfunc=errfunc,
    models=list(),
    args=list(),
    predict.args=list(),
    feature.subset=list(),
    fitted=list(),
    cv=list(),
    base.model=base.model,
    label=label,
    folds=folds,
    postprocess=list()
  );
  class(object) <- 'medley';
  return(object);
}

#' Recursively combine two or more medley objects for the same problem
#'
#' @param e1 the first medley to combine
#' @param e2 the second medley to combine
#' @param ... further medleys to combine
#' @export
combine.medley <- function (e1, e2=NULL, ...) {
  if (is.null(e2)) return(e1);

  e1$models <- c(e1$models, e2$models);
  e1$args <- c(e1$args, e2$args);
  e1$predict.args <- c(e1$predict.args, e2$predict.args);
  e1$feature.subset <- c(e1$feature.subset, e2$feature.subset);
  e1$fitted <- c(e1$fitted, e2$fitted);
  e1$cv <- c(e1$cv, e2$cv);
  e1$postprocess <- c(e1$postprocess, e2$postprocess);
  return(combine.medley(e1, ...));
}

#' Add a new model to an existing medley
#'
#' @param object the medley to be added to
#' @param model the model fitting function
#' @param args a list of extra arguments to \code{model}
#' @param predict.args a list of extra arguments to the predict function for \code{model}
#' @param feature.subset a subset of the features to use
#' @param folds the number of cross-validation folds to use
#' @param postprocess an optional function to apply to the predicted values
#' @export
add.medley <- function (object, model, args=list(), predict.args=list(), feature.subset=NULL, folds=object$folds, postprocess=c()) {
  if (is.null(feature.subset)) {
    feature.subset <- c(1:ncol(object$x));
  }
  n <- length(object$models) + 1;
  object$models[[n]] <- model;
  object$args[[n]] <- args;
  object$predict.args[[n]] <- predict.args;
  object$feature.subset[[n]] <- feature.subset;
  object$postprocess[[n]] <- function(x) x;

  pt <- proc.time()[[3]];
  # Fit model to all data
  data <- list(x=object$x[,feature.subset], y=object$mod.y);
  object$fitted[[n]] <- do.call(model, c(data, args));

  # Do cross-validation
  k <- length(object$y);
  cv.sets <- (seq_len(k) %% folds) + 1;

  pred <- numeric(k);
  for (i in 1:folds) {
    holdout <- which(cv.sets == i);
    data <- list(x=object$x[-holdout,feature.subset], y=object$mod.y[-holdout]);
    fitted <- do.call(model, c(data, args));
    preddata <- list(fitted, newdata=object$x[holdout,feature.subset])
    pred[holdout] <- do.call(predict, c(preddata, predict.args));
  }
  object$cv[[n]] <- pred + object$base.y;
  pt <- proc.time()[[3]] - pt;
  cat(object$label, 'CV model', n, class(object$fitted[[n]]), substring(deparse(args, control=NULL), 5), 'time:', pt, 'error:', object$errfunc(object$y, object$cv[[n]]), '\n');

  nn <- n;
  for (pp in postprocess) {
    nn <- nn + 1;
    object$models[[nn]] <- model;
    object$args[[nn]] <- args;
    object$predict.args[[nn]] <- predict.args;
    object$feature.subset[[nn]] <- feature.subset;
    object$postprocess[[nn]] <- pp;
    object$fitted[[nn]] <- object$fitted[[n]];
    object$cv[[nn]] <- pp(pred) + object$base.y;
    cat(object$label, 'PP error:', object$errfunc(object$y, object$cv[[nn]]), '\n');
  }

  return(object);
}

#' Prune the models in a medley
#'
#' @param object the medley to prune
#' @param prune.factor the proportion of the models to keep
#' @export
prune.medley <- function (object, prune.factor=0.2) {
  n <- ceiling(length(object$models) * prune.factor);
  errs <- sapply(object$cv, function(pred) object$errfunc(object$y, pred));
  keep <- order(errs)[1:n];
  object$models <- object$models[keep];
  object$args <- object$args[keep];
  object$predict.args <- object$predict.args[keep];
  object$feature.subset <- object$feature.subset[keep];
  object$fitted <- object$fitted[keep];
  object$cv <- object$cv[keep];
  return(object);
}

#' Make a prediction based on a medley
#'
#' @param object the medley to predict from
#' @param newdata a matrix of new predictor data
#' @param seed indices of models which should be used for an initial ensemble
#' @param min.members the minimum number of models in an ensemble (selected randomly)
#' @param max.members the maximum number of models in an ensemble
#' @param baggs the number of bagging iterations to perform
#' @param mixer a function to combine model predictions
#' @param ... other arguments (unused)
#' @method predict medley
#' @export
predict.medley <- function (object, newdata, seed=c(), min.members=5, max.members=100, baggs=1, mixer=mean, ...) {
  newdata <- as.matrix(newdata);
  best.errs <- c();
  big.mix <- c();
  for (i in 1:baggs) {
    if (baggs == 1) {
      s <- 1:length(object$y);
    } else {
      s <- sample(length(object$y), replace=T);
    }
    model.sample <- sample(length(object$models), length(object$models) * .8);
    cat('Sampled...');
    if (length(seed) == 0) {
      errs <- sapply(object$cv[model.sample], function(pred) object$errfunc(object$y[s], pred[s]));
      mix <- model.sample[order(errs)[1:min.members]];

    } else {
      mix <- seed;
    }
    mixpred <- simplify2array(object$cv[mix]);

    best.err <- object$errfunc(object$y[s], apply(mixpred, 1, mixer)[s]);

    while(length(mix) < max.members) {
      errs <- sapply(object$cv[model.sample], function(pred) object$errfunc(object$y[s], apply(cbind(mixpred, pred), 1, mixer)[s]));
      best <- which.min(errs);
      if (best.err <= errs[best]) break;
      mix <- c(mix, model.sample[best]);
      best.err <- errs[best];
      mixpred <- simplify2array(object$cv[mix]);
    }
    predictions <- list();
    for (i in unique(sort(mix))) {
      preddata <- list(object$fitted[[i]], newdata=newdata[,object$feature.subset[[i]]]);
      predictions[[i]] <- object$postprocess[[i]](do.call(predict, c(preddata, object$predict.args[[i]])));
      frac <- mean(mix == i);
      cat(format(frac*100, digits=1, nsmall=2), '%: ', i, class(object$fitted[[i]]), substring(deparse(object$args[[i]], control=NULL), 5), '\n');
    }
    best.err <- object$errfunc(object$y, apply(mixpred, 1, mixer));
    cat('CV error:', best.err, '\n');
    if (length(unique(mix)) == 1) {pred <- predictions[[mix]]}
    else {pred <- apply(simplify2array(predictions[mix]), 1, mixer)}
    best.errs <- c(best.errs, best.err);
    big.mix <- cbind(big.mix, pred);
  }
  pred <- apply(big.mix, 1, mixer);
  if (!is.null(object$base.model)) {
    pred <- pred + predict(object$base.model, newdata);
  }
  attr(pred, 'cv.err') <- mean(best.errs);
  return(pred);
}


# Functions for calculating a project's Bus Factor

library(plyr)

# Get a vector of the files in a repo
enumerate_files_in_repo <- function(repo_path) {
  system(paste("cd", repo_path, "; git ls-tree HEAD -r | awk -F '\t' '{print $2}'"), intern=T)
}

# Get a vector of author names - one for each line in a file
get_author_for_lines_in_file <- function(repo_path, filename) {
  system(paste("cd", repo_path, "; git blame --line-porcelain", filename, "| grep '^author ' | sed -e 's/^author //'"), intern=T)
}

# Count the lines by author for a vector of names
count_line_authors <- function(author) {
  as.data.frame(table(author), responseName="line_count")
}

# Count the lines by author for a given file/ repo
count_of_lines_by_author_in_file <- function(repo_path, filename) {
  line_authors <- get_author_for_lines_in_file(repo_path, filename)
  file_blame <- count_line_authors(line_authors)
  file_blame$filename <- rep(filename,nrow(file_blame))
  file_blame
}

# Count the lines by author for a whole repo
count_of_lines_by_author_in_repo <- function(repo_path) {
  repo_tree <- enumerate_files_in_repo(repo_path)
  lines_by_file <- adply(repo_tree, 1, count_of_lines_by_author_in_file, repo_path=repo_path, .progress = "text")
  ddply(lines_by_file, .(author), summarise, line_count=sum(line_count))
}

# Calculate the cumulative line count of authors in order of contribution
calculate_author_contribution <- function(author_lines) {
  author_lines$author <- reorder(as.factor(author_lines$author), -author_lines$line_count)
  sorted_contributions <- author_lines[order(author_lines$line_count, decreasing=T),]
  sorted_contributions$cumulative_line_count <- cumsum(sorted_contributions$line_count)
  sorted_contributions$cumulative_author_count <- 1:nrow(sorted_contributions)
  sorted_contributions$cumulative_line_percent <- sorted_contributions$cumulative_line_count/max(sorted_contributions$cumulative_line_count)
  sorted_contributions$cumulative_author_percent <- sorted_contributions$cumulative_author_count/max(sorted_contributions$cumulative_author_count)
  return(sorted_contributions)
}

# Calculate the number of authors required to reach a given contribution
calculate_bus_factor <- function(author_contribution, critical_threshold=0.5) {
  critical_contributions <- author_contribution[author_contribution$cumulative_line_percent < critical_threshold, ]
  nrow(critical_contributions)
}

# Overall calculation of bus factor for a given repo
calculate_bus_factor_for_repo <- function(repo) {
  lba <- count_of_lines_by_author_in_repo(repo)
  ac <- calculate_author_contribution(lba)
  calculate_bus_factor(ac)
}


## Copyright 2016 Kurt Cutajar, Edwin V. Bonilla, Pietro Michiardi, Maurizio Filippone
##
## 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.

## Code to produce the plots in the paper - comparing MCMC samples with samples from the variational posterior in a two-layer DGP model with a Gaussian likelihood

h = function(x) { exp(-x^2) * 2 * x }

## Set page size
ps.options(width=20, height=7.5, paper="special", horizontal=F, pointsize=36)
pdf.options(width=20, height=7.5, pointsize=36)

## Load data
X = as.matrix(read.table("X.txt"))
Xtest = as.matrix(read.table("Xtest.txt"))
Y = as.matrix(read.table("Y.txt"))

## Load predictions layer 1
predictions_MCMC = as.matrix(read.table("predictions_MCMC_F1.txt"))
predictions_var_NRFF_10 = as.matrix(read.table("predictions_variational_F1_NRFF_10.txt"))
predictions_var_NRFF_50 = as.matrix(read.table("predictions_variational_F1_NRFF_50.txt"))

nsamples = dim(predictions_MCMC)[2]

color_MCMC = rgb(1,0,0,alpha=0.02)
color_var = rgb(0,0,1,alpha=0.02)

## Open figure
pdf("figure_compare_MCMC_var.pdf")
par(mfrow=c(2,3),
    oma = c(1.1,2.1,1.5,0.2),
mar=c(0.3,0.5,0.0,0.0), mgp=c(1.1,0.1,0)
    ## mar = c(0,0,0,0) + 0.1
    )

## Produce plots layer 1

## par("mar"=c(1.5,1.5,0.3,0.3), "mgp"=c(1.8,0.6,0))
plot(Xtest, predictions_var_NRFF_10[,1], type="l", lwd=10, col=color_var, xlab="", ylab="Layer 1", ylim = c(-3,3), yaxt="n", xaxt="n") # , main="Variational - 10 RFF")
axis(2, at=c(-2, 0, 2), tck=0.02)
for(i in 2:nsamples) {
   points(Xtest, predictions_var_NRFF_10[,i], type="l", lwd=10, col=color_var)
}
points(Xtest, h(Xtest), type="l")

## par("mar"=c(1.5,1.5,0.3,0.3), "mgp"=c(1.8,0.6,0))
plot(Xtest, predictions_var_NRFF_50[,1], type="l", lwd=10, col=color_var, xlab="", ylab="", ylim = c(-3,3), yaxt="n", xaxt="n") # , main="Variational - 50 RFF")
for(i in 2:nsamples) {
   points(Xtest, predictions_var_NRFF_50[,i], type="l", lwd=10, col=color_var)
}
points(Xtest, h(Xtest), type="l")

## par("mar"=c(1.5,1.5,0.3,0.3), "mgp"=c(1.8,0.6,0))
plot(Xtest, predictions_MCMC[,1], type="l", lwd=10, col=color_MCMC, xlab="", ylab="", ylim = c(-3,3), yaxt="n", xaxt="n") #, main="MCMC")
for(i in 2:nsamples) {
   points(Xtest, predictions_MCMC[,i], type="l", lwd=10, col=color_MCMC)
}
points(Xtest, h(Xtest), type="l")

## ******************************

## Load predictions layer 2
predictions_MCMC = as.matrix(read.table("predictions_MCMC_F2.txt"))
predictions_var_NRFF_10 = as.matrix(read.table("predictions_variational_F2_NRFF_10.txt"))
predictions_var_NRFF_50 = as.matrix(read.table("predictions_variational_F2_NRFF_50.txt"))

## Produce plots layer 2

## par("mar"=c(1.5,1.5,0.3,0.3), "mgp"=c(1.8,0.6,0))
plot(Xtest, predictions_var_NRFF_10[,1], type="l", lwd=10, col=color_var, xlab="", ylab="Layer 2", ylim = c(-1,1), yaxt="n", tck=0.02) ##,  main="Layer 2 - Variational - 10 RFF", ylim = c(-1,1))
axis(2, at=c(-1, 0, 1), tck=0.02)
for(i in 2:nsamples) {
   points(Xtest, predictions_var_NRFF_10[,i], type="l", lwd=10, col=color_var)
}
points(X, Y, pch=20)
points(Xtest, h(h(Xtest)), type="l")

## par("mar"=c(1.5,1.5,0.3,0.3), "mgp"=c(1.8,0.6,0))
plot(Xtest, predictions_var_NRFF_50[,1], type="l", lwd=10, col=color_var, xlab="", ylab="", ylim = c(-1,1), yaxt="n", tck=0.02) ##, main="Layer 2 - Variational - 50 RFF", ylim = c(-1,1))
for(i in 2:nsamples) {
   points(Xtest, predictions_var_NRFF_50[,i], type="l", lwd=10, col=color_var)
}
points(X, Y, pch=20)
points(Xtest, h(h(Xtest)), type="l")

## par("mar"=c(1.5,1.5,0.3,0.3), "mgp"=c(1.8,0.6,0))
plot(Xtest, predictions_MCMC[,1], type="l", lwd=10, col=color_MCMC, xlab="", ylab="", ylim = c(-1,1), yaxt="n", tck=0.02) ##, main="Layer 2 - MCMC", ylim = c(-1,1))
for(i in 2:nsamples) {
   points(Xtest, predictions_MCMC[,i], type="l", lwd=10, col=color_MCMC)
}
points(X, Y, pch=20)
points(Xtest, h(h(Xtest)), type="l")

## ******************************

## Add legend text / titles
mtext('Variational - 10 RFF', side = 3, outer = TRUE, line = 0.3, at=0.18)
mtext('Variational - 50 RFF', side = 3, outer = TRUE, line = 0.3, at=0.51)
mtext('MCMC', side = 3, outer = TRUE, line = 0.3, at=0.85)
mtext('Layer 1', side = 2, outer = TRUE, line = 0.8, at=0.8)
mtext('Layer 2', side = 2, outer = TRUE, line = 0.8, at=0.25)

dev.off()


#command line a args for RScript
args <- commandArgs(trailingOnly = TRUE)

#read input + chip pairs of data for 2 samples
rmi <- read.table(args[1], header=T) #sample1 input
rmc <- read.table(args[2], header=T) #sample1 chip

rwi <- read.table(args[3], header=T) #sample2 input
rwc <- read.table(args[4], header=T) #sample2 chip

cols <- c("CEN1","CEN2","CEN3","CEN4","CEN5","CEN6","CEN7","CEN8","CEN9","CEN10","CEN11","CEN12","CEN13","CEN14","CEN15","CEN16")

#create a plot for each CEN
for(i in cols){
  #each plot names after cen
   #create a svg file for each CEN
  svg(paste(args[1],i,".svg", sep=""))

 par(cex.lab=1.4)
  # init plot
  plot(rwc$Position, log2(rwc[[i]]/rwi[[i]] ),
      xlim=c(-10000,10000),
       ylim=c(-2,5),
       pch='.', xlab="Position", ylab="Sample/Input")
# add lines for each
  lines(rwc$Position, log2( rwc[[i]]  / rwi[[i]] ),  col="red",  lwd=3)
  lines(rwc$Position, log2( rmc[[i]]  / rmi[[i]] ),  col="blue", lwd=3)

  axis(1, lwd=2)
  axis(2, lwd=2)
}


#setwd("D:/Dropbox/Data analyze/Rdocuments/datas")
library(xlsx)
 library(RColorBrewer)

 fv<-5:3500 #电压频率

q<-c(2.5e-14, 4.5e-13, 9e-13, 3e-12) #不同的流量下

k<-c(0.5,0.6,0.7,0.8) #不同占空比下无电场时间比例，即1-k_i

v<-4.66e-13  #泰勒锥的体积总量

mycolors<-c("red", "blue", "darkgreen", "yellow3")

pchall<-c(21,22,23,24)

######
par(fig=c(0,1,0,1), mar = c(3,3,1,1), oma = c(1,1,1,1),new=FALSE)
plot(fv, (k[1]*q[1]/fv+v), mgp = c(1, 0, 0),tck=0.01,col=mycolors[1], log="x", type="b", xlab = expression(italic(f["v"])(Hz)),
     ylab = expression(italic(V["ne"]+V["m"](m^3))), main="", lwd=2, pch=pchall[1], lty=2,cex.lab=1,cex.axis=1, ylim=c(4.4e-13, 8e-13))

#画出占空比为0.5，流量为1.5nl/min时的弯月面体积，说明最小值是什么

###流量为1.5nl/min时####
for (i in 1:3){
lines(fv,  (k[i+1]*q[1]/fv+v), lwd=1.5, type="b",col="red", pch=pchall[i+1],lty=2,cex=0.6)
}
#画出，流量为最小，占空比从大到小，体积从小到大变化的曲线，其中：颜色均为red，pch的改变代表着占空比的改变

###流量为27nl/min时####
par(fig=c(0,1,0,1))
for (i in 1:4){
lines(fv,  (k[i]*q[2]/fv+v), lwd=1.5, type="b", col="blue", pch=pchall[i] ,lty=2,cex=0.6)
}

###流量为54nl/min时####
for (i in 1:4){
lines(fv,  (k[i]*q[3]/fv+v), lwd=1.5, type="b", col="darkgreen", pch=pchall[i] ,lty=2,cex=0.6)
}

###流量为180nl/min时####
for (i in 1:4){
lines(fv,  (k[i]*q[4]/fv+v), lwd=1.5, type="b", col="yellow3", pch=pchall[i] ,lty=2,cex=0.6)
}

da<-c("kv0.5-Q1.5nlmin", "kv0.4-Q1.5nlmin", "kv0.3-Q1.5nlmin", "kv0.2-Q1.5nlmin", "kv0.5-Q27nlmin", "kv0.4-Q27nlmin", "kv0.3-Q27nlmin", "kv0.2-Q27nlmin","kv0.5-54nlmin", "kv0.4-Q54nlmin", "kv0.3-Q54nlmin", "kv0.2-Q54nlmin","kv0.5-Q180nlmin", "kv0.4-Q180nlmin", "kv0.3-Q180nlmin", "kv0.2-Q180nlmin")

mycolorsss<-c("red","red","red","red","blue","blue","blue","blue","darkgreen","darkgreen","darkgreen","darkgreen","yellow3","yellow3","yellow3","yellow3")

pchss<-c(21,22,23,24,21,22,23,24,21,22,23,24,21,22,23,24)

legend("topright", da, inset=0, col=mycolorsss, pch=pchss,lwd=1.5, lty=2, cex=0.8, bty="n")

abline(v=20, col="red", lwd=2,lty=3)
abline(v=45, col="blue", lwd=2,lty=3)
#abline(v=125, col="darkgreen", lwd=2,lty=3)

#################################################
par(fig=c(0.4, 0.98,0.20,0.98), new=TRUE)

plot(fv, (k[1]*q[1]/fv+v),bty="n", col=mycolors[1], mgp = c(1, 0, 0),tck=0.01,log="x", type="l", xlab = "125Hz ~ 1KHz", ylab ="", lwd=2, lty=2, xlim=c(125,1000), ylim=c(4.66e-13, 5e-13))

#画出占空比为0.5，流量为1.5nl/min时的弯月面体积，说明最小值是什么

###流量为1.5nl/min时####
for (i in 1:3){
lines(fv,  (k[i+1]*q[1]/fv+v), lwd=2, col="red", lty=1)
}
#画出，流量为最小，占空比从大到小，体积从小到大变化的曲线，其中：颜色均为red，pch的改变代表着占空比的改变

###流量为27nl/min时####
for (i in 1:4){
lines(fv,  (k[i]*q[2]/fv+v), lwd=2, col="blue", lty=1)
}

###流量为54nl/min时####
for (i in 1:4){
lines(fv,  (k[i]*q[3]/fv+v), lwd=2,col="darkgreen", lty=1)
}

###流量为180nl/min时####
for (i in 1:4){
lines(fv,  (k[i]*q[4]/fv+v), lwd=2,col="yellow3", lty=1)
}

abline(h=5.126e-13, col="red", lwd=1.5, lty=4)
abline(h=5.592e-13, col="blue", lwd=1.5, lty=4)


#install data from github repo /RamiKrispin/coronavirus
install.packages("devtools")
devtools::install_github("RamiKrispin/coronavirus")
#install coronavirus library data bulk package
library(coronavirus)
update_dataset()

#data
covid19_df <- refresh_coronavirus_jhu()
head(covid19_df)

#data.frame
covid19_df<-data.frame(covid19_df)

#plotting packages
library(ggplot2)
library(dplyr)
library(GGally)

#plots
advanced_countries<-unique(covid19_df[,"contries"])
covid19_advanced_co_df<-covid19_df%>%
filter(country=advanced_countries))
plot<-ggplot(data=covid19_df, aes(date,cases))


#' Function that transforms an alignment result in matrix form into an alignment result in data frame form
#'
#'@param alignM An alingment matrix.
#'@param distM  An distance matrix of same dimensions as alignM.
#'@param text1_indel_dist What distance should be assigned if an particular line of this text has been deleted respectively inserted?
#'@param text2_indel_dist See above.

align_matrix_to_align_df <- function(alignM,
                                     distM=NULL,
                                     text1_indel_dist=NA,
                                     text2_indel_dist=NA){
  # preparation and option handling
    if(is.null(distM)){
      distM <- matrix( rep(NA, length(alignM)), dim(alignM)[1], dim(alignM)[2])
    }
    unused_rows <- seq_len(dim(alignM)[1])[!apply(alignM,1,sum)>0]
    unused_cols <- seq_len(dim(alignM)[2])[!apply(alignM,2,sum)>0]

    if ( length(unused_rows)>0 ) {
      rows_indel_dist <- text1_indel_dist[unused_rows]
    }
    if ( length(unused_cols)>0 ) {
      cols_indel_dist <- text2_indel_dist[unused_cols]
    }

  # matrix to data frame (matches)
    df <- cbind(which(alignM==TRUE, arr.ind=T), dist=distM[alignM==TRUE])

  # add insertions and deletions from text1 and text2
    if ( length(unused_rows)>0 ){
      df <- rbind(df, cbind(unused_rows, NA, rows_indel_dist))
    }
    if ( length(unused_cols)>0 ){
      df <- rbind(df, cbind(NA, unused_cols, cols_indel_dist))
    }
    df <- as.data.frame(df)
    names(df) <- c("lnr1","lnr2","distance")

  # compute type (insertion, deletion, change, no change, ignore)
    align_type <- function(alignRow){
      lnr1     <- alignRow[1]
      lnr2     <- alignRow[2]
      distance <- alignRow[3]
      if( !any(is.na(alignRow)) ){
        if( distance==0 ) return("equal")
        if( distance> 0 ) return("mod")
      }
      if( all(is.na(alignRow)) ){
        return("empty!")
      }
      if( is.na(lnr1) & is.na(distance) ){
        return("ignore")
      }
      if( is.na(lnr2) & is.na(distance) ){
        return("ignore")
      }
      if( is.na(lnr1) ){
        return("ins")
      }
      if( is.na(lnr2) ){
        return("del")
      }
    }
    df$type = apply(df, 1, align_type)

  # return results
    return(df)
}


library(readxl)

aulas <- read_excel("X:/Development/github.com/r_study/Alura/Analise de dados - Introducao com R/data/aulas.xlsx")
# View(aulas)

attach(aulas)
options(max.print=400000)
print(sort(section_id))

aulas[33137,3] <- 3255

print(sort(aulas$section_id))

unique(aulas$section_id)

length(unique(aulas$section_id))

table(aulas$section_id)

sort(table(aulas$section_id))

library(plyr)

df_edit <- count(aulas, vars = "course_id" )

write.csv(df_edit,"X:/Development/github.com/r_study/Alura/Analise de dados - Introducao com R/data/popularidade.csv", row.names=FALSE)

Alura/Analise de dados - Introducao com R/analise_01.r


#' ---
#' title: "Prior probabilities in the interpretation of 'some': analysis of betabinomial prior wonky world model predictions"
#' author: "Judith Degen"
#' date: "January 19, 2014"
#' ---

library(ggplot2)
theme_set(theme_bw(18))
setwd("/Users/titlis/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/models/wonky_world/results/")
source("rscripts/helpers.r")

#' get model predictions
load("data/mp-betabinomial.RData")
d = read.table("data/parsed_betabinomial_results.tsv", quote="", sep="\t", header=T)
table(d$Item)
nrow(d)
head(d)
d[d$Item == "ate the seeds birds" & d$QUD=="how-many" & d$Alternatives=="0_basic" & d$SpeakerOptimality == 1,]
d[d$Item == "stuck to the wall baseballs" & d$QUD=="how-many" & d$Alternatives=="0_basic" & d$SpeakerOptimality == 2 & d$Wonky == "true",]
mp = ddply(d, .(Item, QUD, State, Alternatives, Quantifier, SpeakerOptimality, WonkyWorldPrior), summarise, PosteriorProbability=sum(PosteriorProbability))
head(mp)
#mp[mp$Item == "ate the seeds birds" & mp$QUD=="how-many" & mp$Alternatives=="0_basic" & mp$SpeakerOptimality == 1,]
wr = ddply(d, .(Item, QUD, Wonky, Alternatives, Quantifier, SpeakerOptimality, WonkyWorldPrior), summarise, PosteriorProbability=sum(PosteriorProbability))
wr[wr$Item == "ate the seeds birds" & wr$QUD=="how-many" & wr$Alternatives=="0_basic" & wr$SpeakerOptimality == 1,]

# get prior expectations
priorexpectations = read.table(file="~/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/12_sinking-marbles-prior15/results/data/expectations.txt",sep="\t", header=T, quote="")
row.names(priorexpectations) = paste(priorexpectations$effect,priorexpectations$object)
mp$PriorExpectation = priorexpectations[as.character(mp$Item),]$expectation
wr$PriorExpectation = priorexpectations[as.character(wr$Item),]$expectation

# get smoothed prior probabilities
priorprobs = read.table(file="~/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/12_sinking-marbles-prior15/results/data/smoothed_15marbles_priors_withnames.txt",sep="\t", header=T, quote="")
head(priorprobs)
row.names(priorprobs) = paste(priorprobs$effect,priorprobs$object)
mpriorprobs = melt(priorprobs, id.vars=c("effect", "object"))
head(mpriorprobs)
row.names(mpriorprobs) = paste(mpriorprobs$effect,mpriorprobs$object,mpriorprobs$variable)
mp$PriorProbability = mpriorprobs[paste(as.character(mp$Item)," X",mp$State,sep=""),]$value
mp$AllPriorProbability = priorprobs[paste(as.character(mp$Item)),]$X15
head(mp)

# get empirical state posteriors:
load("/Users/titlis/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/3_sinking-marbles-nullutterance/results/data/r.RData")
head(r)
r$Item = as.factor(paste(r$effect,r$object))
# because posteriors come in 4 bins, make Bin variable for model prediction dataset:
mp$Proportion = as.factor(ifelse(mp$State == 0, "0", ifelse(mp$State == 15, "100", ifelse(mp$State < 8, "1-50", "51-99"))))

agr = aggregate(normresponse ~ Item + quantifier + Proportion,data=r,FUN=mean)
#agr$CILow = aggregate(normresponse ~ Item + quantifier + Proportion,data=r, FUN=ci.low)$normresponse
#agr$CIHigh = aggregate(normresponse ~ Item + quantifier + Proportion,data=r,FUN=ci.high)$normresponse
#agr$YMin = agr$normresponse - agr$CILow
#agr$YMax = agr$normresponse + agr$CIHigh
agr$Quantifier = as.factor(tolower(agr$quantifier))
row.names(agr) = paste(agr$Item, agr$Proportion, agr$Quantifier)
mp$PosteriorProbability_empirical = agr[paste(mp$Item,mp$Proportion,mp$Quantifier),]$normresponse

#plot empirical against predicted distributions for "some"
some = ddply(mp, .(Item, QUD, Alternatives, Quantifier, SpeakerOptimality, PriorExpectation, Proportion, WonkyWorldPrior, PosteriorProbability_empirical), summarise, PosteriorProbability_predicted=sum(PosteriorProbability), PriorProbability_smoothed=sum(PriorProbability))
some= subset(some, Quantifier == "some")
nrow(some)
head(some)
msome = melt(some, measure.vars=c("PosteriorProbability_empirical","PosteriorProbability_predicted","PriorProbability_smoothed"))
msome$ptype = as.factor(ifelse(msome$variable == "PosteriorProbability_empirical", "posterior (empirical)",ifelse(msome$variable == "PosteriorProbability_predicted","posterior (model)", "prior")))
head(msome)
nrow(msome)
summary(msome)

toplot = droplevels(subset(msome, QUD == "how-many" & SpeakerOptimality == 2 & Alternatives == "0_basic"))#"0_basic1_lownum2_extra4_twowords5_threewords"))
nrow(toplot)
toplot$Probability = as.factor(ifelse(toplot$ptype == "prior","prior","posterior"))
toplot$Prop = factor(toplot$Proportion, levels=c("1-50","51-99","100"))
ggplot(toplot, aes(x=Prop, y=value,color=ptype, group=ptype, size=Probability)) +
  geom_point() +
  geom_line() +
  scale_size_discrete(range=c(1,2)) +
  scale_color_manual(values=c("red","blue","black")) +
  facet_wrap(WonkyWorldPrior~Item)
ggsave("graphs/model-empirical-betabinomial-howmany-2-basic.pdf",width=35,height=30)

#plot empirical against predicted expectations for "some"
load("/Users/titlis/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/13_sinking-marbles-priordv-15/results/data/r.RData")
summary(r)
r$Item = as.factor(paste(r$effect, r$object))
agr = aggregate(ProportionResponse ~ Item + quantifier, data=r, FUN=mean)
#agr$CILow = aggregate(ProportionResponse ~ Item + quantifier,data=r, FUN=ci.low)$ProportionResponse
#agr$CIHigh = aggregate(ProportionResponse ~ Item + quantifier,data=r,FUN=ci.high)$ProportionResponse
#agr$YMin = agr$ProportionResponse - agr$CILow
#agr$YMax = agr$ProportionResponse + agr$CIHigh
agr$Quantifier = as.factor(tolower(agr$quantifier))
row.names(agr) = paste(agr$Item, agr$Quantifier)
mp$PosteriorExpectation_empirical = agr[paste(mp$Item,mp$Quantifier),]$ProportionResponse
mp$PriorExpectation_smoothed = mp$PriorExpectation/15

pexpectations = ddply(mp, .(Item, QUD, Alternatives, Quantifier, SpeakerOptimality,PriorExpectation_smoothed, WonkyWorldPrior, PosteriorExpectation_empirical), summarise, PosteriorExpectation_predicted=sum(State*PosteriorProbability)/15)
head(pexpectations)
some = droplevels(subset(pexpectations, Quantifier == "some"))

cors = ddply(some, .(Alternatives, QUD, SpeakerOptimality, WonkyWorldPrior), summarise, r=cor(PosteriorExpectation_predicted, PosteriorExpectation_empirical))
cors = cors[order(cors[,c("r")],decreasing=T),]
head(cors)

ggplot(some, aes(x=PosteriorExpectation_predicted, y=PosteriorExpectation_empirical,color=as.factor(SpeakerOptimality), shape=as.factor(WonkyWorldPrior))) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  #  geom_text(data=cors, aes(label=r)) +
  #scale_size_discrete(range=c(1,2)) +
  #scale_color_manual(values=c("red","blue","black")) +
  facet_grid(QUD~Alternatives)
ggsave("graphs/model-empirical-betabinomial-expectations.pdf",width=30,height=10)

#plot empirical against predicted allstate-prbabilities for "some"
allstate = droplevels(subset(mp, State == 15 & Quantifier == "some"))
cors = ddply(allstate, .(Alternatives, QUD, SpeakerOptimality, WonkyWorldPrior), summarise, r=cor(PosteriorProbability, PosteriorProbability_empirical))
cors = cors[order(cors[,c("r")],decreasing=T),]
head(cors)
# .59 correlation despite being shitty model

ggplot(allstate, aes(x=PosteriorProbability, y=PosteriorProbability_empirical,color=as.factor(WonkyWorldPrior), shape=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth() +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  #  geom_text(data=cors, aes(label=r)) +
  #scale_size_discrete(range=c(1,2)) +
  #scale_color_manual(values=c("red","blue","black")) +
  facet_grid(QUD~Alternatives)
ggsave("graphs/model-empirical-betabinomial-allstateprobs.pdf",width=30,height=10)

#maybe COGSCI plot basis? plot  predicted allstate-prbabilities for "some" as a function of prior allstate-probabilities

ggplot(allstate, aes(x=PriorProbability, y=PosteriorProbability,color=as.factor(WonkyWorldPrior), shape=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth() +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  #  geom_text(data=cors, aes(label=r)) +
  #scale_size_discrete(range=c(1,2)) +
  #scale_color_manual(values=c("red","blue","black")) +
  facet_grid(QUD~Alternatives)
ggsave("graphs/model-betabinomial-allstateprobs.pdf",width=30,height=10)

# get empirical wonkiness posteriors
load("/Users/titlis/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/11_sinking-marbles-normal/results/data/r.RData")
head(r)
nrow(r)
r$Item = as.factor(paste(r$effect,r$object))

t = as.data.frame(prop.table(table(r$Item, r$quantifier, r$response), mar=c(1,2)))
head(t)
colnames(t) = c("Item","Quantifier","NormalMarbles","Proportion")
t[t$Var1=="ate the seeds birds",]
t$Quantifier = tolower(t$Quantifier)
tail(t)
t$Wonky = as.factor(ifelse(t$NormalMarbles == "yes","false","true"))
row.names(t) = paste(t$Item, t$Quantifier, t$Wonky)

wr$PosteriorProbability_empirical = t[paste(wr$Item, wr$Quantifier, wr$Wonky),]$Proportion
head(wr)
wonky = droplevels(subset(wr, Wonky == "true"))

cors = ddply(wonky, .(Alternatives, QUD, SpeakerOptimality, Quantifier, WonkyWorldPrior), summarise, r=cor(PosteriorProbability, PosteriorProbability_empirical))
cors = cors[order(cors[,c("r")],decreasing=T),]
head(cors,15)

ggplot(wonky, aes(x=PosteriorProbability, y=PosteriorProbability_empirical, color=as.factor(WonkyWorldPrior), shape=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth(method="lm") +
  geom_abline(intercept=0,slope=1,color="gray50") +
  scale_x_continuous(limits=c(0,1)) +
  scale_y_continuous(limits=c(0,1)) +
  facet_grid(Quantifier~Alternatives)
ggsave("graphs/model-empirical-betabinomial-wonkiness.pdf", width=30,height=10)

ggplot(wonky, aes(x=PriorExpectation, y=PosteriorProbability, color=as.factor(WonkyWorldPrior), shape=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth() +
  scale_y_continuous(limits=c(0,1)) +
  facet_grid(Quantifier~Alternatives)
ggsave("graphs/model-betabinomial-wonkiness.pdf", width=30,height=10)

save(mp, file="data/mp-betabinomial.RData")
save(wr, file="data/wr-betabinomial.RData")

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

expectations = ddply(mp, .(Item, QUD, Alternatives, Quantifier, SpeakerOptimality, PriorExpectation), summarise, Expectation=sum(PosteriorProbability*State))
head(expectations)
tail(expectations)
expectations$ExpectationProportion = expectations$expectation/15
expectations$QUDOpt = as.factor(paste(expectations$QUD,expectations$SpeakerOptimality))

ggplot(expectations, aes(x=NormAllPrior,y=ExpectationProportion,color=as.factor(SpeakerOptimality),shape=QUD,group=QUDOpt)) +
  geom_point() +
  geom_smooth() +
  facet_grid(SmoothingBW~Alternatives)
ggsave("graphs/marble_expectations.pdf",width=25,height=7)

ggplot(expectations, aes(x=ExpectationProportion,fill=QUD)) +
  geom_histogram(position="dodge") +
  facet_grid(SpeakerOptimality~Alternatives,scales="free_y")
ggsave("graphs/expectation_histograms.pdf",width=12)

subexp = subset(expectations, SpeakerOptimality == 2 & QUD == "how-many" & SmoothingBW == "bwdf")
ggplot(subexp, aes(x=NormAllPrior,y=ExpectationProportion)) +
  geom_point() +
  geom_smooth() +
  facet_wrap(~Alternatives)
ggsave("graphs/expectations_spopt2_qudhowmany_bwdf.pdf",width=12,height=7)

ggplot(subset(subexp,Alternatives=="0_basic"), aes(x=PriorExpectation,y=ExpectationProportion)) +
  geom_point() +
  geom_smooth(method="lm") +
#  geom_abline(intercept=0,slope=1,color="gray70")  +
  scale_x_continuous(name="Prior expectation") +
  scale_y_continuous(name="Posterior expectation")
ggsave("graphs/expectations_bypriorexp_spopt2_qudhowmany_alternativesbasic.pdf",width=12,height=7)
ggsave("graphs/modelpredictions_expectations.pdf")

dd = droplevels(subset(subexp,Alternatives=="0_basic"))
m = lm(ExpectationProportion ~ PriorExpectation, data=dd)
summary(m)

ggplot(subset(mp, Alternatives=="0_basic" & SpeakerOptimality == 2 & QUD == "how-many" & NumState == 15), aes(x=NormAllPrior,y=PosteriorProbability,color=SmoothingBW)) +
  geom_point() +
  #geom_smooth() +
  #geom_abline(intercept=0,slope=1,color="gray70") +
  scale_x_continuous(name="Prior probability of all-state") +
  scale_y_continuous(name="Posterior probability of all-state")
ggsave("graphs/modelpredictions_allstate.pdf")

# get empirical posteriors:
load("/Users/titlis/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/3_sinking-marbles-nullutterance/results/data/r.RData")
head(r)
some = subset(r, quantifier == "Some" & Proportion == 100)
some$Item = as.factor(paste(some$effect, some$object))
head(some$normresponse)
# get model predictions for all-state with basic alts, spopt==2, and qud==how-many
mp_some_allstate = subset(mp, Alternatives=="0_basic" & SpeakerOptimality == 2 & QUD == "how-many" & NumState == 15)
head(mp_some_allstate)
nrow(mp_some_allstate)

agr = aggregate(normresponse ~ Item,data=some,FUN=mean)
agr$CILow = aggregate(normresponse ~ Item,data=some, FUN=ci.low)$normresponse
agr$CIHigh = aggregate(normresponse ~ Item,data=some,FUN=ci.high)$normresponse
agr$YMin = agr$normresponse - agr$CILow
agr$YMax = agr$normresponse + agr$CIHigh
row.names(agr) = agr$Item
head(agr)
mp_some_allstate$EmpiricalPosterior = agr[as.character(mp_some_allstate$Item),]$normresponse
mp_some_allstate$YMin = agr[as.character(mp_some_allstate$Item),]$YMin
mp_some_allstate$YMax = agr[as.character(mp_some_allstate$Item),]$YMax

ggplot(mp_some_allstate, aes(x=PosteriorProbability, y=EmpiricalPosterior)) +
  geom_point() +
  geom_smooth() +
#  geom_errorbar(aes(ymin=YMin,ymax=YMax)) +
  geom_abline(x=0,slope=1,color="gray70") +
  scale_x_continuous(name="Model predicted posterior all-state probability") +
  scale_y_continuous(name="Empirical mean all-state probability") +
  facet_wrap(~SmoothingBW)
ggsave("graphs/model-empirical.pdf")
cor(mp_some_allstate$PosteriorProbability,mp_some_allstate$EmpiricalPosterior) # .51

head(subexp)
# get empirical expectations:
load("/Users/titlis/cogsci/projects/stanford/projects/sinking_marbles/sinking-marbles/experiments/13_sinking-marbles-priordv-15/results/data/r.RData")
head(r)
some = subset(r, quantifier == "Some")
some$Item = as.factor(paste(some$effect, some$object))
rownames(some) = some$Item
# plot subject variability
ggplot(some, aes(x=ProportionResponse)) +
  geom_histogram() +
  facet_wrap(~workerid)
ggsave("graphs/some_subjectvariability.pdf",width=12,height=10)

# mark the people who chose at most 3 middle values to respond to "some" with
some$NoVariance = as.factor(ifelse(some$workerid %in% c("8","24","27","37","52","54","61","72","79","108","113"),1,0))

agr = aggregate(ProportionResponse ~ Item,data=some,FUN=mean)
agr$CILow = aggregate(ProportionResponse ~ Item,data=some, FUN=ci.low)$ProportionResponse
agr$CIHigh = aggregate(ProportionResponse ~ Item,data=some,FUN=ci.high)$ProportionResponse
agr$YMin = agr$ProportionResponse - agr$CILow
agr$YMax = agr$ProportionResponse + agr$CIHigh
row.names(agr) = agr$Item

subexp$EmpiricalMean = agr[as.character(subexp$Item),]$ProportionResponse
subexp$YMin = agr[as.character(subexp$Item),]$YMin
subexp$YMax = agr[as.character(subexp$Item),]$YMax

ggplot(subexp, aes(x=ExpectationProportion, y=EmpiricalMean)) +
  geom_point() +
  geom_errorbar(aes(ymin=YMin,ymax=YMax)) +
  geom_abline(intercept=0,slope=1,color="gray70") +
  geom_smooth(method="lm") +
  #scale_y_continuous(breaks=seq(0,1,0.1)) +
  facet_wrap(~Alternatives)
ggsave("graphs/modelpredictions.pdf",width=12,height=7)

cors = ddply(subexp, .(Alternatives), summarize, Correlation=cor(ExpectationProportion,EmpiricalMean))
cors # best correlation is with basic alternatives (some, none, all -- .6) and basic+many/most/few/afew (-- .59)

# split up by subject vairance on "some" trials
agr = aggregate(ProportionResponse ~ Item + NoVariance,data=some,FUN=mean)
agr$CILow = aggregate(ProportionResponse ~ Item + NoVariance,data=some, FUN=ci.low)$ProportionResponse
agr$CIHigh = aggregate(ProportionResponse ~ Item + NoVariance,data=some,FUN=ci.high)$ProportionResponse
agr$YMin = agr$ProportionResponse - agr$CILow
agr$YMax = agr$ProportionResponse + agr$CIHigh
agrgood = subset(agr, NoVariance == 0)
agrbad = subset(agr, NoVariance == 1)
row.names(agrgood) = agrgood$Item
row.names(agrbad) = agrbad$Item
nrow(agrgood)
nrow(agrbad)
subexp$EmpiricalMean_good = agrgood[as.character(subexp$Item),]$ProportionResponse
subexp$YMin_good = agrgood[as.character(subexp$Item),]$YMin
subexp$YMax_good = agrgood[as.character(subexp$Item),]$YMax

ggplot(subexp, aes(x=ExpectationProportion, y=EmpiricalMean)) +
  geom_point() +
  #geom_errorbar(aes(ymin=YMin,ymax=YMax)) +
  geom_abline(intercept=0,slope=1,color="gray70") +
  geom_smooth(method="lm") +
  #scale_y_continuous(breaks=seq(0,1,0.1)) +
  facet_wrap(~Alternatives)
ggsave("graphs/modelpredictions_good.pdf",width=12,height=7)

subexp$EmpiricalMean_bad = agrbad[as.character(subexp$Item),]$ProportionResponse
subexp$YMin_bad = agrbad[as.character(subexp$Item),]$YMin
subexp$YMax_bad = agrbad[as.character(subexp$Item),]$YMax

ggplot(subexp, aes(x=ExpectationProportion, y=EmpiricalMean_bad)) +
  geom_point() +
  geom_errorbar(aes(ymin=YMin_bad,ymax=YMax_bad)) +
  geom_abline(intercept=0,slope=1,color="gray70") +
  geom_smooth(method="lm") +
  #scale_y_continuous(breaks=seq(0,1,0.1)) +
  facet_wrap(~Alternatives)
ggsave("graphs/modelpredictions_bad.pdf",width=12,height=7)

cors = ddply(subexp, .(Alternatives), summarize, Correlation=cor(ExpectationProportion,EmpiricalMean))
cors # best correlation is with basic alternatives (some, none, all -- .6) and basic+many/most/few/afew (.22)

# plot wonkiness
wonk = unique(mp[,c("PriorExpectation","WonkyProbability","Item","SmoothingBW","Alternatives","SpeakerOptimality","QUD")])
nrow(wonk)
ggplot(wonk, aes(x=PriorExpectation,y=WonkyProbability, color=as.factor(SpeakerOptimality), shape=QUD)) +
  geom_point() +
  geom_smooth() +
  facet_grid(SmoothingBW~Alternatives,scales="free")
ggsave("graphs/wonky_probabilities.pdf",width=20,height=7)

wonk = unique(mp[,c("NormAllPrior","WonkyProbability","Item","SmoothingBW","Alternatives","SpeakerOptimality","QUD")])
nrow(wonk)
ggplot(wonk, aes(x=NormAllPrior,y=WonkyProbability, color=as.factor(SpeakerOptimality), shape=QUD)) +
  geom_point() +
  geom_smooth() +
  facet_grid(SmoothingBW~Alternatives,scales="free")
ggsave("graphs/wonky_probabilities_byallprior.pdf",width=20,height=7)


de_array_limma = function(path, meta_path, out_path, bNormal,bFilter,bPaired){

  pacman::p_load(limma,oligo, genefilter)

  #Read DF
  eset = read.csv(path, check.names = F, header = TRUE, row.names = 1)
  metadata = read.csv(meta_path, check.names = F, header = TRUE, row.names = 1)

  if(bPaired){
    colnames(metadata) = c("sample","condition","patient")

  }else{
    colnames(metadata) = c("sample","condition")

  }

  ##Intersect
  lSample = intersect(metadata$sample, colnames(eset))

  if (bNormal) {
    print("Applyin RMA")
    eset = limma::voom(eset)[[1]]

  }

  if (bFilter){
    eset = eset[rowSums(eset) > 5,]
  }

  #Filter by Sample
  eset = eset[lSample]
  metadata = metadata[metadata$sample %in% lSample,]

  #Design Matrix
  if (bPaired){
  design <- model.matrix(~metadata$patient + metadata$condition)
  } else{
   design <- model.matrix(~metadata$condition)
  }
  #Limma
  fit <- lmFit(eset, design.mat)
  fit<- eBayes(fit)

  #Get DE Table
   if (bPaired){
    res = topTable(fit, coef=5, adjust.method = "BH", sort.by="P", number=Inf)
  } else{
    res = topTable(fit, coef=1, adjust.method = "BH", sort.by="P", number=Inf)
  }
  #Save File
  write.csv(res, out_path)

}

arguments = function(){
  pacman::p_load(optparse)
  option_list = list(
    make_option(c("-f", "--file"), type="character", default=NULL,
                help="dataset file name", metavar="character"),

    make_option(c("-m", "--metadata"), type="character", default=NULL,
                help="Metadata file name", metavar="character"),

    make_option(c("-o", "--out"), type="character", default=NULL,
                help="Out Res file name", metavar="character"),

    make_option(c("-n", "--normalize"), type="logical", default=NULL,
                help="Normalize data. If True the script applies TMM normalziation", metavar="bool"),

    make_option(c("-t", "--filter"), type="logical", default=NULL,
                help="Filter Low Expression", metavar="character")
    make_option(c("-p", "--paired"), type="logical", default=FALSE,
                help="Paired Samples", metavar="character")
  );

  opt_parser = OptionParser(option_list=option_list);
  opt = parse_args(opt_parser);
  return(opt)
}

arg = arguments()

de_array_limma(path = arg$file, meta_path = arg$metadata, out_path = arg$out, bNormal = arg$normalize,  bFilter = arg$filter, , bPaired = arg$paired)


##' estimate missing quantiles
##'
##' @param x a vector of quantiles, with levels as names and some missing (NA) values
##' @return a vector of quantiles, with levels as names and all values
##' @importFrom quantgen quantile_extrapolate
##' @author Sebastian Funk
estimate_quantiles <- function(x) {
  vec <- unlist(x)
  if (any(is.na(x))) {
    tau <- as.numeric(names(vec[!is.na(vec)]))
    x[1, order(as.numeric(names(vec)))] <-
      quantgen::quantile_extrapolate(
                  tau, vec[!is.na(vec)], sort(as.numeric(names(vec))),
                  nonneg = TRUE, round = TRUE)
  }
  return(x)
}


#for matrixizing Solidity files
library(stringr)
solList <- list.files(path = "~/set-protocol-contracts/contracts", pattern = "\\.sol$", recursive = TRUE, full.names = TRUE)
#flatten the Solidity files representing each as a single character vector
flatCode <- lapply(solList, readLines)
#extract all numbers in the code
flatCodeNumbers <- str_extract_all(flatCode,"[0-9]+")
library(ggplot2)
library(ggpubr)
theme_set(theme_pubr())
#total numbers: table(unlist(flatCodeNumbers))
flatCodeTable<-lapply(flatCodeNumbers, table)
z <- do.call(cbind, flatCodeTable[3])
vector <- unlist(flatCodeNumbers)
numbers <- as.numeric(vector)
sortedNumbers <-  sort.int(numbers)
#library(plyr)
countedNumbers <- count(numbers)
#library(dplyr)
str_count(flatCode, "withdraw")
#find all functions with "withdraw" in them
str_count(flatCode, "deposit")
#find all functions with "deposit" in them
str_count(flatCode, "transfer")
#find all functions with "transfer" in them
#str_count(flatCode, "token")
#str_count(flatCode, "set")
sortedNumbers
sortedXyData()
plot(sortedNumbers)
as.data.frame(sortedNumbers)
flattenedCodeDf<-as.data.frame(sortedNumbers)
plot(flattenedCodeDf)
as.numeric(flattenedCodeDf)
as.integer(flattenedCodeDf)
as.vector(flattenedCodeDf)
flattenedCodeVector<-as.vector(flattenedCodeDf)
flattenedCodeVector
as.data.frame(flattenedCodeVector)
flattenedCodeDf<-as.data.frame(flattenedCodeVector)
flattenedCodeDf
summary(flattenedCodeDf)
plot(flattenedCodeDf)
power()
power(flattenedCodeDf)
unlist(flattenedCodeDf)
unlist(flatCodeNumbers)
unlistedNumbers<-unlist(flatCodeNumbers)
plot(unlistedNumbers)
sort(unlistedNumbers)
sortNumbers<-sort(unlistedNumbers)
plot(sortNumbers)
as.data.frame(sortNumbers)
dfNumbers<-as.data.frame(sortNumbers)
plot(dfNumbers)
plot(dfNumbers)
plot(dfNumbers)
savehistory("~/scripts/R/hist.r")


p <- ggplot(ledger_data, aes(date, total)) +
            geom_line() +
            geom_smooth(method="loess") +
            scale_x_date(breaks = "1 month", minor_breaks = "1 week", labels = date_format("%b")) +
            scale_y_continuous(name = commodity) +
            facet_wrap(~year) +
            theme(axis.title.x = element_blank()) # No title on the x-axis

suppressMessages(ggsave(file="line-total-vs-date-facet-year.svg", plot=p, width=12, height=3))


library(tmod)

dn.out = file.path(PROJECT_DIR, "generated_data/fgsea_with_wgcna_modules/")
dir.create(dn.out, showWarnings = F)
dn.fig = file.path(PROJECT_DIR, "figure_generation/SLE-Sig")
dir.create(dn.fig, showWarnings = F)

isv.seq = c(0.5,0.75)

# load FGSEA resuls for BTM modules
mset = "LI"
fn.res = file.path(PROJECT_DIR, "generated_data/fgsea_with_btm_modules",
                   sprintf("BTM.%s_genes_fgsea_results.rds", mset))
res = readRDS(fn.res)

iuse = names(res) %in% paste0("ISV.",isv.seq)
res = res[iuse]

# extract p-values and AUC as effect size
df.pv = data.frame(pathway = res[[1]]$pathway, stringsAsFactors = F)
df.padj = df.pv
for(i in 1:length(res)) {
  tmp = res[[i]] %>% dplyr::select(pathway, pval)
  names(tmp)[2] = names(res)[i]
  df.pv = full_join(df.pv, tmp, by="pathway")
  tmp = res[[i]] %>% dplyr::select(pathway, padj)
  names(tmp)[2] = names(res)[i]
  df.padj = full_join(df.padj, tmp, by="pathway")
}
df.btm = df.pv %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("pathway") %>%
  data.matrix()
df.btm.padj = df.padj %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("pathway") %>%
  data.matrix()

# load FGSEA resuls for WGCNA
fn.res = file.path(PROJECT_DIR, "generated_data", "fgsea_with_wgcna_modules",
                   "WGCNA_genes_fgsea_results.rds")
res = readRDS(fn.res)

# select ISV threshold to plot and filter the loaded results
iuse = names(res) %in% paste0("ISV.",isv.seq)
res = res[iuse]

# extract p-values and AUC as effect size
df.pv = data.frame(pathway = res[[1]]$pathway, stringsAsFactors = F)
df.padj = df.pv
for(i in 1:length(res)) {
  tmp = res[[i]] %>% dplyr::select(pathway, pval)
  names(tmp)[2] = names(res)[i]
  df.pv = full_join(df.pv, tmp, by="pathway")
  tmp = res[[i]] %>% dplyr::select(pathway, padj)
  names(tmp)[2] = names(res)[i]
  df.padj = full_join(df.padj, tmp, by="pathway")
}
df.wgcna = df.pv %>%
  dplyr::filter(pathway %in% "brown") %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("pathway") %>%
  data.matrix()
df.wgcna.padj = df.padj %>%
  dplyr::filter(pathway %in% "brown") %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("pathway") %>%
  data.matrix()

df.comb = rbind(df.wgcna, df.btm)
df.comb.padj = rbind(df.wgcna.padj, df.btm.padj)
df.comb = apply(df.comb, 2, p.adjust, method="BH")

# filter modules
pval.row.in = 0.05 # p threshold for modules to be included
pval.col.in = 0.05 # p threshold for columns to be included
pval.min = 0.1 # p threshold for an enrichment to be shown

i.row.in = apply(df.comb, 1, function(x) any(x <= pval.row.in, na.rm = T))

df.comb = df.comb[i.row.in, ]

rownm = rownames(df.comb)
ibrown = rownm %in% "brown"
data(tmod)
rowttl = tmod$MODULES$Title[match(rownm, tmod$MODULES$ID)]
rownm2 = sprintf("%s (%s)", rownm, rowttl)
rownm2[ibrown] = "WGCNA brown module"

i.hide = df.comb > pval.min
df.comb[i.hide] = NA

df.comb = df.comb %>% as.data.frame() %>%
  mutate(module = rownm2) %>%
  gather("comparison","P.Value", -module)

df.mod = df.comb %>%
  dplyr::filter(comparison == "ISV.0.5", !grepl("TBA", module), !is.na(P.Value))

iord = order(-log10(df.mod$P.Value[-1]))
iord = c(iord+1, 1)
df.mod = df.mod %>%
  mutate(module = factor(module, levels=module[iord]))

p = ggplot(df.mod, aes(module, -log10(P.Value))) +
  geom_bar(stat="identity") +
  geom_hline(yintercept = -log10(c(0.05, 0.01)), col="red", lty=2) +
  geom_text(data=data.frame(y=-log10(c(0.05,0.01)), x=nrow(df.mod), label=c("5% FDR", "1% FDR")),
            aes(x=x,y=y,label=label), col="red", size=2, vjust=-2, hjust=0.5) +
  xlab("") + ylab("adjusted p-value,-log10") +
  coord_flip() +
  theme_bw() +
  theme(
    # panel.border = element_blank(),
    panel.grid.major.y = element_blank(),
    axis.ticks.y = element_blank(),
    plot.margin = margin(5,5,0,0,"mm"))
# Disable clip-area.
gt <- ggplot_gtable(ggplot_build(p))
gt$layout$clip[gt$layout$name == "panel"] <- "off"

library(grid)
library(gridExtra)
grid.draw(gt)

fn.fig = file.path(dn.fig, "brown_BTM_modules_enrichment_CD38.cor.ranked_ISV0.5_barplot")
ggsave(paste0(fn.fig, ".png"), gt, w=5.5, h=3)
ggsave(paste0(fn.fig, ".pdf"), gt, w=5.5, h=3)


#!/usr/bin/Rscript

library(ape)

tree <- read.nexus('mcc.tree')
flows <- read.csv("shipment-flows-origins-on-rows-dests-on-columns.csv", row.names=1)
write.tree(tree, file='mcc.nh')

nms <- tree$tip.label
abs <- sapply(strsplit(nms, '_'), '[[', 1)
absF <- factor(abs)
levs <- levels(absF)

alph <- LETTERS[seq_along(levs)]
levels(absF) <- alph

regDNA <- lapply(absF, as.character)
names(regDNA) <- nms

write.dna(regDNA, file='sim.fasta', format='fasta')
save(regDNA, file='regDNA.RData')

pairs <- expand.grid(to=levs, from=levs)
test <- pairs$from != pairs$to
pairs <- pairs[test,]
pairs <- pairs[, c('from', 'to')]

test <- abs %in% state.abb
pmf <- table(abs[test])
pmf <- pmf/sum(pmf)
pnms <- names(pmf)

usaRow <- colSums(flows[pnms, ] * as.numeric(pmf))
usaCol <- rowSums(t(t(flows[, pnms]) * as.numeric(pmf)))

M <- cbind(flows, 'USA'=usaCol)
M <- rbind(M, 'USA'=c(usaRow, 0))

aggFlow <- function(from, to, sym=TRUE){
    tot <- M[from, to]
    if(sym){
        tot <- tot + M[to, from]
    }
    log10(tot + 1)
}

pairFlows <- mapply(aggFlow, from=pairs$from, to=pairs$to)
Z <- cbind("(Intercept)"=1, pairFlows)
cat(t(Z), file='designMat2')

n <- length(alph)
modFile <- 'init.mod'
cat("ALPHABET:", alph, "\n", file=modFile)
cat("ORDER: 0", "\n", file=modFile, append=TRUE)
cat("SUBST_MOD: UNREST", "\n", file=modFile, append=TRUE)
cat("TRAINING_LNL: 0", "\n", file=modFile, append=TRUE) ## Not sure all of these tags are needed
cat("BACKGROUND:", rep(1, times=n)/n, "\n", file=modFile, append=TRUE)
cat("RATE_MAT:", "\n", file=modFile, append=TRUE)
M <- matrix(1/(n-1), nrow=n, ncol=n)
diag(M) <- -1L
for(i in 1:n){
    cat(M[i,], sep="\t", file=modFile, append=TRUE)
    cat("\n", file=modFile, append=TRUE)
}
cat("TREE:", write.tree(tree), "\n", file=modFile, append=TRUE)


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Fitting generalized additive models to fraction feeding data
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rm(list=ls()) # clears workspace
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
library(plyr)
library(mgcv) # for GAM
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Load saved 'fdat' w/ tWS
load('../Data/SatMeta_FracFDataPhylo.Rdata') # load full post-ToL Frac Feeding dataset
nrow(fdat)
length(unique(fdat$Consumer.identity))
fDat<-fdat # We'll create multiple datasets, to save original to resuse

########################################################################
# Restrict data to those that have information for all desired variables
########################################################################
pdf('../Output/Plots/SatMeta-VarCors.pdf',height=20,width=20)
  pairs(fdat[,c('fF','tWS','Lat','DR','Year','TG','EE','TA','SAlog','BMlog','GT','Eco','FD','RLS','ST')],pch=21,cex=0.5)
dev.off()
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# fF - Fraction feeding
# TSc - Total stomach count
# tWS - Days since winter solstice
# Lat - Latitude
# DR - Diet richness minimum
# DRlog - Diet richness minimum - log10 transformed
# TG - Taxon group
# EE - Endo vs. ectotherm
# TA - Time averaging
# SA - Space averaging (as factor)
# SAlog - Space averaging - (as numeric) log-10 transformed
# BM - Body mass (g)
# BMlog - body mass (g) - log10 transformed
# GT - Generation time (days)
# Eco - Ecosystem
# FD - Feeding data type
# RLS - Rate limiting step
# ST - Space-time replicate
# PS - Population split
# Tmp - Temperature
# ~~~~~~~~~~~~~~~~~~~~~~~~~~
# NOTES:
# Population.split - not much variation, and causes problems in estimation of smoothed variables, so leave out.
# Temperature - unavailable for most surveys, so leave out.
# Diet richness and rate-limiting step might be correlated (so consider leaving latter out)
#   Same with Ecosystem (!?)
# Dropped Space-Time despite being significant in case it sucked up variation from other variables and because there's no expectation that they would differ other than by taxonomic focus.
# Dropped Feeding data type for same reasons
# Dropped Rate-limiting step since could be confounded (correlated) for molluscs with biology
# ~~~~~~~~~~~~~~~~~~~~~~~~~
# Restrict data set to non-NA values for following variables
vars<-vars1<-c('FSc','TSc','tWS','Lat','DR','DRlog','Year','TG','EE','TA','SA','SAlog','Eco')
fdat<-fDat[-which(apply(fdat[,vars],1,function(x) any(is.na(x)))==TRUE),]
nrow(fdat) # => matches count following 'na.omit'
nrow(fdat)/nrow(fDat) # Fraction of used surveys
# Note: Dropping FD and RLS (see below) doesn't alter number of used surveys
nSpp<-length(unique(fdat$Consumer.identity)); nSpp
save(fdat,file='../Data/SatMeta_gamData_FullModel.Rdata')

# Second dataset that drops tWS to include larger dataset
vars<-vars2<-vars1[-3]
fdat<-fDat[-which(apply(fDat[,vars],1,function(x) any(is.na(x)))==TRUE),]
nrow(fdat); nrow(fdat)/nrow(fDat)
nSpp<-length(unique(fdat$Consumer.identity)); nSpp
save(fdat,file='../Data/SatMeta_gamData_SubModel.Rdata')

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Fullmodel data set
load(file='../Data/SatMeta_gamData_FullModel.Rdata')
############################
# Quasi-binomial with logit
############################
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# With Endo/Ecto and Taxon Group
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fit1q_l<-fit<-gam((FSc/TSc)~s(tWS,bs='cc',k=5)+s(Lat,k=6)+s(DRlog,k=4)+s(Year,k=5)+EE+TG+TA+SA+Eco,family=quasibinomial(link='logit'),weights=TSc,data=fdat)

save(fit,file='../Output/GAM/GAM_fit_qBinom_logit_wTaxInf.Rdata')
lapply(concurvity(fit,full=FALSE),round,2) # Variables exhibit very low "co-linearity"
anova(fit) # Variable significance
summary(fit) # Parameter estimates and significance

pdf(paste0('../Output/GAM/GAM_fit_qBinom_logit_wTaxInf.pdf'),height=8,width=10)
  plot(fit,residuals=FALSE,se=1.96,seWithMean=TRUE,shade=TRUE,rug=TRUE,all.terms=TRUE,pch=21,pages=1,scale=-1,too.far=0,pers=TRUE)
  par(mfrow=c(2,2));gam.check(fit)
dev.off()

# Use 'predict' to plot on probability scale

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Without Endo/Ecto and Taxon Group
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fit2q_l<-fit<-gam((FSc/TSc)~s(tWS,bs='cc',k=5)+s(Lat,k=6)+s(DRlog,k=4)+s(Year,k=5)+TA+SA+Eco,family=quasibinomial(link='logit'),weights=TSc,data=fdat)

save(fit,file='../Output/GAM/GAM_fit_qBinom_logit_noTaxInf.Rdata')
lapply(concurvity(fit,full=FALSE),round,2) # Variables exhibit very low "co-linearity"
anova(fit) # Variable significance
summary(fit) # Parameter estimates and significance

pdf(paste0('../Output/GAM/GAM_fit_qBinom_logit_noTaxInf.pdf'),height=8,width=10)
  plot(fit,residuals=FALSE,se=1.96,seWithMean=TRUE,shade=TRUE,rug=TRUE,all.terms=TRUE,pch=21,pages=1,scale=-1,too.far=0,pers=TRUE)
  par(mfrow=c(2,2));gam.check(fit)
dev.off()

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# With log10(Body Mass)
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
fit1q_l<-fit<-gam((FSc/TSc)~s(tWS,bs='cc',k=5)+s(Lat,k=6)+s(DR,k=4)+s(Year,k=5)+BMlog+SAlog+TA+EE+TG+Eco,family=quasibinomial(link='logit'),weights=TSc,data=fdat)

save(fit,file='../Output/GAM/GAM_fit_qBinom_logit_wTaxInf_wBM.Rdata')
lapply(concurvity(fit,full=FALSE),round,2) # Variables exhibit very low "co-linearity"
anova(fit) # Variable significance
summary(fit) # Parameter estimates and significance

pdf(paste0('../Output/GAM/GAM_fit_qBinom_logit_wTaxInf_wBM.pdf'),height=8,width=10)
par(cex.axis=0.8,tcl=-0.1,mgp=c(1.5,0.2,0))
plot(fit,residuals=FALSE,se=1.96,seWithMean=TRUE,shade=TRUE,rug=TRUE,all.terms=TRUE,pch=21,pages=1,scale=-1,too.far=0,pers=TRUE)
par(mfrow=c(2,2));gam.check(fit)
dev.off()


body <- setRefClass('body',
                    fields = c(
                      'mass',
                      'position',
                      'velocity',
                      'acceleration'
                    ),
                    methods = list(
                      initialize = function(m, p, v, a){
                        setMass(m)
                        setPosition(p)
                        setVelocity(v)
                        setAcceleration(a)
                      },
                      setMass = function(m){
                        validateMass(m)
                        mass <<- m
                      },
                      setPosition = function(p){
                        validateVector(p)
                        position <<- p
                      },
                      setVelocity = function(v){
                        validateVector(v)
                        velocity <<- vect(v)
                      },
                      setAcceleration = function(a){
                        validateVector(a)
                        acceleration <<- vect(a)
                      },
                      validateMass = function(m){
                        if(!is.numeric(m)){
                          stop("Mass is not numeric")
                        }
                        if(any(is.nan(m))){
                          stop("Mass is NaN")
                        }
                        if(is.infinite(m)){
                          stop("Mass cannot be infinite")
                        }
                        if(length(m) > 1){
                          stop("Mass must be a single value")
                        }
                      },
                      validateVector = function(v){
                        if(!is.numeric(v)){
                          stop("Input is not numeric")
                        }
                        if(any(is.nan(v))){
                          stop("Input contains NaN")
                        }
                        if(any(is.infinite(v))){
                          stop("Input cannot be infinite")
                        }
                      }
                    ))


library(png)
require(animation)
pngs <- list.files("img/","coin",full = TRUE)
imgs <- lapply(pngs,png::readPNG)

ani.options(interval = 0.5,ani.width = 1800, ani.height = 900)

saveGIF({
    layout(matrix(c(0,0,2,2,2,3,3,3,1,1,2,2,2,3,3,3,1,1,2,2,2,3,3,3,0,0,2,2,2,3,3,3),nrow = 4,byrow = TRUE))
    par(xpd = TRUE)
    for(i in 1:2){
        plot(1,type = "n", axes = FALSE,xlim = c(-0.6,0.6),xlab ="",ylim = c(-0.6,0.6),ylab = "")
        rasterImage(imgs[[i]],-0.5,-0.5,0.5,0.5)
        text(0,0.6,"Throw a coin 10 times",cex = 4)
        text(0,-0.6,"Is it fair?",cex = 4)
        num <- seq(0,40,4)
        plot(1,type = "n", axes = FALSE,xlim = c(-1,42),xlab ="",ylim = c(-0.1,2.2), ylab = "")
        ## sleeping
        for(i in num[2:11]){ rasterImage(imgs[[1]],i - 2,0.1,i + 2,0.3)}
        for(i in num[3:11]){ rasterImage(imgs[[1]],i - 2,0.3,i + 2,0.5)}
        for(i in num[4:11]){ rasterImage(imgs[[1]],i - 2,0.5,i + 2,0.7)}
        for(i in num[5:11]){ rasterImage(imgs[[1]],i - 2,0.7,i + 2,0.9)}
        for(i in num[6:11]){ rasterImage(imgs[[1]],i - 2,0.9,i + 2,1.1)}
        for(i in num[7:11]){ rasterImage(imgs[[1]],i - 2,1.1,i + 2,1.3)}
        for(i in num[8:11]){ rasterImage(imgs[[1]],i - 2,1.3,i + 2,1.5)}
        for(i in num[9:11]){ rasterImage(imgs[[1]],i - 2,1.5,i + 2,1.7)}
        for(i in num[10:11]){ rasterImage(imgs[[1]],i - 2,1.7,i + 2,1.9)}
        for(i in num[11]){ rasterImage(imgs[[1]],i - 2,1.9,i + 2,2.1)}
        mtext(paste(0:10,"\n sleeping \n cats"),line = 0,side = 1, at = num, cex = 0.9)
        ## behind
        for(i in num[1:10]){ rasterImage(imgs[[2]],i - 2,1.9,i + 2,2.1)}
        for(i in num[1:9]){ rasterImage(imgs[[2]],i - 2,1.7,i + 2,1.9)}
        for(i in num[1:8]){ rasterImage(imgs[[2]],i - 2,1.5,i + 2,1.7)}
        for(i in num[1:7]){ rasterImage(imgs[[2]],i - 2,1.3,i + 2,1.5)}
        for(i in num[1:6]){ rasterImage(imgs[[2]],i - 2,1.1,i + 2,1.3)}
        for(i in num[1:5]){ rasterImage(imgs[[2]],i - 2,0.9,i + 2,1.1)}
        for(i in num[1:4]){ rasterImage(imgs[[2]],i - 2,0.7,i + 2,0.9)}
        for(i in num[1:3]){ rasterImage(imgs[[2]],i - 2,0.5,i + 2,0.7)}
        for(i in num[1:2]){ rasterImage(imgs[[2]],i - 2,0.3,i + 2,0.5)}
        for(i in num[1]){ rasterImage(imgs[[2]],i - 2,0.1,i + 2,0.3)}
        mtext(paste(10:0,"\n teasing \n cats"),line = 0,side = 3, at = num, cex = 0.9)
        ## boxes
        rect(xleft = c(-2,38),ybottom = 0.1,xright = c(2,42),ytop = 2.1,border = "red",lwd = 3)
        rect(xleft = c(2.1,34),ybottom = 0.1,xright = c(6,37.9),ytop = 2.1,border = "red",lwd = 2)
        rect(xleft = c(6.1,34),ybottom = 0.1,xright = c(10,30),ytop = 2.1,border = "red",lwd = 1)
        mtext("more \n weird",line = -4,side = 3,at = num[c(1,11)],cex = 1,col = "red")
        mtext("kind of \n weird",line = -4,side = 3,at = num[c(2,10)],cex = 0.8,col = "red")
        mtext("less \n weird",line = -4,side = 3,at = num[c(3,9)],cex = 0.6,col = "red")
        ## line
        arrows(-2,-0.01,42,-0.01,length = 0.1,code = 3,lwd = 2)
        text(20,0.05,"expected",cex = 1.7)
        text(c(8,32),0.05,"weirder",cex = 1.7)
        ## probabilities
        ps <- dbinom(0:10,10,0.5)
        par(xpd = TRUE,mar = c(13.1, 4.1, 4.1, 2.1))
        bar <- barplot(ps,axes = FALSE,border = NA,ylab = "Probability of getting x cats",cex.lab = 1.5)
        barplot(c(ps[1],0,0,0,0,0,0,0,0,0,ps[11]),axes = FALSE,border = c("red",NA,NA,NA,NA,NA,NA,NA,NA,NA,"red"),
                col = NA,lwd = 3,add = TRUE)
        barplot(c(0,ps[2],0,0,0,0,0,0,0,ps[10],0),axes = FALSE,border = c(NA,"red",NA,NA,NA,NA,NA,NA,NA,"red",NA),
                col = NA,lwd = 2,add = TRUE)
        barplot(c(0,0,ps[3],0,0,0,0,0,ps[9],0,0),axes = FALSE,border = c(NA,NA,"red",NA,NA,NA,NA,NA,"red",NA,NA),
                col = NA,lwd = 1,add = TRUE)
        ## line
        arrows(0,-0.01,13,-0.01,length = 0.1,code = 3,lwd = 2)
        text(7.1,-0.007,"expected",cex = 1.7)
        text(c(3.1,10.7),-0.007,"weirder",cex = 1.7)
        ## text
        text(bar[c(1,11)],0.01,"more \n weird",cex = 1.9,col = "red")
        text(bar[c(2,10)],0.02,"kind of \n weird",cex = 1.7,col = "red")
        text(bar[c(3,9)],0.05,"less \n weird",cex = 1.5,col = "red")
        ## axis
        axis(2,las = 2,at = seq(0,0.25,0.05),cex.axis = 1.3,line = -1)
        mtext(paste(0:10,"\n teasing \n or \n sleeping \n cats"),line = 9,side = 1, at = bar, cex = 0.9)
        par(mar = c(5.1, 4.1, 4.1, 2.1))
    }
},movie.name = "binomial_cat.gif")


library(devtools)
devtools::load_all()

library(parallel)
RNGkind("L'Ecuyer-CMRG")
set.seed(999983)

# para setup
s_q <- 2L
ncores <- 16
s_n <- 128L
s_k <- 32L

cv1 <- cv_simulation(ncores, s_n, s_k, s_q,
                maxit = 1e4, thresh = 1e-4,
                s_range = 5, l_range = 10, lambda_l = 5)

save(cv1, file = "cv1.RData")


library(caTools)

# Given a vector of seats, smear across the vector.
visible <- function(x) {
     # It assumes the values in x are 1 for occupied, 0 for empty seat,
     #  and -1 for floor.
     # Smearing stops when it arrives at an unoccupied seat.

     # We start at the edge of the boat, so nothing is visible in this
     # direction:
     smearing <- 0

     # For every seat in the vector:
     for (i in 1:length(x)) {
          if (x[i] == 0) {
               # Empty seat, which blocks our view; so will not smear
               #  anything past it.
               next_smearing <- 0
          } else if (x[i] == 1) {
               # Occupied seat, smear from it (regardless of current
               #  smearing status)
             next_smearing <- 1
          } else {
               # Else it's the floor, which doesn't change our smearing status.
               next_smearing <- smearing
          }

          # Smear a 0 or 1 to the current element.
          x[i] <- smearing

          smearing <- next_smearing
     }
     return(x)
} # visible

# These functions do a column-wise shift up or down on a matrix.
#  Every column is shifted by (col_num-1) rows. So,
#  The first column is not shifted. The second column is shifted
#  up or down by 1 row, the third by 2, and so on. This has the
#  effect of transforming a matrix that represents rectangular
#  relationships between seats into one that represents diagonal
#  relationships.
shift_diag_down <- function(mat) {
     nr <- nrow(mat)
     nc <- ncol(mat)

     for( i in 2:nc ){
          mat[,i] <- c(rep(0,i-1), head(mat[,i], nr+1-i))
     }

     return(mat)
}
shift_diag_up <- function(mat) {
     nr <- nrow(mat)
     nc <- ncol(mat)

     for( i in 2:nc ){
          mat[,i] <- c(tail(mat[,i], nr+1-i), rep(0,i-1))
     }

     return(mat)
}

# These helper functions accomplish what I'm calling "smearing," with a series
#  of gross-looking matrix operations, which boil down to applying the
#  `visible` function row-wise or column-wise. For everything but top-down
#  column-wise, this requires us to apply and then reverse a series of
#  reversing and transposition actions.
smear_right <- function(mat) {
     t(apply(mat, 1, visible)) # Smear any 1s we find all the way RIGHT
}
smear_left <- function(mat) {
     t(apply(apply(apply(mat, 1, rev), 2, visible), 2, rev)) # Smear LEFT
}
smear_up <- function(mat) {
     apply(apply(apply(mat, 2, rev), 2, visible), 2, rev)
}
smear_down <- function(mat) {
     apply(mat, 2, visible) # Smear any 1s we find all the way DOWN
}

###############
# Here begins the program logic,
#  which really should be in a procedure. Oh well.

lines <- scan("input.txt", character(), quote="")
chars <- strsplit(lines, "")
seats <- do.call(rbind, chars)

# The boat's dimensions:
r <- nrow(seats)
c <- ncol(seats)

# Now we're playing a WEIRD game of Life, where adjacency is defined VERY
#  differently. The neighbor count is based on whether there are ANY 1s
#  visible in each cardinal direction, and in diagonal directions,
#  except that our "visibility" may be blocked by an empty seat.
# Then, we use these rules:
#  If its neighbor count is 0, it becomes full (1)
#  If its neighbor count is 5+, it empties     (0)
#  Otherwise, no change.
# Floors are always empty and never change.

# Let's make a MASK out of the floors, in which 0 is not a floor, and
#  1 is a floor.
floor <- matrix(0, r, c)
floor[seats=="."] <- 1

curr_layout <- matrix(0, r, c) # Boats start empty.
prev_layout <- matrix(2, r, c) # Create an invalid "previous" layout

# Now we've got a floor mask (floor), and a matrix of where people are
#  sitting (curr_layout), and a matrix of where people were previously
#  sitting (prev_layout), which is invalid for the first run so we'll always
#  loop at least once.

gif_storage = array(0, c(r,c,100))
steps <- 0

# So, we're off to see the wizard.
while (!all(curr_layout == prev_layout)) {

     steps <- steps+1
     # Ok, we're going to do something similar to part 1 here. For each
     #  cardinal direction, we need to produce a matrix where a 1 means
     #  there's an occupied cell in that direction. I'm going to call this
     #  "smearing" because we're looking for 1s and then smearing them in
     #  some direction until we find an empty seat to mark with it.

     # Annotate the floor with a -1. Our smearing visibility function depends
     #  upon the following key:
     #  Empty seat = 0
     #  Full seat = 1
     #  Floor = -1
     curr_layout[floor == 1] <- -1

     # Cardinal directions.
     cnt_from_u <- smear_down(curr_layout)
     cnt_from_l <- smear_right(curr_layout)
     cnt_from_r <- smear_left(curr_layout)
     cnt_from_d <- smear_up(curr_layout)

     # Now, it's time for the diagonal ones. These are a little complicated.
     #  We solve these by transforming the matrix: we double its vertical size,
     #  then shift each column up or down according to its index. In this
     #  transformed matrix, a left/right or up/down relationship between
     #  entries corresponds to a DIAGONAL relationship in the source matrix.
     # After the transformation, we apply a horizontal smearing function to
     #  the matrix.
     # Then, we reverse the diagonal transformation and trim off the excess
     #  rows.
     #
     # For example, take the following grid, and assume we wish to smear
     #  diagonally down and to the right to achieve the Goal grid:
     #
     # Original     Goal
     # 111          000
     # 000          011
     # 001          001
     #
     # To achieve this, we expand it vertically and shift each column but
     #  the first up according to its position; then we smear to the right,
     #  then reverse the shift:
     #
     # Shifted      Smeared        Unshifted and truncated
     # 001          000            000
     # 010          001            011
     # 101          011            001
     # 000          000
     # 000          000

     cnt_from_lu <- rbind(matrix(0,r,c), curr_layout)
     cnt_from_lu <- shift_diag_down(smear_right(shift_diag_up(cnt_from_lu)))[-1:-r,]

     cnt_from_ru <- rbind(curr_layout, matrix(0,r,c))
     cnt_from_ru <- shift_diag_up(smear_left(shift_diag_down(cnt_from_ru)))[1:r,]

     cnt_from_rd <- rbind(matrix(0,r,c), curr_layout)
     cnt_from_rd <- shift_diag_down(smear_left(shift_diag_up(cnt_from_rd)))[-1:-r,]

     cnt_from_ld <- rbind(curr_layout, matrix(0,r,c))
     cnt_from_ld <- shift_diag_up(smear_right(shift_diag_down(cnt_from_ld)))[1:r,]

     # Sum these up.
     neighbor_cnt <- cnt_from_l + cnt_from_r + cnt_from_u + cnt_from_d +
                    cnt_from_lu + cnt_from_ld + cnt_from_ru + cnt_from_rd

     gif_storage[,,steps] <- neighbor_cnt
     gif_storage[,,steps][floor == 1] <- 0

     # Use our current layout as the starting point for the next one:
     next_layout <- curr_layout

     # Logical subscripting makes this next part easy!
     #  If a seat's neighbor count is 0, it becomes full (1)
     next_layout[neighbor_cnt == 0] <- 1
     #  If its neighbor count is 5+, it empties     (0)
     next_layout[neighbor_cnt >= 5] <- 0
     #  Otherwise, no change.

     # However! Nobody is allowed to sit on the floor. Mask it off.
     next_layout[floor == 1] <- 0
     curr_layout[floor == 1] <- 0 # Clean up our -1s

     prev_layout <- curr_layout
     curr_layout <- next_layout
}

gif_storage <- gif_storage[,,1:steps]/max(gif_storage)
write.gif(gif_storage, "part2.gif", col="jet", delay=10)

# How many butts are in seats once this thing stabilizes?
print(sum(curr_layout==1))


#' @export
#' @title colour.names
#' @description This function returns all of the named colours used by R with their associated R, G and B values
#' @param \code{colour.order} = the sort order.  Valid values are \code{r}, \code{g} and \code{b} (\code{r} is the default)
#' @examples
#' color.code(type='colourblind1',n=2)
#' [1] "#FFFFD8" "#071D58"
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
  colour.names = function( colour.order="r" ) {
    h = t( col2rgb(colors()) )
    rownames(h) = colors()
    if (colour.order=="r") i = order( h[,1], h[,2], h[,3])
    if (colour.order=="g") i = order( h[,2], h[,3], h[,1])
    if (colour.order=="b") i = order( h[,3], h[,1], h[,2])
    return( h[i,] )
  }


#' Filter peaks that do not pass a posterior probability threshold
#'
#' @param model  Chromstar model object
#' @param pp     Posterior probability cutoff
filter_peaks = function(model, pp=1e-4) {
    if (is.list(model) && !grepl("HMM", class(model)))
        lapply(model, chromstaR::changeFDR, fdr=pp)
    else
        chromstaR::changeFDR(model, fdr=pp)
}


library(ape)
library(phytools)
args = commandArgs(trailingOnly=TRUE)

dat <- read.table(args[1], header=T, sep='\t', row.names=1)
d <- dist(dat)
njt <- nj(d)
mid.njt <- midpoint.root(njt)
write.tree(mid.njt, file=args[2])


# This file contains some utility functions.

plot_values <- function(df, title=NA, ylab='Implied Volatility'){
    # Draw a plot that compares the implied volatility
    #
    # Args:
    #     df (data.frame): A dataframe containing the strikes (in column 'K') and either prices or implied volatilities.
    #     title (Optional[string]): The title for the plot and file name. Defaults to NA (no file saved in this case).
    #     ylab (Optional[string]): The label for the y-axis. Defaults to 'Implied Volatility'.

    # Draw the plot
    matplot(df$K, df[names(df)!='K'], main=title, xlab='K', ylab=ylab, type='l', lty=1)
    legend('topright', inset=.05, legend=names(df)[names(df)!='K'], lty=1, col=1:(ncol(df)-1))

    # Save plot to a pdf file in the "results" folder. Replace spaces in file name with underscores
    if (!is.na(title)) dev.copy2pdf(file=paste('results/', gsub(" ", "_", title), '.pdf', sep=''))
}

rowProds <- function(x, N_T){
    # More efficient row product based on r.789695.n4.nabble.com/matrix-row-product-and-cumulative-product-tp841548.html
    #
    # Args:
    #     x (array-like): A matrix or vector or scalar to do a row product over.
    #     N_T (int): The number of time steps not including 0 and T.
    # Returns:
    #     (scalar or vector): The product of each row.

    # If N_T==1, then there is only one malliavin weight per row.  To avoid mistakenly doing a product over the column, return x as is.
    if (N_T == 1) return(x)

    # If there is only one one row, return the product of that row.
    if(is.vector(x)) return(prod(x))

    # Otherwise, return the product of each row in the matrix.
    y <- x[,1]
    for (j in 2:ncol(x)) y <- y*x[,j]
    return(y)
}

feller <- function(params)
    # Args:
    #     params (list): A list containing the parameters to plug into the Heston model
    # Returns:
    #     (boolean): Do the parameters meet the Feller Condition?
    2*params$lambda*params$vbar > params$eta^2


rm(list = setdiff(ls(),c('DATADIR','RESDIR','MAIN_DIR')))

# Run eid_time_table_unrounded.py to create editor-vs-edit timestamp file before executing this script

# Raw Input Files:
# 	'wikichallenge_example_entry.csv'
#	'regdates.tsv'
# Derived Input files:
#	'edit_times_unrounded.csv'

NE = 44514
NT = 22126031
# DATADIR = 'E:\\public\\ICDM11\\wikichallenge_data_all\\'
# RESDIR = 'D:\\ICDM11\\Honourable Mention\\AllFeatureSets\\'
t0 = strptime("2001-01-01 0:0:0", "%Y-%m-%d %H:%M:%S");

# First create EID | FSDT | RegDate Table
X = read.csv(paste(DATADIR,'wikichallenge_example_entry.csv',sep=''),header=T)
RD <- read.csv(paste(DATADIR,'regdates.tsv',sep=''),header=T,sep='\t')
ET = scan(paste(RESDIR,'edit_times_unrounded.csv',sep=''),what='character');
stopifnot(length(ET) == NE, all(dim(X) == (c(NE,2))))

EFR = array(0,c(NE,3))

for (i in 1:NE){
	ix <- which(RD[,1] == X[i,1])
	EFR[i,1] = X[i,1]
	EFR[i,2] <- min(as.numeric(strsplit(ET[i],',',fixed=T)[[1]]))
	EFR[i,3] <- as.numeric(strptime(RD[ix,2],"%Y-%m-%d") - t0)
}

colnames(EFR) = c('user_id','FSDTnum','RegDateNum')
write.csv(EFR,file=paste(RESDIR,'eid_fsdt_regdate_table.csv',sep=''),row.names=F)


# R code
# Luis P. F. Garcia 2018
# Config File

# Packages
require(e1071)
require(kknn)
require(randomForest)
require(rJava)
require(rpart)
require(RWeka)
require(xgboost)
require(parallel)
require(wavelets)

# list of classifiers
CLASSIFIERS = c("Adaboost", "ANN", "C4.5", "CART", "kNN", "RF", "SVM", "XGBoost")

# datasets
FILES = list.files(path="datasets", full.names=TRUE)

# mlp classifier
MLP = make_Weka_classifier("weka/classifiers/functions/MultilayerPerceptron")