REBOL [
    Title: "Binary-conversions"
    Date: 25-Dec-2007/16:27:56+1:00
    Name: none
    Version: none
    File: none
    Home: none
    Author: "David Oliva (commercial)"
    Owner: none
    Rights: none
    Needs: none
    Tabs: none
    Usage: none
    Purpose: none
    Comment: none
    History: none
    Language: none
    Type: none
    Content: none
    Email: oliva.david@seznam.cz
]

either value? 'rebcode [
	int-to-ui8: rebcode [val [integer!] /local tmp result][
		copy result #{00} -1
		and    val 255
		poke result 1 val
		return result
	]

	int-to-ui16: rebcode [val [integer!] /local tmp result][
		copy result #{0000} -1
		set  tmp 0

		set.i  tmp val
		and    tmp 255
		poke result 1 tmp

		set.i  tmp val
		lsr    tmp 8
		and    tmp 255
		poke result 2 tmp

		return result
	]

	int-to-ui32: rebcode [val [integer!] /local tmp result][
		;to-int val
		copy result #{00000000} -1
		set  tmp 0

		set.i  tmp val
		and    tmp 255
		poke result 1 tmp

		set.i  tmp val
		lsr    tmp 8
		and    tmp 255
		poke result 2 tmp

		set.i  tmp val
		lsr    tmp 16
		and    tmp 255
		poke result 3 tmp

		set.i  tmp val
		lsr    tmp 24
		and    tmp 255
		poke result 4 tmp

		return result
	]
	int-to-bits: func[i [number!] bits][skip enbase/base head reverse int-to-ui32 i 2 32 - bits]
][
	if error? try [
		ui32-struct: make struct! [value [integer!]] none
		ui16-struct: make struct! [value [short]] none
		int-to-ui32:   func[i][ui32-struct/value: to integer! i copy third ui32-struct]
		int-to-ui16: func[i][ui16-struct/value: to integer! i copy third ui16-struct]
		int-to-ui8: func[i][ui16-struct/value: to integer! i copy/part third ui16-struct 1]
		int-to-bits: func[i [number!] bits][skip enbase/base head reverse int-to-ui32 i 2 32 - bits]
	][
		;for Rebol versions where the struct! datatype is not available
		int-to-ui32: func[i [number!]][head reverse load rejoin ["#{" to-hex to integer! i "}"]]
		int-to-ui16: func[i [number!]][head reverse load rejoin ["#{" skip mold to-hex to integer! i 5 "}"]]
		int-to-ui8:  func[i [number!]][load rejoin ["#{" skip mold to-hex to integer! i 7 "}"]]
		int-to-bits: func[i [number!] bits][skip enbase/base load rejoin ["#{" to-hex to integer! i "}"] 2 32 - bits]
	]
]

issue-to-binary: func[clr] [debase/base clr 16]
issue-to-decimal: func[i [issue!] /local e d][
	i: head reverse issue-to-binary i
	e: 0 d: 0
	forall i [
		d: d + (i/1 * (2 ** e))
		e: e + 8
	]
	d
]
tuple-to-decimal: func[t [tuple!] /local e d][
	t: head reverse to-binary t
	e: 0 d: 0
	forall t [
		d: d + (t/1 * (2 ** e))
		e: e + 8
	]
	d
]

to-ieee64f: func [
	"Conversion of number to IEEE (Flash byte order)"
	value [number!]
	/local tmp
][
	insert tail tmp: third make struct! [f [double]] reduce [value] copy/part tmp 4
	return remove/part tmp 4
]
from-ieee64f: func [
	"Conversion of number from IEEE (Flash byte order)"
	bin [binary!]
	/local tmp
][
	change third tmp: make struct! [f [double]] [0] remove/part head insert tail bin: copy bin copy/part bin 4 4
	tmp/f
]
from-ieee64: func [
	"Conversion of number from IEEE"
	bin [binary!]
	/local tmp
][
	change third tmp: make struct! [f [double]] [0] bin
	tmp/f
]


#' ms2knots
#'
#' Conversion speed meter per second in knot per second.
#'
#' @param numeric   ms Speed in meter per second [m/s].
#' @return
#'
#'
#' @author  Istituto di Biometeorologia Firenze Italy  Alfonso Crisci \email{a.crisci@@ibimet.cnr.it}
#' @keywords  ms2knots
#'
#' @export
#'
#'
#'
#'

ms2knots<-function(ms)
{
  return(ms * 1.94384);
}


# Goal: To read in a simple data file, and look around it's contents.

# Suppose you have a file "x.data" which looks like this:
#        1997,3.1,4
#        1998,7.2,19
#        1999,1.7,2
#        2000,1.1,13
# To read it in --

A <- read.table("x.data", sep=",",
                col.names=c("year", "my1", "my2"))
nrow(A)                                 # Count the rows in A

summary(A$year)                         # The column "year" in data frame A
                                        # is accessed as A$year

A$newcol <- A$my1 + A$my2               # Makes a new column in A
newvar <- A$my1 - A$my2                 # Makes a new R object "newvar"
A$my1 <- NULL                           # Removes the column "my1"

# You might find these useful, to "look around" a dataset --
str(A)
summary(A)
library(Hmisc)          # This requires that you've installed the Hmisc package
contents(A)
describe(A)

RFrontEndSolution/Tests Repo/Rscripts All (163 files)/r1.r


library(gplots)
library(ggplot2)
library(dplyr)
library(assertthat)
library(sva)

source('analysis.r')
source('metadata.r')

### Get bulk data
bulkTPMData <- read.table('bulk_tpm.txt', header = TRUE)
celltypesToExclude <- getCelltypesToExclude()
bulkExperimentMetadata <- getExperimentMetadata()
bulkExperimentMetadata <- filter(bulkExperimentMetadata,
                                 !Celltype %in% celltypesToExclude,
                                 SampleID %in% names(bulkTPMData))
row.names(bulkExperimentMetadata) <- bulkExperimentMetadata$SampleID
bulkTPMData <- dplyr::select(bulkTPMData,
                             match(bulkExperimentMetadata$SampleID, names(bulkTPMData)))
logBulkTPM <- log2(bulkTPMData + 1)

assert_that(all(bulkExperimentMetadata$SampleID == colnames(bulkTPMData)))

# Remove all genes that don't have logTPM of at least 4 at some point
maxTPM <- apply(logBulkTPM, 1, max)
minTPM <- apply(logBulkTPM, 1, min)
logBulkTPM <- logBulkTPM[(maxTPM >= 2) & ((maxTPM - minTPM) >= 2), ]

# Batch correction
TFExprSet <- ExpressionSet(
  assayData = as.matrix(logBulkTPM),
  phenoData = new(
    "AnnotatedDataFrame",
    data = bulkExperimentMetadata))

phenoData <- pData(TFExprSet)
batch <- phenoData$Batch
modcombat <- model.matrix(~as.factor(Celltype), data = phenoData)
combatExpr <- ComBat(
  dat = exprs(TFExprSet),
  batch = batch,
  mod = modcombat,
  par.prior = FALSE,
  prior.plots = FALSE)
combatExpr[combatExpr < 0] <- 0

logBulkTPM <- combatExpr

### Get scRNA data
# Parameters
minTPM <- 10
minCellsWithMinTPM <- 20

# Read in data
scTPMData <- read.table('sc_tpm.txt',
                        header = TRUE)
scExperimentMetadata <- getScExperimentMetadata()

# Make sure the genes line up
assert_that(all(rownames(scTPMData) == rownames(bulkTPMData)))

# Filter out all genes that don't have at least minTPM TPM in at least minCellsWithMinTPM cells
idxToKeep <- which(rowSums(scTPMData >= minTPM) >= minCellsWithMinTPM)
scTPMData <- scTPMData[idxToKeep, ]
logScTPM <- log2(scTPMData + 1)

### Combine bulk and scRNA data
# Filter out all genes that do not appear in both logScTPM and logBulkTPM
idxToKeep <- which(rownames(logScTPM) %in% rownames(logBulkTPM))
logScTPM <- logScTPM[idxToKeep, ]
idxToKeep <- which(rownames(logBulkTPM) %in% rownames(logScTPM))
logBulkTPM <- logBulkTPM[idxToKeep, ]

# Plot average expression in single cells vs. average expression in bulk
for (celltype in c('D0 H7 hESC', 'D1 APS', 'D1 MPS', 'D2 DLL1+ PXM', 'D3 Somite', 'D5 Dermomyotome', 'D6 Sclerotome')){

  scIdxOfCelltype = (scExperimentMetadata$Celltype == celltype)
  logScTPMCelltype = logScTPM[, scIdxOfCelltype]
  bulkIdxOfCelltype = (bulkExperimentMetadata$Celltype == celltype)
  logBulkTPMCelltype = logBulkTPM[, bulkIdxOfCelltype]

  statsToPlot = data.frame(
    bulkMean = rowMeans(logBulkTPMCelltype),
    scMean = rowMeans(logScTPMCelltype))

  ggplot(statsToPlot, aes_string(x = "bulkMean", y = "scMean")) +
    geom_point(size = 1, alpha = 0.40) +
    theme(text = element_text(size=20)) +
    xlab("Average expression in bulk") +
    ylab("Average expression in single cells")

  print(paste(celltype, cor(statsToPlot)[1,2]))
}


plotday365 <- ggplot(day365, aes(x = Percentage, y = Change.In.Polling.Percentage, size = Searched, fill=Candidate, label=Candidate)) +
  labs(x="Total Percentage of Democrat Vote", y="Change in Percentage")+
  geom_point(shape = 21, show_guide = FALSE) +
  geom_text(size=4)+
  # map z to area and make larger circles
  scale_size_area(max_size = 70) +
  scale_x_continuous(breaks = c(20, 40, 60, 80), limit = c(0, 100),
                     expand = c(0, 0)) +
  scale_y_continuous(breaks = c(-40, -20, 0, 20, 40), limit = c(-60, 60),
                     expand = c(0, 0)) +
  theme_bw() +
  theme(panel.grid.major = element_blank(),
        plot.title = element_text(size = rel(1.5), face = "bold", vjust = 1.5),
        axis.title=element_blank(),
        axis.text.x=element_text(size=10),
        axis.text.y=element_text(size=10))+

ggtitle(paste(as.character(day365$Date[1]), " Democrats"))
ggsave(filename="/Users/andrewlee/Documents/School/CS125/Final Project/DEMPlots/DEMday365.png")


import::here(dplyr, .all=TRUE)
import::here(ggplot2, .all=TRUE)
import::here(tsibble, .all=TRUE)
import::here(distributional, guide_level)
import::here(fabletools, model, report)
import::here(fable, ARIMA)

plot_arima_error = function(fit, index_col) {
    data = bind_rows(
        `Regression residuals` =
            tibble::as_tibble(residuals(fit, type = "regression")),
        `ARIMA residuals` =
            tibble::as_tibble(residuals(fit, type = "innovation")),
        .id = "type"
    )

    data['index'] = data[index_col]

    plt = data %>%
        mutate(
            type = factor(type, levels=c("Regression residuals", "ARIMA residuals"))
        ) %>%
        ggplot(aes(x = index, y = .resid)) +
        geom_line() +
        facet_grid(vars(type))
    return(plt)
}

# Examples
# ------------
# fit = lm(mpg ~ wt + disp + hp + qsec, mtcars)
# summary(fit)
# make_adjr2(predict(fit, mtcars), mtcars$mpg, 4)
make_adjr2 <- function (x, y, k) {
    n = length(x)
    r2 = cor(x, y) ^ 2
    return(1 - (1 - r2) * (n - 1)/(n - k - 1))
}

if (identical(environment(), globalenv())) {
    data = fpp3::us_change

    fit = data %>%
        model(ARIMA(
            Consumption ~ Income + Production + Savings + Unemployment +
            pdq(d=0)
        ))

    fit %>% report()

    plot_arima_error(fit, 'Quarter')

    fit %>% feasts::gg_tsresiduals()

    generics::augment(fit) %>%
        fabletools::features(.innov, feasts::ljung_box, dof = 8, lag = 7)

    calc = fabletools::forecast(fit, data)

    make_adjr2(calc$.mean, data$Consumption, 8)

    calc %>% autoplot(data)

}


require(ggplot2)

lda20 <- data.frame(read.table("rankings_lda20.csv",header=TRUE,sep=",",quote="\""))
lda20$Topic <- as.factor(lda20$Topic)
topic_names <- read.csv("final_lda20_fulltext.txt",header=FALSE,as.is=TRUE)

levels(lda20$Topic) <- topic_names$V1

lda50 <- data.frame(read.table("rankings_lda50.csv",header=TRUE,sep=",",quote="\""))

p50 <- ggplot(lda50,aes(x=Fulltext.Rank,y=Abstract.Rank))
p20 <- ggplot(lda20,aes(x=Fulltext.Rank,y=Abstract.Rank))

axis_labs <- labs(x = "Fulltext paper rank (out of top 50)", y = "Abstract paper rank (out of top 50)")

legend <- function (n) { guides(col=guide_legend(ncol=n)) }

# aggregate scatter plots
scatter_by_topic <- geom_point(aes(colour=factor(Topic)))
p20 + axis_labs + scatter_by_topic + legend(2) + labs(title = "Common papers in the top 50 (k=20)", colour="Topic")
p50 + axis_labs + scatter_by_topic + legend(5) + labs(title = "Common papers in the top 50 (k=50)", colour="Topic")

# by topic
p20 + geom_point() + facet_wrap(~Topic,ncol=5) + axis_labs + theme(strip.text=element_text(size=8)) # MMG this one
p50 + geom_point() + facet_wrap(~Topic,ncol=10,nrow=5) + axis_labs + labs(title="Common papers in the top 50 (k=20), by topic")

y2x <- stat_function(fun = function (x) 2 * x, colour='red')

ggplot(lda20, aes(x=Fulltext.Rank,y=Fulltext.Rank + Abstract.Rank)) +
  geom_point(aes(colour=factor(Topic))) +
  y2x + stat_smooth(method=lm) +
  legend(2) +
  labs(title="Relative rankings (k=20)\n Blue line is best linear fit w/confidence .95; red line is y = 2x (same rankings)", x="Fulltext paper rank (out of 50)", y="Fulltext rank + abstract rank (out of 50)", colour="Topic")


rm(list = ls())
gc()
set.seed(1954)

# Adjust to your settings.
.libPaths("~/Rlib/")
setwd("~/Code/ising_model/scripts/")

library(ggplot2)
library(posterior)
source("tools.r")
source("algorithms.r")
source("algorithms_potts.r")

## Tuning parameters for experiments
# For Potts model with q = 4.
n_states <- 4
# beta_range <- c(0.25, 0.45, 0.5493062, 0.65, 0.85)  # grid graph
# beta_range <- c(1.35, 1.55, 1.647918, 1.75, 1.95)  # complete graph (q = 4)
# beta_range <- c(0.5, 0.8, 1, 1.2, 2)  # gaussian graph
# beta_range <- c(0.25, 0.44, 0.63)
# beta_range <- c(0.5, 1, 1.5) # complete graph for q = 2
beta_range <- rep(1, 14)  # hopfield model

n_beta <- length(beta_range)
# Options for graph types: "complete", "grid", "gaussian", "hopfield"
# m_hopfield parameter is only relevant for Hopfield model
m_hopfield <- c(1, 10, 20, 30, 40, 50, 60, 70, 80, 90, 100, 150, 200, 256)
  # c(1) # c(150, 200) # c(1, 10, 20, 30, 40, 50, 60, 70, 80, 90, 100)
graph_types <- rep("hopfield", n_beta)
anti_corr <- FALSE
graph_sizes <- rep(256, n_beta)
anti_corr <- rep(FALSE, n_beta)

n_iter <- 1e4
n_chains <- 4  # need multiple chains for diagnostics
total_sample <- n_iter * n_chains

# For Gaussian graphs, Wolff and SW cannot be used.
# algo_names <- c("AG_potts", "HB", "Wolff", "SW", "AG_potts_lowrank")  # complete
# algo_names <- c("AG_potts", "HB")  # Gaussian
algo_names <- c("AG_potts", "HB", "AG_potts_lowrank")
# algo_names <- c("AG_potts", "HB", "Wolff", "SW", "AG_potts_lowrank")
n_algorithms <- length(algo_names)

# Number of generated quantities, based on samples
# (for now only do one)
n_gen_quant <- 2
n_gen_sample <- n_iter / 2

burn_in <- 1e3

length_graph_size <- length(graph_sizes)
if (FALSE) {
  beta_range[1] <- 1.60
  length_graph_size <- 1  # only run one loop.
}

for (k in 1:length_graph_size) {
  graph <- graph_types[k]
  n_part <- graph_sizes[k]
  beta <- beta_range[k]
  print(paste0("graph size: ", n_part, ", type: ", graph_types[k],
               ", beta: ", beta_range[k], ", anti_corr: ", anti_corr[k]))

  # Build adjacency graph
  A <- adjacency_graph(n_part, type = graph, anti_corr = anti_corr[k],
                       m_hopfield = m_hopfield[k])

  init <- matrix(NA, nrow = n_chains, ncol = n_part)
  for (c in 1:n_chains) init[c, ] <- sample(1:n_states, n_part, replace = T)

  samples <- array(NA, c(n_iter, n_part, n_algorithms, n_chains))
  time <- rep(NA, n_algorithms)

  print("Doing AG sampling")
  time[1] <- system.time(
    for (c in 1:n_chains) {
      samples[, , 1, c] <- ag_potts_simple(A = A, beta = beta, init = init[c, ],
                                           n_iter = n_iter, n_states = n_states)
    })[3]

  print("Doing HB sampling")
  time[2] <- system.time(
    for (c in 1:n_chains) {
      samples[, , 2, c] <- hb_sampler(A = A, beta = beta, init = init[c, ],
                                      n_iter = n_iter, is_potts = TRUE,
                                      n_states = n_states,
                                      sub_sample = ceiling(n_part / 10))
    })[3]

  if (graph != "gaussian" & graph != "hopfield") {
    print("Doing Wolff sampling")
    time[3] <- system.time(
      for (c in 1:n_chains) {
        samples[, , 3, c] <- wolff_sampler(A = A, beta = beta, init = init[c, ],
                                           n_iter = n_iter, is_potts = TRUE,
                                           n_states = n_states)
      })[3]

    print("Doing SW sampling")
    time[4] <- system.time(
      for (c in 1:n_chains) {
        samples[, , 4, c] <- sw_sampler(A = A, beta = beta, init = init[c, ],
                                        n_iter = n_iter, is_potts = TRUE,
                                        n_states = n_states)
      })[3]
  }

  if (graph == "complete" || graph == "hopfield") {
    print("Doing AG lowrank sampling")
    if (graph == "complete") index = 5
    if (graph == "hopfield") index = 3

    # REMARK: default epsilon = 1e-12 doesn't remove approximatively 0 eigenvalues.
    time[index] <- system.time(
      for (c in 1:n_chains) {
        samples[, , index, c] <- ag_potts_lowrank(A = A, beta = beta, init = init[c, ],
                                              n_states = n_states, n_iter = n_iter,
                                              alpha_modif = 0,
                                              epsilon = 1e-5)
      })[3]
  }

  all_samples <- array(NA, dim = c(total_sample, n_part, n_algorithms))
  for (c in 1:n_chains) {
    iteration_index <- ((c - 1) * n_iter + 1):(c * n_iter)
    all_samples[iteration_index, , ] <- samples[, , , c]
  }

  gen_quant <- array(NA, c(n_gen_sample, n_algorithms, n_chains, n_gen_quant))
  index_start <- n_iter - n_gen_sample + 1
  print("Computing generated quantities.")
  for (j in 1:n_algorithms) {
    for (c in 1:n_chains) {
      for (i in 1:n_gen_sample) {
        gen_quant[i, j, c, 1] <- potts_log_kernel(beta, A,
                                  samples[index_start - 1 + i, , j, c])
        gen_quant[i, j, c, 2] <- gen_quant[i, j, c, 1]
      }
    }
  }

  # Compute the effective samples size and results
  mean <- array(NA, dim = c(n_gen_quant, n_algorithms))
  mcse <- array(NA, dim = c(n_gen_quant, n_algorithms))
  rhat <- array(NA, dim = c(n_gen_quant, n_algorithms))
  ess <- array(NA, dim = c(n_gen_quant, n_algorithms))
  eff <- array(NA, dim = c(n_gen_quant, n_algorithms))

  for (j in 1:n_algorithms) {
    draws_formatted <- as_draws_df(gen_quant[, j, , ])
    names(draws_formatted)[1] <- c("log_kernel")
    summary <- summarize_draws(draws_formatted,
                               measure = c("mean", "mcse_mean", "ess_bulk", "rhat"))
    names(summary) <- c("variable", "mean", "mcse_mean", "ess_bulk", "rhat")
    mean[, j] <- summary$mean
    mcse[, j] <- summary$mcse_mean
    rhat[, j] <- summary$rhat
    ess[, j] <- summary$ess_bulk   # / total_sample * 1e3
    eff[, j] <- ess[, j] / time[j]   # (time[j] * 1e3 / total_sample)
    # Note: returns ESS / time, and corrects for the fact ess is the number
    # of effectively independent samples per 1000 iterations.
  }

  eff_data <- data.frame(cbind(mean, mcse, rhat, ess, eff))
  names(eff_data) <- c(paste0("mean_", algo_names), paste0("mcse_", algo_names),
                       paste0("rhat_", algo_names),
                       paste0("ess_", algo_names), paste0("eff_", algo_names))

  output_name <- paste0("deliv/measurements/potts/", n_part, graph,
                        "_", beta, "_", n_states, "_", m_hopfield[k], "_efficiency")
  write.csv(eff_data, paste0(output_name, ".csv"))
}


library(rcompanion)
library(effsize)

mann_whitney <- function(sample1, sample2, sample1_name, sample2_name) {
    cat("mann_whitney", sample1_name, sample2_name, "\n")
    test = wilcox.test(sample1, sample2)
    print(test)
    d=cohen.d(sample1, sample2, hedges.correction=TRUE)
    print(d)
    return(d)
}

data_cs = read.csv("/data/results/pareto_cs.csv")
data_java = read.csv("/data/results/pareto_java.csv")

mann_whitney(data_cs[["Pareto_category"]], data_java[["Pareto_category"]], "CS", "Java")


# author: Lara Habashy
# date: 2020-11-26

"Pre-processes the default of credit card clients data (from http://archive.ics.uci.edu/ml/datasets/default+of+credit+card+clients).
Writes the training and test data to separate feather files.

Usage: src/pre_process.r --train=<train> --test=<test> --out_dir=<out_dir>

Options:
--train=<train>       Path (including filename) to training data (feather file)
--test=<test>         Path (including filename) to test data (feather file)
--out_dir=<out_dir>   Path to directory where the processed data should be written
" -> doc

library(feather)
library(tidyverse)
library(caret)
library(docopt)
library(arrow)
set.seed(2020)

opt <- docopt(doc)
main <- function(train, test, out_dir){

  # read data and convert default to factor
  training_data <- arrow::read_feather(train)
  test_data <- arrow::read_feather(test)

  dmy_train <- dummyVars( ~ sex + education + marriage, data = training_data)
  dmy_test <- dummyVars( ~ sex + education + marriage, data = test_data)

  one_hot_train <- data.frame(predict(dmy_train, newdata = training_data))
  one_hot_test <- data.frame(predict(dmy_test, newdata = test_data))

  one_hot_train <- lapply(one_hot_train, function(x) as.factor(x))
  one_hot_test <- lapply(one_hot_test, function(x) as.factor(x))

  training_ohe <- cbind(training_data, one_hot_train)
  test_ohe <- cbind(test_data, one_hot_test)

  # scale test data using scale factor
  X_train <- training_ohe %>%
    select(-default)
  X_test <- test_ohe %>%
    select(-default)
  y_train <- training_ohe %>%
    select(default)
  y_test <- test_ohe %>%
    select(default)

  pre_process_scaler <- preProcess(X_train, method = c("center", "scale"))
  X_train_scaled <- predict(pre_process_scaler, X_train)
  X_test_scaled <- predict(pre_process_scaler, X_test)

  training_scaled <- X_train_scaled %>%
    mutate(default = training_data %>% select(default) %>% pull()) %>%
    janitor::clean_names()
  test_scaled <- X_test_scaled %>%
    mutate(default = test_data %>% select(default) %>% pull()) %>%
    janitor::clean_names()

  try({
    dir.create(out_dir)
  })
  saveRDS(pre_process_scaler, file = paste0(out_dir, "/scale_factor.rds"))

  # write training and test data to feather files
  write_feather(training_scaled, paste0(out_dir, "/training.feather"))
  write_feather(test_scaled, paste0(out_dir, "/test.feather"))
}

main(opt[["--train"]], opt[["--test"]], opt[["--out_dir"]])


# Use order function to sort the dataframe column

# Use order() to create positions - list of positions are assigned
positions <-  order(planets_df$diameter)

# Use positions to sort planets_df
planets_df[positions,]


#' @title calcTestIMO
#'
#' @description
#' Determines whether or not an IMO number is in the correct format. IMO numbers
#' should have 7 digits with a check digit at the end.
#'
#' @param IMO IMO number (vector of numericals or strings)
#' @param correctFlag Output indicator for rows where the IMO Number is in the
#' correct format
#' @param incorrectFlag Output indicator for rows where the IMO Number is not in
#' the correct format
#'
#' @return
#' \code{IMO_number_flag}, a factorized vector containing either the value of
#' \code{correctFlag} or \code{incorrectFlag}, depending on the correctness of
#' the IMO number
#'
#' @examples
#' calcTestIMO(IMO=c(899046900,0,9394935))
#'
#' @export

calcTestIMO<-function(IMO,correctFlag="Correct",incorrectFlag="Incorrect"){

#Correct Flag
IMO_NUMBER_flag<-rep(correctFlag,length(IMO))

#Test Right Legth:
IMO<-as.character(IMO)
imolist<-strsplit(unique(IMO), split="")
rightLength<-which(lapply(imolist, length)==7)
imolist<-imolist[rightLength]
rm(rightLength)

#For those of right length, test check digit:

imolist<-lapply(imolist, as.numeric)

checkDigit<-lapply(imolist, function(x) sapply(strsplit(
  as.character((x[1]*7)+(x[2]*6)+(x[3]*5)+(x[4]*4)+(x[5]*3)+(x[6]*2)),
  split=""), tail, 1))

test<-unlist(lapply(checkDigit, as.numeric))==unlist(lapply(imolist, function(x) x[7]))

rm(checkDigit)
imolist<-imolist[which(test==TRUE)]

imolist<- lapply(imolist, function(x)paste(x, collapse=""))

#Incorrect Flag:
IMO_NUMBER_flag[which(!IMO%in%imolist)]<-incorrectFlag

IMO_NUMBER_flag<-as.factor(IMO_NUMBER_flag)
return(IMO_NUMBER_flag)

}


#!/usr/bin/Rscript

# friedman.post.hoc.simple(t(amg2$mean))$ranks
# friedman.post.hoc.simple(t(r$succRatio[1:4,]),minFlag=F)
# friedman.post.hoc.simple(t(r$mean[1:4,]))

#"
#Useful commands:
#source("friedman.r"); r <- friedman.post.hoc.meth.bench("intsp.csv", minFlag=FALSE)
#source("friedman.r"); r <- friedman.post.hoc.meth.bench("strp.csv", minFlag=FALSE)
#sort(r$ranks)
#r$p.value
#r$cmp.matrix
#r$cmp.p.values
#r$cmp.p.values
#r$p.value
#r$cmp.matrix
#"

friedman.post.hoc.meth.bench <- function(fname, minFlag=TRUE)
{
# KK
# reads a csv file of the form: methods x benchmarks
# transforms a table into format expected by friedman.post and calls friedman.post
# set minFlag to true if the variable is minimized, otherwise to false

    options(width=10000) # prevent the wrapping of output
    #options(width=300)

    options(digits=2)
	  b <- read.csv(file=fname, header=TRUE, sep=";", row.names=1, check.names=FALSE)
    b <- b[rownames(b) != "All", ]
    b <- t(b)
	print(summary(b))
	r <- friedman.post.hoc.simple(b,minFlag)
    print(sort(r$ranks))
    r #sort(r.ranks)
}

## Does Friedman from dataframe
friedman.post.hoc.simple <- function(df, minFlag=T,...)  {
	res <- data.frame(var=rep(NA, 0), alg=rep("", 0),
		block=rep("", 0), stringsAsFactors=FALSE, check.names=FALSE)
    i = 1
   print(df)
	for(r in 1:nrow(df))
		for(c in 1:ncol(df))
		{
			res[i,1] = df[r,c]
			res[i,2] = row.names(df)[r]
			res[i,3] = colnames(df)[c]
			i=i+1
		}
	friedman.post.hoc (var ~ alg | block, data=res,minimize=minFlag, ...)
}

friedman.post.hoc <- function(formu, data, minimize=TRUE, p.signif=0.05, post.signif=p.signif, ctrl=NULL, method=NULL)
{
	#
	# formu is a formula of the shape: 	Y ~ X | block   i.e.:  Value ~ Algorithm | Problemf
	# data is a long data.frame with three columns:	[[ Y (numeric), X (factor), block (factor) ]]

	# get the names out of the formula
	formu.names <- all.vars(formu)
	Y.name <- formu.names[1]
	X.name <- formu.names[2]
	block.name <- formu.names[3]

	X <- factor(data[,X.name ])
	Y <- data[,Y.name]
	block <- factor(data[,block.name ])

	n <- nlevels(block)
	k <- nlevels(X)

	if(sum(is.na(Y)) > 0) stop("Function stopped: This function doesn't handle NA's. In case of NA in Y in one of the blocks, then that entire block should be removed.")
	if(k == 2) { warning(paste("'",X.name,"'", "has only two levels. Consider using paired wilcox.test instead of friedman test"))}

	# convert data.frame to matrix
	values <- matrix(nrow=n, ncol=k, dimnames=list(levels(block), levels(X)))
	values[cbind(block, X)] <- Y

	ranks.in.blocks <- t(apply(if (minimize) values else -values, 1, rank))
	rmean <- mean(ranks.in.blocks)
	ranks <- apply(ranks.in.blocks, 2, mean)

	Ff <- n*(k-1)*(n*sum((ranks-rmean)^2))/(sum((ranks.in.blocks-rmean)^2))
	p.value <- pchisq(Ff, k-1, lower.tail=F)

	if (p.value < p.signif)
	{
		if (is.null(ctrl)) {
			# NxN
			#stop("NxN posthoc not implemented yet")
			method <- match.arg(method, c('shaffer', p.adjust.methods))

			#z <- outer(1:k,1:k, function(a,b) abs(ranks[a]-ranks[b]) / sqrt((k*(k+1))/(6*n)))
			rowidx <- unlist(lapply(2:k, function(x) x:k))
			colidx <- rep(1:(k-1), (k-1):1)
			z <- abs(ranks[rowidx] - ranks[colidx]) / sqrt((k*(k+1))/(6*n))
			p <- 2*pnorm(-z)

			cmp.p.values <- switch(method,
					shaffer = {
						ShafferH <- function(k) {
							if (k <= 1) return(0)
							S <- vector("list", k)
							S[[1]] <- 0

							for (i in 2:k) {
								res <- choose(i, 2)
								for (j in (i-1):1) res <- union(res, choose(j, 2) + S[[i-j]])
								S[[i]] <- res
							}
							return(sort(S[[k]]))
						}

						i <- seq_len(length(p))
						o <- order(p)
						ro <- order(o)
						m <- k*(k-1)/2

						val <- matrix(nrow=k,ncol=k)
						#val[lower.tri(val)] <- p.adjust(p) # Homel
						#val[lower.tri(val)] <- pmin(1, cummax( (m - i + 1L) * p[o] ))[ro] # Homel

						H <- ShafferH(k)
						val[lower.tri(val)] <- pmin(1, cummax( unlist(lapply(0:(m-1), function(x) max(H[H<=(m-x)]))) * p[o] ))[ro] # Shaffer's static S1
						val
					},
					{
						val <- matrix(nrow=k,ncol=k)
						val[lower.tri(val)] <- p.adjust(p)
						val
					}
				)

			cmp.p.values[upper.tri(cmp.p.values)] <- t(cmp.p.values)[upper.tri(cmp.p.values)]
			cmp.matrix <- matrix(ifelse(cmp.p.values < p.signif, outer(1:k,1:k, function(a,b) sign(ranks[b]-ranks[a])), 0), nrow=k,ncol=k)
			dimnames(cmp.p.values) <- dimnames(cmp.matrix) <- list(levels(X), levels(X))
		} else {
			# 1xN
			if (is.character(ctrl))
				ctrl <- match(ctrl, names(ranks))
			z <- abs(ranks[ctrl]-ranks[-ctrl]) / sqrt((k*(k+1))/(6*n))
			p <- 2*pnorm(-z)

			if (is.null(method)) method <- 'holm';
			cmp.p.values <- matrix(p.adjust(p, method=method), nrow=1, dimnames=list(names(ranks)[ctrl], names(p)))
			cmp.matrix <- ifelse(cmp.p.values < p.signif, sign(ranks[-ctrl] - ranks[ctrl]), 0)

		}

		return(list(statistic=Ff, parameter=k-1, p.value=p.value, ranks=ranks, cmp.p.values=cmp.p.values, cmp.matrix=cmp.matrix, cmp.method=method))
	} else return(list(statistic=Ff, parameter=k-1, p.value=p.value, ranks=ranks))
}
# friedman.post.hoc(successes ~ method | problem, sstab, minimize=FALSE, ctrl=c('X_A0.2','X_A0.3'))
#
# friedman.post.hoc(successes ~ method | problem, sstab, minimize=FALSE)
#
# friedman.post.hoc(successes ~ method | problem, sstab, minimize=FALSE, ctrl='X_A0.2')
#
# friedman.post.hoc(successes ~ method | problem, sstab, minimize=FALSE, ctrl=c('X_A0.2','X_A0.3'))
#
# friedman.post.hoc(successes ~ method | problem, sstab)

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

args <- commandArgs(trailingOnly = TRUE)
friedman.post.hoc.meth.bench(args[1], minFlag=args[2])

#friedman.post.hoc.meth.bench("tmp.csv", minFlag=FALSE)

#r <- friedman.post.hoc.meth.bench("table-success-small.csv", minFlag=FALSE)
#sort(r$ranks)
#r$p.value
#r$cmp.matrix
#r$cmp.p.values
#source("friedman.r"); r <- friedman.post.hoc.meth.bench("strp.csv", minFlag=FALSE)


library(pvclust)

path = "../../data/"
for (i in list.files(path)) {
  dataset <- read.csv(paste(path,i, sep=""))
  colnames(dataset)[1]="X"
  dataset <- dataset[!duplicated(dataset$X),]
  row.names(dataset) <- dataset$X
  dataset$X <- NULL
  dataset <- as.matrix(dataset)
  len = length(unlist(strsplit(i,"\\_")))
  result <- pvclust(dataset, method.dist=function(x)as.dist(1-cor(x, use="pairwise", method="pearson")), method.hclust="ward.D2", nboot=10000, parallel=TRUE)
  svg(file=paste0("../Report",i,"_Bootstrap_Pearson_unscaled_10000.svg"),width=ifelse(dim(dataset)[2] > 300, 28.5 , ifelse(dim(dataset)[2] > 200, 18.5 , 9.25 )),height=6.5)
  plot(result, cex = 0.4, cex.pv=0.4)
  pvrect(result, alpha=0.95)
  dev.off()
}


library(xgboost)
library(magrittr)
library(dplyr)
library(Matrix)
library(ROCR)
library(MLmetrics)
library(caret)
# read data
finalData <- read.csv(file = "./FinalData.csv", sep = ",", header = TRUE, stringsAsFactors = FALSE)
finalData$target_id <- as.character(finalData$target_id)
# keep away training data with class = NA
classNaData <- finalData[which(is.na(finalData$DE)),]
# clear data - keep only ones with meaningful classes
finalData <- finalData[which(!is.na(finalData$DE)),]
# replace NAs with 0
finalData[is.na(finalData)] <- 0
# convert character columns to factors
finalData[sapply(finalData, is.character)] <- lapply(finalData[sapply(finalData, is.character)],as.factor)
# remove factors with too many levels
finalData <- finalData[, which(lapply(X = finalData, FUN = nlevels) < 50)]
# convert boolean DE column to factor
finalData$DE <- as.factor(finalData$DE)
# class imbalance problem
hist(as.numeric(finalData$DE) - 1, col = 'blue', main = 'Class Imbalance', xlab = 'FALSE = 0 \t TRUE = 1', ylim = c(0,length(finalData$DE)))
# set seed
set.seed(123)
# shuffle data
finalData <- finalData[sample(nrow(finalData)),]
# split to training and testing datasets
rndsplt <- sample(x = 2, size = nrow(finalData), replace = TRUE, prob = c(0.95,0.05))
trainingData <- finalData[rndsplt == 1, ]
testingData <- finalData[rndsplt == 2, ]
# One-Hot Encoding
label <- ifelse(test = finalData[,'DE'] == TRUE, yes = 1, no = 0)
n = nrow(finalData)
train.index = sample(n,floor(0.70*n))
train.data = as.matrix(sapply(finalData[train.index,], as.numeric))
train.label = label[train.index]
test.data = as.matrix(sapply(finalData[-train.index,], as.numeric))
test.label = label[-train.index]
xgb.train = xgb.DMatrix(data=train.data,label=train.label)
xgb.test = xgb.DMatrix(data=test.data,label=test.label)
test.label <- as.factor(ifelse(test = test.label == 1, yes = TRUE, no = FALSE))
# XGBoost Model Parameters
constant_params <- list(booster = 'gbtree',
                        silent = 0,
                        objective = 'binary:logistic',
                        eval_metric = 'error',
                        gamma = 0,
                        early.stop.round = 50
)
# tunable parameters
tunable_params_grid <- expand.grid(eta = (1:6)*0.05,
                                   nrounds = (1:6)*150,
                                   max_depth = c(4:9),
                                   subsample = c(0.6:1),
                                   colsample_bytree = c(0.5,0.8,1)
)
colnames(tunable_params_grid) <- c("eta", "nrounds", "max_depth", "subsample", "colsample_bytree")
# watchlist <- list(train = xgb.train, test = xgb.test)
numModels <- c(400, 300, 250, 200, 150, 100, 75, 50, 25, 12);
currParams <- as.data.frame(matrix(data = NA, nrow = 1, ncol = ncol(tunable_params_grid) + 3))
colnames(currParams) <- c(colnames(tunable_params_grid), "Accuracy", "AUC", "F1score")
bestGenModel <- currParams
# main loop and measure time
for (j in 1:length(numModels)){
  print(paste0("generating up to ", numModels[j], " models..."))
  start.time <- Sys.time()
  for (i in 1:numModels[j]){
    print(paste0("building model ", i))
    currParams[i, ] <- tunable_params_grid[sample(nrow(tunable_params_grid), size = 1), ] #sample random combination and train the trees
    # Train Model
    xgbModel <- xgb.train(params = constant_params,
                          eta = tunable_params_grid[i, 'eta'],
                          nrounds = tunable_params_grid[i, 'nrounds'],
                          max_depth = tunable_params_grid[i, 'max_depth'],
                          subsample = tunable_params_grid[i, 'subsample'],
                          colsample_bytree = tunable_params_grid[i,'colsample_bytree'],
                          data = xgb.train)
                          # watchlist = watchlist)
    # Predict
    xgb.pred <- predict(xgbModel, test.data)
    xgb.pred <- as.data.frame(xgb.pred)
    pred.class <- ifelse(test = xgb.pred > 0.5, yes = TRUE, no = FALSE)
    # Evaluate model
    # Confusion Matrix
    # confusionMatrix(data = as.factor(pred.class), reference = test.label, positive = 'TRUE')
    currParams[i, 'Accuracy'] <- Accuracy(y_pred = pred.class, y_true = test.label)
    pred_obj = prediction(xgb.pred, test.label, label.ordering = c("FALSE", "TRUE"))
    currParams[i, 'AUC'] <- performance(prediction.obj = pred_obj, measure = "auc")@y.values
    currParams[i, 'F1score'] <- F1_Score(y_true = test.label, y_pred = pred.class, positive = 'TRUE')
  }
  # best generated model among numModels[i] models
  bestModel <- currParams[which(currParams$Accuracy == max(currParams$Accuracy)),]
  bestModel <- bestModel[which(bestModel$AUC == max(bestModel$AUC)),]
  bestModel <- bestModel[which(bestModel$F1score == max(bestModel$F1score)),]
  bestGenModel[j,] <- bestModel[1,]
  end.time <- Sys.time()
  time.taken <- end.time - start.time
  saveRDS(object = data.frame(n = numModels[j], time.t = time.taken), file = paste0("./test/xgboost", numModels[j], ".rds"))
}


#' tabulated.baseline
#'
#' tabulate the baseline intensity function.
#'
#' @param case.df A \code{data.frame} of events.
#' @param date.time.field A \code{character} string.
#' @importFrom KernSmooth bkde2D
#' @importFrom KernSmooth dpik
#' @importFrom tidyr expand_grid
tabulated.baseline<-function(case.df, date.time.field = 'week'){
  x.range = ceiling(range(case.df$x))
  y.range = ceiling(range(case.df$y))
  bdw.x = dpik(case.df$x) / 4
  bdw.y = dpik(case.df$y) / 4
  gridsize.x = ceiling(abs(diff(x.range)) / bdw.x)
  gridsize.y = ceiling(abs(diff(y.range)) / bdw.y)
  # gridsize.x = floor(abs(diff(x.range) / mean(diff(case.df$x))) )
  # gridsize.y = floor(abs(diff(y.range) / mean(diff(case.df$y))) )
  cat("Bandwidths are: ", bdw.x, bdw.y, '\n')
  cat("Grid size: ", gridsize.x,'x' ,gridsize.y, '\n')
  kde = bkde2D(case.df[,c('x','y')],
             bandwidth = c(bdw.x, bdw.y),
             gridsize = c(gridsize.x, gridsize.y),
            )

  r = expand.grid(kde$x1, kde$x2)
  r$z = c(unlist(kde$fhat))
  colnames(r) = c('x', 'y', 'z')
  times = min(case.df[,date.time.field], na.rm = T):max(case.df[,date.time.field], na.rm = T)
  r = as.data.frame(expand_grid(r, times))
  colnames(r) = c('x', 'y', 'z', 't')

  Parameters<-tryCatch({
    load(file.path(getwd(), paste0('timefactor_parameters_tmp.Rdata')))
    Parameters
  },
  error = function(e){
    Parameters = cmle(case.df[,date.time.field], n.cycles=20, start=NULL, save.on.dir=TRUE)
    return(Parameters)
  })

  delta2 = diff(head(kde$x2, 2)) * diff(head(kde$x1, 2))
  T = lambda(r$t, Parameters)
  r$z = r$z * T
  C = nrow(case.df) / sum(r$z)
  r$z = C * r$z
  attributes(r)$delta2 = delta2 # = diff(head(baseline.tab[[2]]$x2), 2)) * diff(head(baseline.tab[[2]]$x1), 2))
  # diff(x.range) / gridsize.x * diff(y.range) / gridsize.y
  # attributes(r)$kde2D = kde
  return(r)
}

# radia = sapply(1:5, function(h){sqrt(1 / mean.baseline / pi / h )} )
# radia_and_heights = cbind(1:5, radia)
# n.cylinders = 10000
# radia_and_heights = radia_and_heights[sample(1:nrow(radia_and_heights), n.cylinders, replace=T),]
# rho = radia_and_heights[,2]
# random_radia = runif(n.cylinders, 0, rho)
# theta = runif(n.cylinders, 0, 2* pi)
# idx = sample(1:nrow(observations), n.cylinders, replace=T)
# y0 = observations$y[idx] + sin(theta) * random_radia
# x0 = observations$x[idx] + cos(theta) * random_radia
# t = observations$t[idx] + round(runif(n.cylinders, -radia_and_heights[,1]/2, radia_and_heights[,1]/2))
# t.low = t - round(radia_and_heights[,1]/2)
# t.low = ifelse(t.low>0, t.low, 1)
# t.upp = t.low + round(radia_and_heights[,1]/2)
# t.max = max(observations$t)
# t.upp = ifelse(t.upp <= t.max, t.upp, t.max)
# cylinders = data.frame(x=x0, y=y0, rho=rho, t.low=t.low, t.upp=t.upp, original.x=observations$x[idx],  original.y=observations$y[idx])

# cylinders[,c('n_obs', 'mu',  'p.val')] = t(apply(cylinders, 1, compute_cylinders,
#                                                   observations, tabulated.baseline))
# # cylinders$warning = apply(cylinders, 1, function(x){ifelse((x['p.val'] < 0.05) & (x['n_obs'] > 0), TRUE, FALSE)})
# cylinders$warning = (cylinders['p.val'] < 0.05) & (cylinders['n_obs'] > 0)

ppp=function(case.df, baseline.tab, x0=0){
  idx.case.df = (case.df$week==1) & (case.df$x < x0) & (case.df$y > 5900)
  print(sum(idx.case.df))
  idx.case.df = (case.df$week==1) & (case.df$x >= x0) & (case.df$y > 5900)
  print(sum(idx.case.df))
  print(sum(case.df$week==1))
  print(" ")
  idx = (baseline.tab$x < x0) & (baseline.tab$t == 1) & (baseline.tab$y > 5900)
  print(sum(baseline.tab[idx,]$z))
  idx = (baseline.tab$x >= x0) & (baseline.tab$t == 1) & (baseline.tab$y > 5900)
  print(sum(baseline.tab[idx,]$z))
  print(sum(baseline.tab[baseline.tab$t == 1,]$z))
}

#' tabulated.baseline
#'
#' tabulate the baseline intensity function.
#'
#' @param x integer. number of cylinder samples.
#' @param postcode.field numeric.
#' @importFrom KernSmooth dpik
#' @importFrom tidyr expand_grid
tabulated.baseline2<-function(case.df, date.time.field = 'week'){
  x.range = range(case.df$x)
  x.range = c(floor(x.range[1]), ceiling(x.range[2]))
  y.range = range(case.df$y)
  y.range = c(floor(y.range[1]), ceiling(y.range[2]))
  bdw.x = dpik(case.df$x)
  bdw.y = dpik(case.df$y)
  gridsize.x = ceiling(abs(diff(x.range)) / bdw.x)
  gridsize.y = ceiling(abs(diff(y.range)) / bdw.y)
  x.bin <- seq(x.range[1], x.range[2], length=gridsize.x+1)
  y.bin <- seq(y.range[1], y.range[2], length=gridsize.y+1)

  # gridsize.x = floor(abs(diff(x.range) / mean(diff(case.df$x))) )
  # gridsize.y = floor(abs(diff(y.range) / mean(diff(case.df$y))) )
  cat("Bandwidths are: ", bdw.x, bdw.y, '\n')
  cat("Grid size: ", gridsize.x,'x' ,gridsize.y, '\n')

  freq = as.data.frame(table(findInterval(case.df$x, x.bin),findInterval(case.df$y, y.bin)))
  freq[,1] = as.numeric(freq[,1])
  freq[,2] = as.numeric(freq[,2])

  x.bin.centers = x.bin[-1] - diff(x.bin[1:2]) / 2
  y.bin.centers = y.bin[-1] - diff(y.bin[1:2]) / 2

  freq2D = matrix(data=0, ncol=gridsize.x, nrow=gridsize.y)
  freq2D[cbind(freq[,2], freq[,1])]=freq[,3]

  r1 = expand.grid(y.bin.centers, x.bin.centers)
  r1$z = c(unlist(freq2D))
  colnames(r1) = c('y', 'x', 'z')
  times = min(case.df[,date.time.field], na.rm = T):max(case.df[,date.time.field], na.rm = T)
  r1 = as.data.frame(expand_grid(r1, times))
  colnames(r1) = c('y', 'x', 'z', 't')

  Parameters<-tryCatch({
    load(file.path(getwd(), paste0('timefactor_parameters_tmp.Rdata')))
    Parameters
  },
  error = function(e){
    Parameters = cmle(case.df[,date.time.field], n.cycles=20, start=NULL, save.on.dir=TRUE)
    return(Parameters)
  })

  T = lambda(r1$t, Parameters)
  r1$z = r1$z * T
  C = nrow(case.df) / sum(r1$z)
  r1$z = C * r1$z

  return(list(r=r,r1=r1))
}


# Process a QGIS-exported CSV file: sanity checks, hardening, purity determination
library(sp)

filename = "../data/samples.csv"
samples = read.csv(filename)
coordinates(samples) = ~X+Y
row.names(samples) = samples$pkuid
samples$pkuid = NULL

# Sanity check: all should add up to 100%
# "named integer(0)" is good and expected
which(rowSums(samples@data) != 100)

# Add "hardened" column: dominant land cover class
samples$dominant = factor(apply(samples@data, 1, which.max), labels = colnames(samples@data)[1:9], ordered = FALSE)
# Add a column that identifies endmembers
samples$pure = apply(samples@data[,1:9], 1, max) >= 95

# Statistics!
# "dominant" should be >=50 for all
table(samples$dominant)
# Should be >= 15 for all
table(samples[samples$pure,]$dominant)
# Progress indicator!
table(samples$dominant)/50*100
table(samples[samples$pure,]$dominant)/15*100
# What to work on next!
which.min(table(samples$dominant))
which.min(table(samples[samples$pure,]$dominant))
# How many are left!
50-table(samples$dominant)
15-table(samples[samples$pure,]$dominant)


#!/usr/bin/env Rscript

# ypar
# reference for main analysis: https://github.com/chr1swallace/coloc

args = commandArgs(trailingOnly=TRUE)
print(args)

library(dplyr)
library(data.table)
library(coloc)

Var.data <- function(f, N) {
  1 / (2 * N * f * (1 - f))
}

Var.data.cc <- function(f, N, s) {
  1 / (2 * N * f * (1 - f) * s * (1 - s))
}

logsum <- function(x) {
  my.max <- max(x)                              ##take out the maximum value in log form
  my.res <- my.max + log(sum(exp(x - my.max )))
  return(my.res)
}

logdiff <- function(x,y) {
  my.max <- max(x,y)                              ##take out the maximum value in log form
  my.res <- my.max + log(exp(x - my.max ) - exp(y-my.max))
  return(my.res)
}

approx.bf.p <- function(p,f,type, N, s, suffix=NULL) {
  if(type=="quant") {
    sd.prior <- 0.15
    V <- Var.data(f, N)
  } else {
    sd.prior <- 0.2
    V <- Var.data.cc(f, N, s)
  }
  z <- qnorm(0.5 * p, lower.tail = FALSE)
  ## Shrinkage factor: ratio of the prior variance to the total variance
  r <- sd.prior^2 / (sd.prior^2 + V)
  ## Approximate BF  # I want ln scale to compare in log natural scale with LR diff
  lABF = 0.5 * (log(1-r) + (r * z^2))
  ret <- data.frame(V,z,r,lABF)
  if(!is.null(suffix))
    colnames(ret) <- paste(colnames(ret), suffix, sep=".")
  return(ret)
}

approx.bf.estimates <- function (z, V, type, suffix=NULL, sdY=1) {
  sd.prior <- if (type == "quant") { 0.15*sdY } else { 0.2 }
  r <- sd.prior^2/(sd.prior^2 + V)
  lABF = 0.5 * (log(1 - r) + (r * z^2))
  ret <- data.frame(V, z, r, lABF)
  if(!is.null(suffix))
    colnames(ret) <- paste(colnames(ret), suffix, sep = ".")
  return(ret)
}

combine.abf <- function(l1, l2, p1, p2, p12) {
  lsum <- l1 + l2
  lH0.abf <- 0
  lH1.abf <- log(p1) + logsum(l1)
  lH2.abf <- log(p2) + logsum(l2)
  lH3.abf <- log(p1) + log(p2) + logdiff(logsum(l1) + logsum(l2), logsum(lsum))
  lH4.abf <- log(p12) + logsum(lsum)

  all.abf <- c(lH0.abf, lH1.abf, lH2.abf, lH3.abf, lH4.abf)
  my.denom.log.abf <- logsum(all.abf)
  pp.abf <- exp(all.abf - my.denom.log.abf)
  names(pp.abf) <- paste("PP.H", (1:length(pp.abf)) - 1, ".abf", sep = "")
  print(signif(pp.abf,3))
  print(paste("PP abf for shared variant: ", signif(pp.abf["PP.H4.abf"],3)*100 , '%', sep=''))
  return(pp.abf)
}

sdY.est <- function(vbeta, maf, n) {
    warning("estimating sdY from maf and varbeta, please directly supply sdY if known")
    oneover <- 1/vbeta
    nvx <- 2 * n * maf * (1-maf)
    m <- lm(nvx ~ oneover - 1)
    cf <- coef(m)[['oneover']]
    if(cf < 0)
        stop("estimated sdY is negative - this can happen with small datasets, or those with errors.  A reasonable estimate of sdY is required to continue.")
    return(sqrt(cf))
}

process.dataset <- function(d, suffix) {
  #message('Processing dataset')

  nd <- names(d)
  if (! 'type' %in% nd)
    stop("dataset ",suffix,": ",'The variable type must be set, otherwise the Bayes factors cannot be computed')

  if(!(d$type %in% c("quant","cc")))
      stop("dataset ",suffix,": ","type must be quant or cc")

  if(d$type=="cc") {
      if(! "s" %in% nd)
          stop("dataset ",suffix,": ","please give s, proportion of samples who are cases")
      if("pvalues" %in% nd && !( "MAF" %in% nd))
          stop("dataset ",suffix,": ","please give MAF if using p values")
      if(d$s<=0 || d$s>=1)
          stop("dataset ",suffix,": ","s must be between 0 and 1")
  }

  if(d$type=="quant") {
      if(!("sdY" %in% nd || ("MAF" %in% nd && "N" %in% nd )))
          stop("dataset ",suffix,": ","must give sdY for type quant, or, if sdY unknown, MAF and N so it can be estimated")
  }

  if("beta" %in% nd && "varbeta" %in% nd) {  ## use beta/varbeta.  sdY should be estimated by now for quant
    if(length(d$beta) != length(d$varbeta))
      stop("dataset ",suffix,": ","Length of the beta vectors and variance vectors must match")
    if(!("snp" %in% nd))
      d$snp <- sprintf("SNP.%s",1:length(d$beta))
    if(length(d$snp) != length(d$beta))
      stop("dataset ",suffix,": ","Length of snp names and beta vectors must match")

    if(d$type=="quant" && !('sdY' %in% nd))
          d$sdY <- sdY.est(d$varbeta, d$MAF, d$N)
   df <- approx.bf.estimates(z=d$beta/sqrt(d$varbeta),
                              V=d$varbeta, type=d$type, suffix=suffix, sdY=d$sdY)
    df$snp <- as.character(d$snp)
    return(df)
  }

  if("pvalues" %in% nd & "MAF" %in% nd & "N" %in% nd) { ## no beta/varbeta: use p value / MAF approximation
    if (length(d$pvalues) != length(d$MAF))
      stop('Length of the P-value vectors and MAF vector must match')
    if(!("snp" %in% nd))
      d$snp <- sprintf("SNP.%s",1:length(d$pvalues))
    df <- data.frame(pvalues = d$pvalues,
                     MAF = d$MAF,
                     snp=as.character(d$snp))
    colnames(df)[-3] <- paste(colnames(df)[-3], suffix, sep=".")
    df <- subset(df, df$MAF>0 & df$pvalues>0) # all p values and MAF > 0
    abf <- approx.bf.p(p=df$pvalues, f=df$MAF, type=d$type, N=d$N, s=d$s, suffix=suffix)
    df <- cbind(df, abf)
    return(df)
  }

  stop("Must give, as a minimum, one of:\n(beta, varbeta, type, sdY)\n(beta, varbeta, type, MAF)\n(pvalues, MAF, N, type)")
}

coloc.abf <- function(dataset1, dataset2, MAF=NULL,
                      p1=1e-4, p2=1e-4, p12=1e-5) {

  if(!is.list(dataset1) || !is.list(dataset2))
    stop("dataset1 and dataset2 must be lists.")
  if(!("MAF" %in% names(dataset1)) & !is.null(MAF))
    dataset1$MAF <- MAF
  if(!("MAF" %in% names(dataset2)) & !is.null(MAF))
    dataset2$MAF <- MAF

  df1 <- process.dataset(d=dataset1, suffix="df1")
  df2 <- process.dataset(d=dataset2, suffix="df2")
  # the na.omit is the fix here:
  merged.df <- na.omit(merge(df1,df2))

   if(!nrow(merged.df))
    stop("dataset1 and dataset2 should contain the same snps in the same order, or should contain snp names through which the common snps can be identified")

  merged.df$internal.sum.lABF <- with(merged.df, lABF.df1 + lABF.df2)
  ## add SNP.PP.H4 - post prob that each SNP is THE causal variant for a shared signal
  my.denom.log.abf <- logsum(merged.df$internal.sum.lABF)
  merged.df$SNP.PP.H4 <- exp(merged.df$internal.sum.lABF - my.denom.log.abf)

  pp.abf <- combine.abf(merged.df$lABF.df1, merged.df$lABF.df2, p1, p2, p12)
  common.snps <- nrow(merged.df)
  results <- c(nsnps=common.snps, pp.abf)

  output<-list(summary=results, results=merged.df)
  return(output)
}

############################## above here are general coloc package functions

# example file
# due to constraints in the computing environment,
# individual genes were tested first before parallelization

# head -2 input_per_gene/Whole_Blood/Coronary_Artery_Disease/ENSG00000000457.13_for_coloc.txt
# gene_id	eqtl_variant_id	tss_distance	eqtl_ma_samples	eqtl_ma_count	eqtl_maf	eqtl_pval_nominal	eqtl_slope	eqtl_slope_se	tissue	eqtl_sample_size	gwas_variant_id	chromosome	position	eqtl_effect_allele	eqtl_non_effect_allele	current_build	frequency	gwas_sample_size	gwas_zscore	gwas_pvalue	gwas_effect_size	gwas_standard_error	gwas_imputation_status	gwas_n_cases	trait
# ENSG00000000457.13	chr1_168894411_A_T_b38	-999856	30	30	0.0223881	0.4447680000000001	0.0509097	0.0665773	Whole_Blood	670	rs114383479	chr1	168894411	T	A	hg38	0.023088023088023088	184305	1.3586797714233398	0.17424808484624	NA	NA	imputed	60801	Coronary_Artery_Disease

# this script assumes input files contains per-gene or per-ldblock variants only

# inputfile = 'ENSG00000000457.13_for_coloc.txt'
inputfile = args[1]
tissueid = args[2]
traitid = args[3]

workdir = '/project/chrbrolab/gtex/coloc_v8/'
# inputdir = paste(workdir, 'input_per_gene/', sep='')
outputdir = paste(workdir, 'output_per_gene_eur/', tissueid, '/', traitid, '/', sep='')
# file names are changed to reflect new pheno labels
priorsfile = 'ypark_enloc_enrichment_and_prior_estimation_results.txt'

geneid = unlist(strsplit(inputfile, '_for_'))[1]

print(c(tissueid, traitid, geneid))

# before organizing
# inputdir = paste(workdir, 'input_per_gene/', sep='')
# after organizing
inputdir = paste(workdir, 'input_per_gene_eur/', tissueid, '/', traitid, '/', sep='')
outfile = paste(outputdir, geneid, '_coloc_output_file.txt', sep='')
output = c()

inputdata = tbl_df(fread(paste(inputdir, inputfile, sep='')))
inputdata = inputdata[inputdata$frequency > 0,]
inputdata$gwas_varbeta = 1

inputdata = inputdata %>% filter(complete.cases(gwas_zscore)) %>% mutate(max_gwas_zscore = max(abs(gwas_zscore)))
inputdata = inputdata %>% arrange(desc(abs(gwas_zscore)))

priors = tbl_df(fread(paste(workdir, priorsfile, sep='')))
priorsused = priors %>% filter(trait == traitid & tissue == tissueid)
p1used = priorsused$p1_trait_prior
p2used = priorsused$p2_tissue_prior
p12used = priorsused$p12

# eqtlinput = list(beta = inputdata$eqtl_slope, varbeta = (inputdata$eqtl_slope_se)**2, N = inputdata$eqtl_sample_size, type = 'quant', snp = inputdata$eqtl_variant_id, MAF = inputdata$eqtl_maf)
eqtlinput = list(pvalues = inputdata$eqtl_pval_nominal, N = inputdata$eqtl_sample_size, type = 'quant', snp = inputdata$eqtl_variant_id, MAF = inputdata$frequency)

caseproportion = inputdata$gwas_n_cases/inputdata$gwas_sample_size
datatype = ifelse(is.na(caseproportion[1]), 'quant', 'cc')

if(datatype == 'quant') {
  gwasinput = list(beta = inputdata$gwas_zscore, varbeta = inputdata$gwas_varbeta, N = inputdata$gwas_sample_size, type = datatype, snp = inputdata$eqtl_variant_id, MAF = inputdata$frequency)
} else {
  gwasinput = list(beta = inputdata$gwas_zscore, varbeta = inputdata$gwas_varbeta, N = inputdata$gwas_sample_size, type = datatype, snp = inputdata$eqtl_variant_id, MAF = inputdata$frequency, s = caseproportion)
}

# if(datatype == 'quant') {
#   gwasinput = list(pvalues = inputdata$gwas_pvalue, N = inputdata$gwas_sample_size, type = datatype, snp = inputdata$eqtl_variant_id, MAF = inputdata$frequency)
# } else {
#   gwasinput = list(pvalues = inputdata$gwas_pvalue, N = inputdata$gwas_sample_size, type = datatype, snp = inputdata$eqtl_variant_id, MAF = inputdata$frequency, s = caseproportion)
# }

# priors were stored in a table like this:
# tissue	trait	p1_trait_prior	p2_tissue_prior	p12	pm1	pm2	enloc_enrich_intercept_effect(inteffect)	inteffect_95ci_lower	inteffect_95ci_upper	enloc_enrich_log_odds_ratio_effect(logor)	logor_95ci_lower	logor_95ci_upper
# Adipose_Subcutaneous	Adiponectin	7.31680E-06	3.32503E-03	3.05385E-08	7.34734E-06	3.32506E-03	-11.822	-11.849	-11.795	0.224	-2.384	2.832
# Adipose_Subcutaneous	Alzheimers_Disease	1.32258E-05	3.32490E-03	1.60605E-07	1.33864E-05	3.32506E-03	-11.230	-11.409	-11.052	1.292	-2.956	5.540

runcoloc = coloc.abf(gwasinput, eqtlinput, p1=p1used, p2=p2used, p12=p12used)
output = rbind(output, c(unlist(inputdata[1,]), runcoloc$summary))
output = as.data.table(output)

output = mutate(output, PP.H1.abf = ifelse(PP.H0.abf == 1, 0, PP.H1.abf))
output = mutate(output, PP.H2.abf = ifelse(PP.H0.abf == 1, 0, PP.H2.abf))
output = mutate(output, PP.H3.abf = ifelse(PP.H0.abf == 1, 0, PP.H3.abf))
output = mutate(output, PP.H4.abf = ifelse(PP.H0.abf == 1, 0, PP.H4.abf))

outputdata = tbl_df(as.data.frame(output)) %>% mutate(PP.H4.abf = as.numeric(as.character(PP.H4.abf))) %>% arrange(desc(PP.H4.abf))
write.table(outputdata, file=outfile, quote=F, col.names=T, row.names=F, sep='\t')


v <- c(7,12,28,3,41)
t <- c(14,7,6,19,3)
plot(v,type = "o",col = "red", xlab = "Month", ylab = "Rainfall (mm)",
   main = "Rainfall Chart")
lines(t, type = "o", col = "blue")


require(ggplot2)
require(gridExtra)
require(reshape2)

source('fmm_multivariate_conditional_collapsed.r')

dimension = 1

config = list(
    k = 4
  , m = dimension
  , a = 1
  , l = rep(0, dimension)
  , b = dimension
  , w = diag(1, dimension)
  , n = 50
  )

set.seed(222)

d = list(
    as.matrix(replicate(100, rnorm(config$m, 5)))
  , as.matrix(replicate(100, rnorm(config$m, -5)))
  , as.matrix(replicate(100, rnorm(config$m, 10)))
  , as.matrix(replicate(200, rnorm(config$m))))

dn = lapply(d, function(j) { data.frame(x = j) })

m  = melt(dn, id.vars = c('x'))

set.seed(990909)

params = inverse_model(
    config$n, config$k, as.matrix(m[, c('x')])
  , config$a
  , config$l
  , config$b, config$w
  )

early = data.frame(x = m$x, variable = params$z[1,])
mid   = data.frame(x = m$x, variable = params$z[round(config$n * 1 / 2),])
late  = data.frame(x = m$x, variable = params$z[config$n - 1,])

p_early =
  ggplot(early, aes(x, colour = factor(variable), fill = factor(variable))) +
    geom_histogram(alpha = 0.5)

p_mid =
  ggplot(mid, aes(x, colour = factor(variable), fill = factor(variable))) +
    geom_histogram(alpha = 0.5)

p_late =
  ggplot(late, aes(x, colour = factor(variable), fill = factor(variable))) +
    geom_histogram(alpha = 0.5)

inferred_plots = grid.arrange(p_early, p_mid, p_late, ncol = 3)


#' Francis effective sample size plots by fleet
#'
#' Compares input ESS with Francis (2011) estimates. Based on Francis 2011 CJFAS 68: 1124-1138.
#' @param asap name of the variable that read in the asap.rdat file
#' @param a1 list file produced by grab.aux.files function
#' @param fleet.names names of fleets
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param is.catch.flag true means only catch plotted, false also plots discards (defaults to TRUE)
#' @export

PlotFrancisFleet<-function(asap,a1,fleet.names,save.plots,od,plotf,is.catch.flag=T) {
  par(mfrow=c(2,1), mar=c(4,4,2,4) )

  years <- seq(asap$parms$styr, asap$parms$endyr)
  nyrs <- length(years)

  Neff.init <- asap$fleet.catch.Neff.init
  Neff.est <- asap$fleet.catch.Neff.est
  my.title <- "Catch "
  my.save <- "Catch."
  if (!is.catch.flag){
    Neff.init <- asap$fleet.discard.Neff.init
    Neff.est <- asap$fleet.discard.Neff.est
    my.title <- "Discard "
    my.save <- "Discard."
  }

  for (i in 1:asap$parms$nfleets) {
    ages <- seq(asap$fleet.sel.start.age[i], asap$fleet.sel.end.age[i])

    t.obs<-   as.data.frame(asap$catch.comp.mats [4*(i-1)+1] )
    t.pred<-   as.data.frame(asap$catch.comp.mats [4*(i-1)+2] )
    catch.yrs <- which(asap$fleet.catch.Neff.init[i,]>0)
    scale.Neff= max(asap$fleet.catch.Neff.init[i,])/10
    if (!is.catch.flag){
      scale.Neff= max(asap$fleet.discard.Neff.init[i,])/10
      catch.yrs = which(asap$fleet.discard.Neff.init[i,]>0)
      t.obs <- as.data.frame(asap$catch.comp.mats[4*(i-1)+3] )
      t.pred <- as.data.frame(asap$catch.comp.mats[4*(i-1)+4] )
    }

    t.res <- matrix(NA, nrow=0, ncol=6)
    ESS1 <- Neff.init[i,]
    ESS <- ESS1[ESS1>0]
    num.acomp.yrs <- length(catch.yrs)

    if (length(catch.yrs)>0){
      for (j in catch.yrs) {
        obsf <- CalcFreqMeanSE(ages,ESS,t.obs[j,])
        prdf <- CalcFreqMeanSE(ages,ESS,t.pred[j,])
        t.res <- rbind(t.res,c(obsf[1],obsf[1]-1.96*obsf[2],obsf[1]+1.96*obsf[2],
                               prdf[1],prdf[1]-1.96*prdf[2],prdf[1]+1.96*prdf[2]))
      } # end j-loop

      #res
      Neff.bars <-  ESS1/scale.Neff
      ess.uniques <- unique(ESS)
      len.uniques<- length(ess.uniques)

      #-- First plot
      par(mfrow=c(2,1), mar=c(4,4,2,4) )

      plot(years[catch.yrs],t.res[,4],lty=1,lwd=2,col="blue", ylim=c(0,10), xlab="Year",ylab="Mean Age", type='l')
      if (len.uniques>1) {
        segments(x0=years[catch.yrs], y0=rep(0,num.acomp.yrs), x1=years[catch.yrs],
                 y1=Neff.bars[catch.yrs], lwd=5, col='#66BB77aa')
        axis(side=4, at=seq(0,10,2), lab=scale.Neff*seq(0,10,2), las=2 )
        mtext(side = 4, "Eff. Sample Size", line = 3, col='#66BB77')
        lines(years[catch.yrs],t.res[,4],lty=1,lwd=2,col="blue")
      } #end test for >1 unique ESS

      Hmisc::errbar(years[catch.yrs],t.res[,1],t.res[,3],t.res[,2],ylim=c(0,10),add=T)

      if(len.uniques==1) title(main=paste0(my.title,"Fleet ",i, " (", fleet.names[i], ")"," ESS = ",ESS[1]), outer=F)
      if(len.uniques>1) title(main=paste0(my.title,"Fleet ",i, " (", fleet.names[i], ")"), outer=F)

      sdres <- (t.res[,4]-t.res[,1])/((t.res[,1]-t.res[,2])/1.96)
      sdres[sdres==Inf]  <- NA
      sdres[sdres==-Inf]  <- NA

      sdnr <- sd(sdres, na.rm=T)
      rmse <- sqrt(mean(sdres^2, na.rm=T))
      plotrix::barp(sdres,names.arg=years[catch.yrs],col="grey50",ylab="Std Resids",xlab="Year")
      legend('topleft',legend=c(paste0("SDNR=",round(sdnr,2)),paste0("RMSE=",round(rmse,2))),cex=0.7,h=T)
      if (save.plots) savePlot(paste0(od,my.save,"ESS_Mean_Age_Fleet_",i,".",plotf), type=plotf)

      #-- Second plot
      par(mfrow=c(1,1), mar=rep(4,4) )
      aa <- sort(sdres)
      bb <- qqnorm(aa, plot.it = F)
      qqplot(bb$x,bb$y,xlab="Theoretical Quantile",ylab="Sample Quantiles")
      qqline(aa,col="red")
      abline(a=0,b=1,col="blue",lty=2)
      legend('topleft',legend=c("y=x","1st-3rd quartiles"),lty=c(2,1),col=c("blue","red"))

      if(len.uniques==1) title(main=paste0(my.title,"Fleet ",i, " (", fleet.names[i], ")"," ESS = ",ESS[1]), outer=F)
      if(len.uniques>1) title(main=paste0(my.title,"Fleet ",i, " (", fleet.names[i], ")"), outer=F)

      if (save.plots) savePlot(paste0(od,my.save,"ESS_QQplot_Fleet_",i,".",plotf), type=plotf)

    } #end test for catch.yrs
  }   # end loop on number of fleets

  # write csv file of Francis multipliers
  asap.name <- a1$asap.name

  francis.mult <- unlist(asap$Neff.stage2.mult)
  write.csv(francis.mult, file=paste0(od, "NEFF.Mult.Stage2_",asap.name,".csv"), row.names=T)

  return()
} #end function


shinyServer(func = function(input, output, session){
     # Data Page: ----------------------------------------------------------------------------------
     # Create Data:
     MyDataset <- reactive({
          # Yearly:
          if (input$Data_TimeInterval == "Yearly")
          {
               data[[station[which(station$Name == input$Data_SelectStation),"ID"]]] %>%
                    filter(date >= input$Data_SelectDate[1] & date <= input$Data_SelectDate[2]) %>%
                    group_by(year = year(date)) %>%
                    summarise(tmin = if(all(is.na(tmin))) NA else round(x = mean(x = tmin, na.rm = TRUE), digits = 1),
                              tave = if(all(is.na(tave))) NA else round(x = mean(x = tave, na.rm = TRUE), digits = 1),
                              tmax = if(all(is.na(tmax))) NA else round(x = mean(x = tmax, na.rm = TRUE), digits = 1),
                              dp   = if(all(is.na(dp))) NA else round(x = mean(x = dp, na.rm = TRUE), digits = 1),
                              prec = if(all(is.na(prec))) NA else round(x = sum(prec, na.rm = TRUE), digits = 1),
                              wd   = if(all(is.na(wd))) NA else round(x = mean(x = wd, na.rm = TRUE), digits = 1),
                              ws   = if(all(is.na(ws))) NA else round(x = mean(x = ws, na.rm = TRUE), digits = 1),
                              stp  = if(all(is.na(stp))) NA else round(x = mean(x = stp, na.rm = TRUE), digits = 1),
                              slp  = if(all(is.na(slp))) NA else round(x = mean(x = slp, na.rm = TRUE), digits = 1),
                              ea  = if(all(is.na(ea))) NA else round(x = mean(x = ea, na.rm = TRUE), digits = 1),
                              es  = if(all(is.na(es))) NA else round(x = mean(x = es, na.rm = TRUE), digits = 1),
                              rh   = if(all(is.na(rh))) NA else round(x = mean(x = rh, na.rm = TRUE), digits = 1))
          }
          # Monthly:
          else if (input$Data_TimeInterval == "Monthly")
          {
               data[[station[which(station$Name == input$Data_SelectStation),"ID"]]] %>%
                    filter(date >= input$Data_SelectDate[1] & date <= input$Data_SelectDate[2]) %>%
                    group_by(year = year(date), month = month(date)) %>%
                    summarise(tmin = if(all(is.na(tmin))) NA else round(x = mean(x = tmin, na.rm = TRUE), digits = 1),
                              tave = if(all(is.na(tave))) NA else round(x = mean(x = tave, na.rm = TRUE), digits = 1),
                              tmax = if(all(is.na(tmax))) NA else round(x = mean(x = tmax, na.rm = TRUE), digits = 1),
                              dp   = if(all(is.na(dp))) NA else round(x = mean(x = dp, na.rm = TRUE), digits = 1),
                              prec = if(all(is.na(prec))) NA else round(x = sum(prec, na.rm = TRUE), digits = 1),
                              wd   = if(all(is.na(wd))) NA else round(x = mean(x = wd, na.rm = TRUE), digits = 1),
                              ws   = if(all(is.na(ws))) NA else round(x = mean(x = ws, na.rm = TRUE), digits = 1),
                              stp  = if(all(is.na(stp))) NA else round(x = mean(x = stp, na.rm = TRUE), digits = 1),
                              slp  = if(all(is.na(slp))) NA else round(x = mean(x = slp, na.rm = TRUE), digits = 1),
                              ea  = if(all(is.na(ea))) NA else round(x = mean(x = ea, na.rm = TRUE), digits = 1),
                              es  = if(all(is.na(es))) NA else round(x = mean(x = es, na.rm = TRUE), digits = 1),
                              rh   = if(all(is.na(rh))) NA else round(x = mean(x = rh, na.rm = TRUE), digits = 1))
          }
          # Daily:
          else
          {
               data[[station[which(station$Name == input$Data_SelectStation),"ID"]]] %>%
                    select(-id, -lat, -lon, -elev) %>%
                    filter(date >= input$Data_SelectDate[1] & date <= input$Data_SelectDate[2])
          }
     })

     # Data Viwe:
     output$Data_viwe <- DT::renderDataTable({
          DT::datatable(data = MyDataset(),
                        options = list(lengthMenu = c(10, 25, 50),
                                       pageLength = 10))
     })

     # Data Download:
     output$Data_Download <- downloadHandler(
          filename = function()
          {
               paste(input$Data_SelectStation, " - ", input$Data_TimeInterval, ".csv", sep = "")
          },
          content = function(file)
          {
               write.csv(x = MyDataset(),
                         file = file,
                         row.names = FALSE)
          }
     )

     # Graphs Page: --------------------------------------------------------------------------------
     # Graphs 01:
     # Create Data:
     MyDataset_Graphs_01 <- reactive({
          # Yearly:
          if (input$Graphs_01_TimeInterval == "Yearly")
          {
               data[[station[which(station$Name == input$Graphs_01_SelectStation),"ID"]]] %>%
                    filter(date >= input$Graphs_01_SelectDate[1] & date <= input$Graphs_01_SelectDate[2]) %>%
                    group_by(year = year(date)) %>%
                    summarise(tmin = if(all(is.na(tmin))) NA else round(x = mean(x = tmin, na.rm = TRUE), digits = 1),
                              tave = if(all(is.na(tave))) NA else round(x = mean(x = tave, na.rm = TRUE), digits = 1),
                              tmax = if(all(is.na(tmax))) NA else round(x = mean(x = tmax, na.rm = TRUE), digits = 1),
                              dp   = if(all(is.na(dp))) NA else round(x = mean(x = dp, na.rm = TRUE), digits = 1),
                              prec = if(all(is.na(prec))) NA else round(x = sum(prec, na.rm = TRUE), digits = 1),
                              wd   = if(all(is.na(wd))) NA else round(x = mean(x = wd, na.rm = TRUE), digits = 1),
                              ws   = if(all(is.na(ws))) NA else round(x = mean(x = ws, na.rm = TRUE), digits = 1),
                              stp  = if(all(is.na(stp))) NA else round(x = mean(x = stp, na.rm = TRUE), digits = 1),
                              slp  = if(all(is.na(slp))) NA else round(x = mean(x = slp, na.rm = TRUE), digits = 1),
                              ea  = if(all(is.na(ea))) NA else round(x = mean(x = ea, na.rm = TRUE), digits = 1),
                              es  = if(all(is.na(es))) NA else round(x = mean(x = es, na.rm = TRUE), digits = 1),
                              rh   = if(all(is.na(rh))) NA else round(x = mean(x = rh, na.rm = TRUE), digits = 1)) %>%
                    mutate(Factor = factor(x = "Year"))
          }
          # Monthly:
          else if (input$Graphs_01_TimeInterval == "Monthly")
          {
               data[[station[which(station$Name == input$Graphs_01_SelectStation),"ID"]]] %>%
                    filter(date >= input$Graphs_01_SelectDate[1] & date <= input$Graphs_01_SelectDate[2]) %>%
                    group_by(year = year(date), month = month(date)) %>%
                    summarise(tmin = if(all(is.na(tmin))) NA else round(x = mean(x = tmin, na.rm = TRUE), digits = 1),
                              tave = if(all(is.na(tave))) NA else round(x = mean(x = tave, na.rm = TRUE), digits = 1),
                              tmax = if(all(is.na(tmax))) NA else round(x = mean(x = tmax, na.rm = TRUE), digits = 1),
                              dp   = if(all(is.na(dp))) NA else round(x = mean(x = dp, na.rm = TRUE), digits = 1),
                              prec = if(all(is.na(prec))) NA else round(x = sum(prec, na.rm = TRUE), digits = 1),
                              wd   = if(all(is.na(wd))) NA else round(x = mean(x = wd, na.rm = TRUE), digits = 1),
                              ws   = if(all(is.na(ws))) NA else round(x = mean(x = ws, na.rm = TRUE), digits = 1),
                              stp  = if(all(is.na(stp))) NA else round(x = mean(x = stp, na.rm = TRUE), digits = 1),
                              slp  = if(all(is.na(slp))) NA else round(x = mean(x = slp, na.rm = TRUE), digits = 1),
                              ea  = if(all(is.na(ea))) NA else round(x = mean(x = ea, na.rm = TRUE), digits = 1),
                              es  = if(all(is.na(es))) NA else round(x = mean(x = es, na.rm = TRUE), digits = 1),
                              rh   = if(all(is.na(rh))) NA else round(x = mean(x = rh, na.rm = TRUE), digits = 1)) %>%
                    mutate(Factor = factor(x = month))
          }
          # Daily:
          else
          {
               data[[station[which(station$Name == input$Graphs_01_SelectStation),"ID"]]] %>%
                    select(-id, -lat, -lon, -elev) %>%
                    filter(date >= input$Graphs_01_SelectDate[1] & date <= input$Graphs_01_SelectDate[2]) %>%
                    mutate(Factor = factor(x = year(date)))
          }
     })

     output$Graphs_01 <- renderPlot({
          # Scatterplot
          if (input$Graphs_01_GraphType == "Scatterplot")
          {
               if (input$Graphs_01_TimeInterval == "Yearly")
               {
                    x = "year"
               }
               else if (input$Graphs_01_TimeInterval == "Monthly")
               {
                    x = "year"
               }
               else
               {
                    x = "date"
               }
               ggplot(data = MyDataset_Graphs_01(),
                      mapping = aes_string(x = x,
                                           y = para[which(para$Parameter == input$Graphs_01_SelectParameter),"abbv"])) +
                    geom_point() +
                    geom_line()
          }
          # Histogram
          else if (input$Graphs_01_GraphType == "Histogram")
          {
               ggplot(data = MyDataset_Graphs_01(),
                      mapping = aes_string(x = para[which(para$Parameter == input$Graphs_01_SelectParameter),"abbv"])) +
                    geom_histogram(bins = input$Graphs_01_GraphBins)
          }
          # Density Plot
          else if (input$Graphs_01_GraphType == "Density Plot")
          {
               ggplot(data = MyDataset_Graphs_01(),
                      mapping = aes_string(x = para[which(para$Parameter == input$Graphs_01_SelectParameter),"abbv"])) +
                    geom_density()
          }
          # Box Plot
          else
          {
               ggplot(data = MyDataset_Graphs_01(),
                      mapping = aes_string(x = "Factor",
                                           y = para[which(para$Parameter == input$Graphs_01_SelectParameter),"abbv"])) +
                    geom_boxplot()
          }
     })
})


pdf_file<-"pdf/boxplots_multiple.pdf"
cairo_pdf(bg="grey98", pdf_file,width=7,height=9)

par(omi=c(0.35,0.25,0.75,0.75),mai=c(0.95,1.75,0.25,0),family="Lato Light",las=1)
library(RColorBrewer)
library(memisc)

# Import data and prepare chart

myDataFile<-"myData/ZA4804_v2-0-0.sav"
ZA4804<-spss.system.file(myDataFile)
myData<-subset(ZA4804,select=c(s002evs,s003,x047d))
attach(myData)
x<-subset(myData,x047d>0 & s002evs=="2008-2010")
attach(x)

tM<-aggregate(as.numeric(x047d),list(as.factor(s003)),median,na.rm =T)

s003f<-factor(s003,levels=tM[order(tM$x),1])

myC1<-brewer.pal(6, "PuRd")[2]
myC2<-brewer.pal(6, "PuRd")[3]
myC3<-brewer.pal(6, "PuRd")[4]
myC4<-brewer.pal(6, "PuRd")[5]
myC5<-brewer.pal(6, "PuRd")[6]
myColour<-c(rep(myC1, 7), rep(myC2, 10), rep(myC3, 10), rep(myC4, 10), rep(myC5,10))
par(fg="grey75")

# Create chart and other elements

boxplot(1000*x047d ~ s003f,horizontal=T,ylim=c(0,4000),border=NA,boxwex=0.25,las=1,col=myColour,outline=F,cex.axis=0.7)

points(sort(1000*tM$x,decreasing=T),length(unique(s003)):1,pch=19,cex=1.15,col=rev(myColour))

abline(v=2000)
abline(h=seq(7.5,37.5,by=10))

par(fg="black")
mtext("25 %",3,at=1300,line=-2)
mtext("75 %",3,at=3000,line=-2)
mtext("Median",3,at=2800,line=-1, cex=0.75)

mtext("Monthly Household Income (PPP adjusted) in Euro",1,adj=0.5,line=2.5)

# Titling

mtext("Income Distribution 2008-2010",3,line=1.6,adj=0,cex=1.8,family="Lato Black",outer=T)
mtext("European Values Study",3,line=-0.2,adj=0,cex=1.5,font=3,outer=T)
mtext("Source: ZA4804 European Values Study Longitudinal Data File 1981-2008, www.gesis.org",1,line=0,adj=1.0,cex=0.95,font=3,outer=T)
mtext("N (total): 55,635",1,line=-2,adj=0,cex=1.25,font=3,outer=T)
dev.off()


#!/usr/bin/env Rscript
# Author: Cody Lewis
# Description:
# Console interface showing how the reputation equation works

library(optigrab)

source("ReputationQR.r")

# The main interface
main <- function() {
    cat("Simulating the effects of varying capabilities on the system...\n")
    s_target = as.numeric(opt_get(c("s-target", "st"), default=50))
    c_target = as.numeric(opt_get(c("c-target", "ct"), default=50))
    s_j = as.numeric(opt_get(c("s-j", "sj"), default=50))
    eta = as.numeric(opt_get(c("eta", "e"), default=50))
    node_note = as.numeric(opt_get(c("node-note", "n"), default=1))
    lambda = as.numeric(opt_get(c("lambda", "l"), default=0.7))
    theta = as.numeric(opt_get(c("theta", "t"), default=0.7))
    number_of_transactions = as.numeric(opt_get(c("transactions", "tr"), default=300))
    final_qrs = rep(1, each=100)
    reputations = matrix(
        rep(1, each=((number_of_transactions + 1) * 100)), nrow=100
    )
    weights_text = rep("", each=100)
    for(c_j in 1:100) {
        node_qrs = c(1)
        node_qr_times = c(1)
        time = 1
        client_qrs = runif(number_of_transactions)
        client_notes = take_notes(c_j, c_target, s_j, s_target, client_qrs)
        for(transactions in 1:number_of_transactions) {
            if((transactions %% 30) == 0) {
                time = time + 1
            }
            dS_max_sq = find_dist(S_MAX, s_target)**2
            dC_max_sq = find_dist(C_MAX, c_target)**2
            d = report_dist(c_j, s_j, c_target, s_target, eta, node_note,
                            dS_max_sq, dC_max_sq, S_MAX, C_MAX)
            w = find_weight(lambda, theta, node_note, time, d, time)
            qr = find_qr(w, client_notes[[transactions]], theta, time,
                         node_note, client_qrs[[transactions]], node_qrs,
                         node_qr_times)
            if(d >= sqrt(dS_max_sq + dC_max_sq)) {
                weights_text[[c_j]] = "Reports produced in the transaction phase of this attack will have no impact on the client's QR as the distance of the report is out of bounds"
            } else {
                weights_text[[c_j]] = sprintf("Reports produced in the transaction phase of this attack will have a weight of %f", w)
            }
            node_qrs = c(qr, node_qrs)
            node_qr_times = c(time, node_qr_times)
            reputations[c_j, transactions + 1] =
                calculate_reputation(
                    theta, client_notes, client_qrs,
                    transactions, time, node_qr_times
                )
        }
        final_qrs[[c_j]] = node_qrs[[1]]
        cat(
            sprintf(
                "Completed %d transactions for c_j: %d\n",
                number_of_transactions, c_j
            )
        )
    }
    dir.create("./graphs", showWarnings=FALSE)
    for(c_j in 1:100) {
        png(sprintf("graphs/%d_reputation_evolution.png", c_j))
        plot_reputation(reputations[c_j, ])
        dev.off()
        cat(sprintf("%d\t%s\n", c_j, weights_text[[c_j]]))
    }
    plot_cap_qr(final_qrs)
    cat("Done. Created a few plots in the ./graphs directory\n")
}

main()


##Read phylogenetic tree from TimeTree.org
library(ape)
tree <- read.tree("../data/tree.tre")

##Read summary table of motif and species from Cis-BP database
mot = read.table("../data/motif_vs_species.tsv",sep="\t",header=T,row.names=1)
mot = mot[,colnames(mot) %in% tree[[3]]]
mot = mot[apply(mot,1,sum)>0,apply(mot,2,sum)>138] #remove species with imcomplete data support.
tree = drop.tip(tree,tree[[3]][!tree[[3]]%in%colnames(mot)]) #sync tree with motif

##Calculate MPI for each motif
bg = sum(tree$edge.length) #The total branch sum as background
MPI = vector()
for (i in 1:nrow(mot))
	{colu = tree[[3]] %in% colnames(mot)[mot[i,]>0]

	if (sum(colu) == 1)
		{MPI[i] = 0
		}
	else{tr = tree
		tr = drop.tip(tr,tree[[3]][! colu])
		MPI[i] = sum(tr$edge.length)/bg #MPI is defined as the branch sum of a subtree over background
		}
	}

##Output
out = cbind("Motif\tMPI"=MPI,mot)
rownames(out) = rownames(mot)
ord = order(out[,1],decreasing=T)
out = out[ord,]
write.table(out,file="../data/MPI.tsv",sep="\t",quote=F)


rm(list = ls())

args <- commandArgs(TRUE)
wd <-args[1]
cooc_file <- args[2]
metadata_file <- args[3]
output_file <- args[4]
mode <- args[5]

setwd(wd) #Don't forget to set your working directory
library(GMD)
library(MASS)
library(ecodist)
library(tm)
library(proxy)
library(SnowballC)

# Read input files

metadata <- read.csv(metadata_file)

if(mode == "text") {
  cooc <- read.csv(cooc_file, header=TRUE) # You will need to have your own co-occurrence file here

  m <- list(Content = "content", ID = "id")

  myReader <- readTabular(mapping = m)

  (corpus <- Corpus(DataframeSource(cooc), readerControl = list(reader = myReader)))

  corpus <- tm_map(corpus, removePunctuation, preserve_intra_word_dashes = FALSE)

  corpus <- tm_map(corpus, stripWhitespace)

  corpus <- tm_map(corpus, tolower)

  corpus <- tm_map(corpus, removeWords, stopwords("english"))

  corpus <- tm_map(corpus, stemDocument)

  tdm <- TermDocumentMatrix(corpus)

  distance_matrix <- dissimilarity(tdm, method="correlation")

  write.csv(as.matrix(distance_matrix), "matrix.csv")

} else {

  cooc <- read.csv(cooc_file, header=FALSE) # You will need to have your own co-occurrence file here

  # Create symmetric matrix from co-occurrences list
  cooc_matrix_sym <- tapply(as.numeric(cooc$V3), list(cooc$V1, cooc$V2), max)

  if(isSymmetric(cooc_matrix_sym) == FALSE)  {
    stop("Input matrix not symmetric")
  }

  # Calculate correlation coefficients
  cooc_matrix_cor = cor(cooc_matrix_sym, use="pairwise.complete.obs")

  # Calculate Euclidian distance
  distance_matrix <- dist(data.matrix(cooc_matrix_cor))
}

# Perform clustering, use elbow to determine a good number of clusters
css_cluster <- css.hclust(distance_matrix, hclust.FUN.MoreArgs=list(method="ward"))
#cut_off = elbow.batch(css_cluster)
cut_off = elbow.batch(css_cluster,inc.thres=c(0.01,0.05,0.1),
                      ev.thres=c(0.95,0.9,0.8,0.75,0.67,0.5,0.33,0.2,0.1),precision=3)
num_clusters = cut_off$k
meta_cluster = attr(css_cluster,"meta")
cluster = meta_cluster$hclust.obj
labels = labels(distance_matrix)

# Plot result of clustering to PDF file
pdf("clustering.pdf", width=19, height=12)
plot(cluster, labels=metadata$title, cex=0.6)
rect.hclust(cluster, k=num_clusters, border="red")
dev.off()

cat(num_clusters)

# Perform non-metric multidimensional scaling
nm = nmds(distance_matrix, mindim=2, maxdim=2)
nm.nmin = nmds.min(nm)
x = nm.nmin$X1
y = nm.nmin$X2

# Plot results from multidimensional scaling, highlight clusters with symbols
pdf("mds.pdf")
groups <- cutree(cluster, k=num_clusters)
plot(nm.nmin, pch=groups)
dev.off()

# Prepare the output
result = cbind(x,y,groups,labels)
output = merge(metadata, result, by.x="id", by.y="labels", all=TRUE)

# Write output to file
file_handle = file(output_file, open="w")
write.csv(output, file=file_handle, row.names=FALSE)
close(file_handle)

# Write some stats to a file
file_handle = file("stats.txt", open="w")
writeLines(c(paste("Number of Clusters:", num_clusters, sep=" ")
  , paste("Description:", attributes(cut_off)$description)
  , paste("Stress:", min(nm$stress), sep=" ")
  , paste("R2:", max(nm$r2), sep=" ")
  ), file_handle)

close(file_handle)


rm(list=ls())

train_13 <- fread('data_all/train_all_2013.csv')
train_13 <- subset(train_13,is_booking==1)

destIds <-  sqldf('select srch_destination_id,count(*) from train_13 group by srch_destination_id having count(*)>3000 order by count(*) desc')$srch_destination_id

for(dest_id in  destIds) {
  print(sprintf('training model=%d',dest_id))
  train <- subset(train_13,srch_destination_id==dest_id)
  train$time_to_ci <- as.Date(train$srch_ci) - as.Date(train$date_time)
  train$length <- as.Date(train$srch_co) - as.Date(train$srch_ci)

  svmData_a <- train[1:min(nrow(train),6000),c(24,26),with=F]
  svmData_a$hotel_cluster <- as.factor(svmData_a$hotel_cluster)
  model <- svm(hotel_cluster ~ ., data = svmData_a,probability=T,cross=2)
  summary(model)
  svmProbs <- predict(model,svmData_a,probability=T)
  svmProbs <- attr(svmProbs, "probabilities")

  allClustersCols <- lapply(0:99,function(x) { x})
  missingClusterCols  <- setdiff(allClustersCols,colnames(svmProbs))
  missingClustersMat = matrix(0,nrow=nrow(svmProbs),ncol=length(missingClusterCols))
  colnames(missingClustersMat) <- missingClusterCols
  svmProbs <- cbind(svmProbs,missingClustersMat)

  svmProbs <- svmProbs[, order(as.integer(colnames(svmProbs)))]

  svmProbs <- data.frame(svmProbs)
  svmProbs$length <- svmData_a$length
  write.csv(svmProbs,sprintf('svm/svm_predictions_%d.csv',dest_id),row.names=F)
}

#train <- subset(train,length<4)

tuneResults <- tune.svm(hotel_cluster~., data = svmData_a, gamma = seq(.5, .9, by = .1), cost = seq(1,1000, by = 200))


# Thanks: JoAnn Alvarez
require(Hmisc)
set.seed(3)
NN <- 200
x1 <- rnorm(NN)
x2 <- x1^2
x3 <- runif(NN)
x4 <- factor(NA, levels = c("January", "February", "March"))
x5 <- factor(sample(c(1, 2, 3), size = NN, replace = TRUE), labels =
             c("January", "February", "March"))
m <- 30
x2[1:m] <- NA
x5[1:m] <- NA
xdat <- data.frame(x1, x2, x3, x4)
combine.levels(xdat$x4)
xdat2 <- dataframeReduce(xdat, minprev=0.05, fracmiss = 0.05)


df <- read.table('data.in')
print(df)
plot(df$V1, df$V2, col=rgb(0,0,1,0.2), xlab="Altura", ylab="Peso")
curve(66.48*x-53.41, add=TRUE, lwd=3, col="#ff0000")


#' Center the variables on groups mean
#' Returns a dataframe with variables groups means as x.mean
#' and centered variables a x.centered
#' @param x dataframe
#' @param g grouping factor
#' @return New dataframe
#' @export
centerOnGroup<-function(x,g) {
	# First, create the joint distribution
	df1<-data.frame(x)
	df1$.g<-g
	x2<-x
	colnames(x2)<-paste0("mean.",colnames(x))
	df2.1<-aggregate(x2,list(.g=g),mean)
	df2<-merge(df1,df2.1)
	for(i in colnames(x)) {
		df2[[paste0("centered.",i)]]<-df2[[i]]-df2[[paste0("mean.",i)]]
	}
	df2
}


############################################################
# For macaque paper revisions, 04.20
# Checks distributions of genes overlapping CNVs
# Gregg Thomas
############################################################

this.dir <- dirname(parent.frame(2)$ofile)
setwd(this.dir)

library(ggplot2)
library(cowplot)
source("../lib/design.r")

cat("----------\n")

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

genHist <- function(df, mode, type) {

  if(type=="del"){
    type = "deleted"
    fcol = "#006ddb"
    df$xvar = df$Num.del
    fillstr = "Deletions"
  }else if(type=="dup"){
    type = "duplicated"
    fcol = "#db6d00"
    df$xvar = df$Num.dup
    fillstr = "Duplications"
  }else{
    type = "deleted or duplicated"
    fcol = "#999999"
    df$xvar = df$total
    fillstr = "All"
  }

  df = subset(df, xvar > 0)
  xmax = max(df$xvar)

  xtitle = paste("# of times ", mode, " ", type, sep="")
  ytitle = paste("# of ", mode, "s", sep="")

  p = ggplot(df, aes(x=xvar)) +
    geom_histogram(aes(fill=fillstr), bins=xmax, color="black") +
    xlab(xtitle) +
    ylab(ytitle) +
    scale_x_continuous(breaks=1:xmax) +
    scale_y_continuous(expand = c(0, 0)) +
    scale_fill_manual(name="", values=c("All"='#999999',"Deletions"='#006ddb',"Duplications"='#db6d00')) +
    bartheme() +
    theme(legend.position="none")
  return(p)
}

parseDF <- function(df, mode) {
  df = subset(df, Feature.type == mode)
  df$total = df$Num.del.full + df$Num.del.partial + df$Num.dup.full + df$Num.dup.partial
  df$Num.del = df$Num.del.full + df$Num.del.partial
  df$Num.dup = df$Num.dup.full + df$Num.dup.partial
  return(df)
}

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

mq_gene_counts = read.csv("../data/macaque-cnv-gene-counts-noalu.csv", header=T)

mq_genes = parseDF(mq_gene_counts, "gene")
genes_p = genHist(mq_genes, "gene", "all")
print(genes_p)
genes_del_p = genHist(mq_genes, "gene", "del")
print(genes_del_p)
genes_dup_p = genHist(mq_genes, "gene", "dup")
print(genes_dup_p)

cat("Combining gene plots...\n")
prow = plot_grid(genes_del_p, genes_dup_p, align = 'vh', hjust = -1, nrow = 1)
genes_pcombo = plot_grid(genes_p, prow, nrow=2)
print(genes_pcombo)
## Genes

mq_trans = parseDF(mq_gene_counts, "transcript")
trans_p = genHist(mq_trans, "transcript", "all")
print(trans_p)
trans_del_p = genHist(mq_trans, "transcript", "del")
print(trans_del_p)
trans_dup_p = genHist(mq_trans, "transcript", "dup")
print(trans_dup_p)

cat("Combining trancsript plots...\n")
prow = plot_grid(trans_del_p, trans_dup_p, align = 'vh', hjust = -1, nrow = 1)
trans_pcombo = plot_grid(trans_p, prow, nrow=2)
print(trans_pcombo)
## Transcripts

mq_exons = parseDF(mq_gene_counts, "exon")
exons_p = genHist(mq_exons, "exon", "all")
print(exons_p)
exons_del_p = genHist(mq_exons, "exon", "del")
print(exons_del_p)
exons_dup_p = genHist(mq_exons, "exon", "dup")
print(exons_dup_p)

cat("Combining exon plots...\n")
prow = plot_grid(trans_del_p, exons_dup_p, align = 'vh', hjust = -1, nrow = 1)
exons_pcombo = plot_grid(exons_p, prow, nrow=2)
print(exons_pcombo)
## Exons

cat("Combining ALL plots...\n")
full_combo = plot_grid(genes_pcombo, trans_pcombo, exons_pcombo, nrow=3, labels=c("Genes","Transcripts","Exons"), label_size=24, vjust=0.1)
print(full_combo)

cat("Saving...\n")
ggsave(filename="figX2.png", full_combo, width=10, height=20, units="in")

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

# The Chi-square test for ratios of deletions and duplications
cat("\n-------------\n")
cat("Gene overlap Chi-square test:\n")
gene_overlaps = data.frame("Species"=c("Macaque", "Human"), "num.del"=c(952,7804), "num.dup"=c(425,2597))
gene_overlaps_t = t(gene_overlaps[,2:ncol(gene_overlaps)])
colnames(gene_overlaps_t) <- gene_overlaps[,1]
gene_overlaps_chi = chisq.test(gene_overlaps_t)
print(gene_overlaps_chi)
cat("-------------\n")


# Originally published on:
# http://www.r-statistics.com/2010/02/post-hoc-analysis-for-friedmans-test-r-code

# good read: 	http://en.wikipedia.org/wiki/Friedman_test
# 				http://finzi.psych.upenn.edu/R/library/coin/html/SymmetryTests.html
# could have used: block = with(data, eval(parse(text = all.vars(formu)[3])))

friedman.test.with.post.hoc <- function(formu, data, to.print.friedman = T, to.post.hoc.if.signif = T,  to.plot.parallel = T, to.plot.boxplot = T, signif.P = .05, color.blocks.in.cor.plot = T, jitter.Y.in.cor.plot =F)
{
  # formu is a formula of the shape: 	Y ~ X | block
  # data is a long data.frame with three columns:    [[ Y (numeric), X (factor), block (factor) ]]

  # Note: This function doesn't handle NA's! In case of NA in Y in one of the blocks, then that entire block should be removed.

  # Loading needed packages
  if(!require(coin))
  {
    print("You are missing the package 'coin', we will now try to install it...")
    install.packages("coin")
    library(coin)
  }

  if(!require(multcomp))
  {
    print("You are missing the package 'multcomp', we will now try to install it...")
    install.packages("multcomp")
    library(multcomp)
  }

  if(!require(colorspace))
  {
    print("You are missing the package 'colorspace', we will now try to install it...")
    install.packages("colorspace")
    library(colorspace)
  }

  # get the names out of the formula
  formu.names <- all.vars(formu)
  Y.name <- formu.names[1]
  X.name <- formu.names[2]
  block.name <- formu.names[3]

  if(dim(data)[2] >3) data <- data[,c(Y.name,X.name,block.name)]	# In case we have a "data" data frame with more then the three columns we need. This code will clean it from them...

  # Note: the function doesn't handle NA's. In case of NA in one of the block T outcomes, that entire block should be removed.

  # stopping in case there is NA in the Y vector
  if(sum(is.na(data[,Y.name])) > 0) stop("Function stopped: This function doesn't handle NA's. In case of NA in Y in one of the blocks, then that entire block should be removed.")

  # make sure that the number of factors goes with the actual values present in the data:
  data[,X.name ] <- factor(data[,X.name ])
  data[,block.name ] <- factor(data[,block.name ])
  number.of.X.levels <- length(levels(data[,X.name ]))
  if(number.of.X.levels == 2) { warning(paste("'",X.name,"'", "has only two levels. Consider using paired wilcox.test instead of friedman test"))}

  # making the object that will hold the friedman test and the other.
  the.sym.test <- symmetry_test(formu, data = data,	### all pairwise comparisons
                                teststat = "max",
                                xtrafo = function(Y.data) { trafo( Y.data, factor_trafo = function(x) { model.matrix(~ x - 1) %*% t(contrMat(table(x), "Tukey")) } ) },
                                ytrafo = function(Y.data){ trafo(Y.data, numeric_trafo = rank, block = data[,block.name] ) }
  )
  # if(to.print.friedman) { print(the.sym.test) }

  if(to.post.hoc.if.signif)
  {
    if(pvalue(the.sym.test) < signif.P)
    {
      # the post hoc test
      The.post.hoc.P.values <- pvalue(the.sym.test, method = "single-step")	# this is the post hoc of the friedman test

      # plotting
      if(to.plot.parallel & to.plot.boxplot)	par(mfrow = c(1,2)) # if we are plotting two plots, let's make sure we'll be able to see both

      if(to.plot.parallel)
      {
        X.names <- levels(data[, X.name])
        X.for.plot <- seq_along(X.names)
        plot.xlim <- c(.7 , length(X.for.plot)+.3)	# adding some spacing from both sides of the plot

        if(color.blocks.in.cor.plot)
        {
          blocks.col <- rainbow_hcl(length(levels(data[,block.name])))
        } else {
          blocks.col <- 1 # black
        }

        data2 <- data
        if(jitter.Y.in.cor.plot) {
          data2[,Y.name] <- jitter(data2[,Y.name])
          par.cor.plot.text <- "Parallel coordinates plot (with Jitter)"
        } else {
          par.cor.plot.text <- "Parallel coordinates plot"
        }

        # adding a Parallel coordinates plot
        matplot(as.matrix(reshape(data2,  idvar=X.name, timevar=block.name,
                                  direction="wide")[,-1])  ,
                type = "l",  lty = 1, axes = FALSE, ylab = Y.name,
                xlim = plot.xlim,
                col = blocks.col,
                main = par.cor.plot.text)
        axis(1, at = X.for.plot , labels = X.names) # plot X axis
        axis(2) # plot Y axis
        points(tapply(data[,Y.name], data[,X.name], median) ~ X.for.plot, col = "red",pch = 4, cex = 2, lwd = 5)
      }

      if(to.plot.boxplot)
      {
        # first we create a function to create a new Y, by substracting different combinations of X levels from each other.
        subtract.a.from.b <- function(a.b , the.data)
        {
          the.data[,a.b[2]] - the.data[,a.b[1]]
        }

        temp.wide <- reshape(data,  idvar=X.name, timevar=block.name,
                             direction="wide") 	#[,-1]
        wide.data <- as.matrix(t(temp.wide[,-1]))
        colnames(wide.data) <- temp.wide[,1]

        Y.b.minus.a.combos <- apply(with(data,combn(levels(data[,X.name]), 2)), 2, subtract.a.from.b, the.data =wide.data)
        names.b.minus.a.combos <- apply(with(data,combn(levels(data[,X.name]), 2)), 2, function(a.b) {paste(a.b[2],a.b[1],sep=" - ")})

        the.ylim <- range(Y.b.minus.a.combos)
        the.ylim[2] <- the.ylim[2] + 2*max(sd(Y.b.minus.a.combos))+1	# adding some space for the labels
        is.signif.color <- ifelse(The.post.hoc.P.values < .05 , "green", "grey")

        op <- par(mar = c(2,13,2,2) + 0.1)
        boxplot(Y.b.minus.a.combos,
                names = names.b.minus.a.combos ,
                col = is.signif.color,
                main = "Boxplots of Rank Differences",
                ylim = the.ylim,
                horizontal=TRUE,
                las=1
        )
        par(op)
        legend("topright", legend = paste(rev(names.b.minus.a.combos), rep(" ; PostHoc P.value:", number.of.X.levels),round(rev(The.post.hoc.P.values),5)) , fill =  rev(is.signif.color) )
        abline(v = 0, col = "blue")

      }

      list.to.return <- list(Friedman.Test = the.sym.test, PostHoc.Test = The.post.hoc.P.values)
      if(to.print.friedman) {print(list.to.return)}
      return(list.to.return)

    }	else {
      print("The results were not significant, There is no need for a post hoc test")
      return(the.sym.test)
    }
  }

  # Original credit (for linking online, to the package that performs the post hoc test) goes to "David Winsemius", see:
  # http://tolstoy.newcastle.edu.au/R/e8/help/09/10/1416.html
}

# friedman.test.with.post.hoc(Taste ~ Wine | Taster ,WineTasting)	# the same with our function. With post hoc, and cool plots
# boxplot(Taste ~ Wine  ,WineTasting)

# example

friedman.test.with.post.hoc.example <- function()
{

  # Loading needed packages
  if(!require(coin))
  {
    install.packages("coin")
    library(coin)
  }

  if(!require(multcomp))
  {
    install.packages("multcomp")
    library(multcomp)
  }

  ### Comparison of three Wine ("Wine A", "Wine B", and
  ###  "Wine C") for rounding first base.
  WineTasting <- data.frame(
    Taste = c(5.40, 5.50, 5.55,
              5.85, 5.70, 5.75,
              5.20, 5.60, 5.50,
              5.55, 5.50, 5.40,
              5.90, 5.85, 5.70,
              5.45, 5.55, 5.60,
              5.40, 5.40, 5.35,
              5.45, 5.50, 5.35,
              5.25, 5.15, 5.00,
              5.85, 5.80, 5.70,
              5.25, 5.20, 5.10,
              5.65, 5.55, 5.45,
              5.60, 5.35, 5.45,
              5.05, 5.00, 4.95,
              5.50, 5.50, 5.40,
              5.45, 5.55, 5.50,
              5.55, 5.55, 5.35,
              5.45, 5.50, 5.55,
              5.50, 5.45, 5.25,
              5.65, 5.60, 5.40,
              5.70, 5.65, 5.55,
              6.30, 6.30, 6.25),
    Wine = factor(rep(c("Wine A", "Wine B", "Wine C"), 22)),
    Taster = factor(rep(1:22, rep(3, 22))))

  with(WineTasting , boxplot( Taste  ~ Wine )) # boxploting
  friedman.test.with.post.hoc(Taste ~ Wine | Taster ,WineTasting)	# the same with our function. With post hoc, and cool plots

  ### classical global test
  friedman_test(Taste ~ Wine | Taster, data = WineTasting)

  friedman.test.with.post.hoc(Taste ~ Wine | Taster ,WineTasting[1:15,])	# showing what happens when results are not signif

  #	fo <- Taste ~ Wine | Taster
  #  mtrace(temp)
  # mtrace.off()

  # what happens in the case of only two levels in X
  WineTasting2 <- WineTasting[WineTasting[,2] %in% levels(WineTasting[,2])[2:3],]
  WineTasting2[,2] <- factor(WineTasting2[,2] )
  friedman.test.with.post.hoc(Taste ~ Wine | Taster ,WineTasting2)

  # what happens in case of an NA
  WineTasting2 <- WineTasting
  WineTasting2[1,1] <- NA
  friedman.test.with.post.hoc(Taste ~ Wine | Taster ,WineTasting2)
}

#friedman.test.with.post.hoc.example()

friedman.test.with.post.hoc.example2 <- function()
{

  # Loading needed packages
  if(!require(coin))
  {
    install.packages("coin")
    library(coin)
  }

  if(!require(multcomp))
  {
    install.packages("multcomp")
    library(multcomp)
  }

  ### Comparison of three Wine ("Wine A", "Wine B", and
  ###  "Wine C") for rounding first base.
  WineTasting <- data.frame(
    Taste = c(5.40, 5.50, 5.55,
              5.85, 5.70, 5.75,
              5.20, 5.60, 5.50,
              5.55, 5.50, 5.40,
              5.90, 5.85, 5.70,
              5.45, 5.55, 5.60,
              5.40, 5.40, 5.35,
              5.45, 5.50, 5.35,
              5.25, 5.15, 5.00,
              5.85, 5.80, 5.70,
              5.25, 5.20, 5.10,
              5.65, 5.55, 5.45,
              5.60, 5.35, 5.45,
              5.05, 5.00, 4.95,
              5.50, 5.50, 5.40,
              5.45, 5.55, 5.50,
              5.55, 5.55, 5.35,
              5.45, 5.50, 5.55,
              5.50, 5.45, 5.25,
              5.65, 5.60, 5.40,
              5.70, 5.65, 5.55,
              6.30, 6.30, 6.25),
    Wine = factor(rep(c("Wine A", "Wine B", "Wine C"), 22)),
    Taster = factor(rep(1:22, rep(3, 22))))

  ### classical global test
  friedman_test(Taste ~ Wine | Taster, data = WineTasting)

  #	fo <- Taste ~ Wine | Taster

  friedman.test.with.post.hoc(Taste ~ Wine | Taster ,WineTasting)	# the same with our function. With post hoc, and cool plots
  friedman.test.with.post.hoc(Taste ~ Wine | Taster ,WineTasting[1:15,])	# showing what happens when results are not signif

  #  mtrace(temp)
  # mtrace.off()

  # what happens in the case of only two levels in X
  WineTasting2 <- WineTasting[WineTasting[,2] %in% levels(WineTasting[,2])[2:3],]
  WineTasting2[,2] <- factor(WineTasting2[,2] )
  friedman.test.with.post.hoc(Taste ~ Wine | Taster ,WineTasting2)

  # what happens in case of an NA
  WineTasting2 <- WineTasting
  WineTasting2[1,1] <- NA
  friedman.test.with.post.hoc(Taste ~ Wine | Taster ,WineTasting2)
}

#friedman.test.with.post.hoc.example2()


plot(x,y,type="n",axes=F,xlab="cumulative percentage of population",ylab="cumulative percentage of income")

pos1<-round(0.25*length(x),0)
pos2<-round(0.75*length(x),0)

rect(0,0,1,1,border=F,col=rgb(200,0,0,25,maxColorValue=255))
rect(0,0,x[pos2],y[pos2],border=F,col="white")
rect(0,0,x[pos1],y[pos1],border=F,col=rgb(200,0,0,100,maxColorValue=255))
lines(x,y)
x<-array(c(0,1,0,1),dim=c(2,2))
lines(x)
text(0.35,y[pos1]/2,paste(round(100*y[pos1],digits=0),"%",sep=" "))
text(0.1,1-(1-y[pos2])/2,paste(round(100*(1-y[pos2]),digits=0),"%",sep=" "))

source("scripts/inc_axes_with_lines_lorenz.r")


a <- 1:100
evennums <- a[ a%%2 == 0 ]
print(evennums)


library(readr)
library(stringr)
library(dplyr)

#setwd("C:/Users/Justin/Documents/Classes/SP20/GES 486/proj1")
setwd("Z:/ges486/Project1")

as.pct <- function(x, digits = 2) {
  round(x*100, digits = digits)
}

ins.12 <- read_csv("summary_data/insurance_2012.csv",col_types = cols())
ins.17 <- read_csv("summary_data/insurance_2017.csv",col_types = cols())

ins.12$pct_ins <- with(ins.12, insured / total)
ins.17$pct_ins <- with(ins.17, insured / total)

ins.12.17 <- inner_join(ins.12,ins.17,by = ("GEOID"="GEOID"), suffix = c("12","17"))

ins.12.17$pct_ins_chg <- with(ins.12.17, pct_ins17 - pct_ins12)

pct_ins.12 <- with(ins.12, sum(insured) / sum(total)) # 0.8927705
pct_ins.17 <- with(ins.17, sum(insured) / sum(total)) # 0.9265638
chg <- pct_ins.17 - pct_ins.12

print(paste0("Percent Insured in 2012: ",as.pct(pct_ins.12),"%"))
print(paste0("Percent Insured in 2017: ",as.pct(pct_ins.17),"%"))
print(paste0("Percent Change: ",as.pct(chg),"%"))

write_csv(ins.12.17,"summary_data/insured_2012_2017.csv")

mhhi.12 <- read_csv("clean_tables/MHHI_2012.csv",col_types = cols())
mhhi.17 <- read_csv("clean_tables/MHHI_2017.csv",col_types = cols())
nm <- c("GEO_ID","MHHI")
ins.12.17.mhhi <- ins.12.17 %>% inner_join(mhhi.12[nm], by = c("GEOID"="GEO_ID")) %>%
  inner_join(mhhi.17[nm], by = c("GEOID"="GEO_ID"),suffix = c("12","17"))

write_csv(ins.12.17,"summary_data/insured_mhhi_2012_2017.csv")