#!/usr/bin/env Rscript

# ---------- Load R environment ----------
# Setup R error handling to go to stderr
options(show.error.messages=F, error=function() { cat(geterrmessage(), file=stderr()); q("no",1,F) } )

# Set proper locale
#loc <- Sys.setlocale("LC_MESSAGES", "en_US.UTF-8")
#loc <- Sys.setlocale(category="LC_ALL", locale="C")

# Set options
#options(encoding="UTF-8")
options(stringAsfactors=FALSE, useFancyQuotes=FALSE)

# Take in trailing command line arguments
args <- commandArgs(trailingOnly=TRUE)
if (length(args) < 2) {
	print("Error! No or not enough arguments given.")
	print("Usage: $0 feat_list.tsv heatmap.pdf")
	quit(save="no", status=1, runLast=FALSE)
}

# Load libraries
library(mixOmics)
library(ape)
library(pvclust)
library(dendextend)
library(cba)
library(phangorn)
library(gplots)

# Import Feature list
feat_list <- read.table(file=args[1], header=TRUE, quote="\"", sep="\t")

# Sample names
ketchup_samples <- colnames(feat_list)

# Sample classes: ketchup
ketchup <- as.factor(sapply(strsplit(as.character(ketchup_samples), "\\."), function(x) {
    nam <- x[1];
    nam;
}))

# Unique sample classes: ketchup
ketchup_names <- unique(ketchup)

# Define colors
ketchup_colors <- c("darkorange1","blue3","darkorange3","darkorange4","coral2","coral3","coral4","brown3")
ketchup_symbols <- c(0,16,1,2,5,6,7,10)

# Define samples colors
ketchup_samples_colors <- sapply(ketchup, function(x) { x <- ketchup_colors[which(x==ketchup_names)] } )
ketchup_samples_symbols <- sapply(ketchup, function(x) { x <- ketchup_symbols[which(x==ketchup_names)] } )

ncomp <- 5                        # Number of components
nfolds <- 5                       # Number of folds for cross-validation
nrepeat <- 10                     # Number of repeats for validation
keepx <- c(seq(10, 20, 10))       # The number of variables to test from the X data set

# Prepare data matrix
plsda_list <- as.data.frame(t(feat_list))
plsda_list[is.na(plsda_list)] <- 0
for (i in ncol(plsda_list)) {
        plsda_list[,i] <- as.numeric(plsda_list[,i])
}

# Perform sPLS-DA
model_splsda <- splsda(X=plsda_list, Y=ketchup, multilevel=NULL, ncomp=ncomp)

# Plot full (non-selected) feature matrix
pdf(args[2], encoding="ISOLatin1", pointsize=12, width=10, height=6, family="Helvetica")
par(mfrow=c(1,1), mar=c(4,4,4,1), oma=c(0,0,0,0), cex.axis=0.9, cex=0.8)
#model_cim <- cim(model_splsda, comp=1:ncomp, xlab="features", ylab="samples", margins=c(5, 14))
heatmap.2(scale(as.matrix(plsda_list)), scale="row", cexRow=1.2, cexCol=0.6,
          Rowv=as.dendrogram(hclust(dist(t(feat_list), method="euclidean"))),
          labRow=ketchup_samples, colRow=ketchup_samples_colors, col=bluered(16),
          tracecol=FALSE, key=TRUE, margins=c(0.5,16))
dev.off()


source("R/functions/get_score.r")

fn.si = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_sample_info_2_sle_lowDA.txt")
info = fread(fn.si, data.table=F)

fn.ge = file.path(PROJECT_DIR, "generated_data", "SLE", "SLE_ge_matrix_gene_sle_lowDA.txt")
dat = fread(fn.ge, data.table = F) %>%
  tibble::remove_rownames() %>% tibble::column_to_rownames("gene") %>%
  data.matrix()

pb.file = "PB_DC.M4.11_ge_sig.txt"
pb.label = "PB.DC"

fn.sig = file.path(PROJECT_DIR, "generated_data", "signatures", pb.file)
pb.genes = fread(fn.sig, header = F) %>% unlist(use.names=F)

gi = toupper(rownames(dat)) %in% toupper(pb.genes)
sum(gi)

df.pb.score = cbind(
                dplyr::select(info, SUBJECT, VISIT, CUMULATIVE_TIME, SAMPLE_NAME),
                data.frame(PB_score=get_score(dat[gi,]))
              )

fn.sig = file.path(PROJECT_DIR, "generated_data", "SLE",
                   sprintf("SLE_lowDA_%s_ge_sig_score.txt",pb.label))
fwrite(df.pb.score, fn.sig, sep="\t", quote=F)

df.pb.score.subj = df.pb.score %>%
  dplyr::select(SUBJECT, PB_score) %>%
  mutate(SUBJECT = factor(SUBJECT,
                          levels=unique(SUBJECT[order(as.numeric(sub("SLE-","",SUBJECT)))]))) %>%
  group_by(SUBJECT) %>%
  dplyr::summarise(PB_score_mean=mean(PB_score, na.rm=T)) %>%
  ungroup()

fn.sig.subj = file.path(PROJECT_DIR, "generated_data", "SLE",
                        sprintf("SLE_lowDA_%s_ge_sig_score_subjects.txt",pb.label))
fwrite(df.pb.score.subj, fn.sig.subj, sep="\t", quote=F)


## 1. Introduction to Data Visualization ##

library(readr)
life_expec <- read_csv("life_expec.csv")

## 4. Data Visualization and the Grammar of Graphics ##

ggplot(data = life_expec)

## 5. Mapping Variables to Axes ##

# ggplot(data = life_expec)
ggplot(data = life_expec,
  aes(x = Year, y = Avg_Life_Expec))

## 6. Adding Geometric Objects to Visualize Data Points ##

# ggplot(data = life_expec,
#  aes(x = Year, y = Avg_Life_Expec))
ggplot(data = life_expec,
  aes(x = Year, y = Avg_Life_Expec)) +
  geom_line()

## 7. Selecting Data for Visualization ##

life_expec_filter <- life_expec %>%
  filter(Race == "All Races" & Sex == "Both Sexes")

ggplot(data = life_expec_filter,
  aes(x = Year, y = Avg_Life_Expec)) +
  geom_line()

## 8. Adding Graph Titles and Changing Axis Labels ##

# ggplot(data = life_expec_filter,
#  aes(x = Year, y = Avg_Life_Expec)) +
#  geom_line()
ggplot(data = life_expec_filter,
  aes(x = Year, y = Avg_Life_Expec)) +
  geom_line() +
  labs(title = "United States Life Expectancy: 100 Years of Change", y = "Average Life Expectancy (Years)")

## 9. Refining Graph Aesthetics ##

# ggplot(data = life_expec_filter,
#  aes(x = Year, y = Avg_Life_Expec)) +
#  geom_line() +
#  labs(title = "United States Life Expectancy: 100 Years of Change", y = "Average Life Expectancy (Years)")
ggplot(data = life_expec_filter,
  aes(x = Year, y = Avg_Life_Expec)) +
  geom_line() +
  labs(title = "United States Life Expectancy: 100 Years of Change", y = "Average Life Expectancy (Years)") +
  theme(panel.background = element_rect(fill = "white"))

Data Analyst in R/Step 2 - Data Visualization in R/Data Visualization in R/1. Creating Line Graphs.r


#Usage:
#Rscript cell_classified_pseudotime.r num_dimension gene_array
library("monocle")
args <- commandArgs(trailingOnly=TRUE)
#print(args)
if(length(args)==0)
{
	print("Usage: Rscript cell_classified_pseudotime.r num_dimension gene_array")
}
HSMM <- readRDS("classified_cells.rds")
HSMM_myo <- reduceDimension(HSMM, max_components=as.numeric(args[1]))
HSMM_myo <- orderCells(HSMM_myo, reverse=FALSE)
selected_genes <- row.names(subset(fData(HSMM_myo),gene_short_name %in% args[2:length(args)]))
cds_subset <- HSMM_myo[selected_genes,]
print(plot_genes_in_pseudotime(cds_subset, color_by="CellType"))
ggsave("cell_classified_pseudotime_plot.png")
ggsave("cell_classified_pseudotime_plot.tiff", width = 7, height = 7,dpi=600)
dev.off()


context("data_dredge_regression")

library(magrittr)
library(mnmacros)
#library(testthat)

rm(list = ls())
set.seed(0)

# not enough columns
y1 <- rep(c("a", "b"), c(10,10))
expect_error(
  data.frame(y1, stringsAsFactors = F) %>% data_dredge_regression(),
  "data %>% ncol() >= 2 is not TRUE",
  fixed = T)

# not enough response columns
expect_error(
  data.frame(y1, y1, stringsAsFactors = F) %>% data_dredge_regression(),
  "response_column_count >= 1 is not TRUE",
  fixed = T)

# categorical predicts continuous
y2 <- c(rnorm(10), rnorm(10, mean = 2))
actual <- data.frame(y1, y2, stringsAsFactors = F) %>% data_dredge_regression()
expected <- data.frame(
  formula = c("y2 ~ y1"),
  best_pvalue = c(0.01135),
  adjusted_r_squared = c(0.26782),
  stringsAsFactors = F)
expect_equal(actual, expected, tolerance = 0.001)

# continuous predicts continuous
y3 <- c(rnorm(10, mean = 2), rnorm(10, mean = 4))
actual <- data.frame(y2, y3, stringsAsFactors = F) %>% data_dredge_regression()
expected <- data.frame(
  formula = c("y3 ~ y2", "y2 ~ y3"),
  best_pvalue = c(0.01400, 0.01400),
  adjusted_r_squared = c(0.25210, 0.25210),
  stringsAsFactors = F)
expect_equal(actual, expected, tolerance = 0.001)

# mixed case test
actual <-
  data.frame(y1, y2, y3, stringsAsFactors = F) %>%
  data_dredge_regression()
expected <- data.frame(
  formula = c("y2 ~ y1", "y3 ~ y1", "y3 ~ y2", "y2 ~ y3", "y3 ~ y1*y2"),
  best_pvalue = c(0.01135, 0, 0.01400, 0.01400, 0.00029),
  adjusted_r_squared = c(0.26782, 0.67155, 0.25210, 0.25210, 0.67321),
  stringsAsFactors = F)
expect_equal(actual, expected, tolerance = 0.001)

# perfect numeric continuous regression
y4 <- y3 + 1
actual <-
  data.frame(y3, y4, stringsAsFactors = F) %>%
  data_dredge_regression()
expect_equal(actual %>% nrow(), 0)

# perfect integer continuous regression
y5 <- 1:10
y6 <- 1:10 + 1 %>% as.integer()
actual <-
  data.frame(y5, y6, stringsAsFactors = F) %>%
  data_dredge_regression()
expect_equal(actual %>% nrow(), 0)

# perfect numeric ~ categorical regression
y7 <- c("q", "w", "e", "r", "t", "y", "u", "i", "o", "p")
actual <-
  data.frame(y5, y7, stringsAsFactors = F) %>%
  data_dredge_regression()
expect_equal(actual %>% nrow(), 0)

# perfect integer ~ categorical regression
actual <-
  data.frame(y6, y7, stringsAsFactors = F) %>%
  data_dredge_regression()
expect_equal(actual %>% nrow(), 0)


# -------------------------------
# --------- HOLDIAY DATA --------
# -------------------------------

# what holidays are important for beaches?
# Memorial Day, Labor Day, Independence Day, Cinco de Mayo, Father's Day, Summer Solstice
holidays <- read.csv("data/ExternalData/Holidays.csv", stringsAsFactors = T, header=T)

holidays$Date <- as.Date(holidays$Date, format="%m-%d-%Y")

# merge with beach_readings
beach_readings <- merge(beach_readings, holidays, by.x="Full_date", by.y="Date", all.x = TRUE)

# create "holiday or not holiday" indicator variable for each record
beach_readings$Holiday.Flag <- ifelse(!is.na(beach_readings$Holiday),1,0)

# create "days since last holiday" variable
## QUESTION - is this necessary or will a time series model be able to know this already?

sorted <- beach_readings[order(beach_readings$Client.ID, beach_readings$Full_date),]

count <- 1
first_event_flag <- 0
current_beach <- sorted$Client.ID[1]
for (i in 1:nrow(sorted)) {
  if (!identical(sorted$Client.ID[i],current_beach)) {
    count <- 1
    first_event_flag <- 0
  }
  if (first_event_flag == 0 && sorted$Holiday.Flag[i] == 0) {
    sorted$Days.Since.Last.Holiday[i] <- NA
  }
  else if (first_event_flag == 0 && sorted$Holiday.Flag[i] == 1) {
    first_event_flag <- 1
  }
  if (first_event_flag == 1) {
    if (sorted$Holiday.Flag[i] == 1) {
      sorted$Days.Since.Last.Holiday[i] <- 0
      count <- 1
    }
    else {
      sorted$Days.Since.Last.Holiday[i] <- count
      count <- count + 1
    }
  }
  current_beach <- sorted$Client.ID[i]
}

beach_readings <- sorted

# clean up workspace
rm(list=c("sorted"))

# clean up order
beach_readings <- beach_readings[order(-as.numeric(beach_readings$Full_date)), c(
  "Client.ID",  "Full_date", "Year", "Date",
  "Laboratory.ID", "Reading.1", "Reading.2",
  "Escherichia.coli", "Units", "Sample.Collection.Time",
  "Weekday", "Month", "Day",
  "Drek_Reading", "Drek_Prediction", "Drek_Worst_Swim_Status",
  "e_coli_geomean_actual_calculated", "elevated_levels_actual_calculated", "Drek_elevated_levels_predicted_calculated",
  "Water.Station", "Water.Temp.Min", "Water.Temp.Max","Water.Temp.Mean",
  "Turbidity.Min","Trubidity.Max", "Turbidity.Mean",
  "Transducer.Depth.Min","Transducer.Depth.Max", "Transducer.Depth.Mean",
  "Wave.Height.Min","Wave.Height.Max", "Wave.Height.Mean",
  "Wave.Period.Min","Wave.Period.Max","Wave.Period.Mean",
  "Weather.Station", "Air.Temp.Min","Air.Temp.Max","Air.Temp.Mean",
  "Wet.Bulb.Temp.Min","Wet.Bulb.Temp.Max","Wet.Bulb.Temp.Mean",
  "Humidity.Min","Humidity.Max","Humidity.Mean",
  "Rain.Intensity.Min","Rain.Intensity.Max","Rain.Intensity.Mean",
  "Interval.Rain.Min","Interval.Rain.Max","Interval.Rain.Mean",
  "Total.Rain.Min","Total.Rain.Max","Total.Rain.Mean",
  "Wind.Direction.Min","Wind.Direction.Max","Wind.Direction.Mean",
  "Wind.Speed.Min","Wind.Speed.Max","Wind.Speed.Mean",
  "Barometric.Pressure.Min","Barometric.Pressure.Max","Barometric.Pressure.Mean",
  "Solar.Radiation.Min","Solar.Radiation.Max","Solar.Radiation.Mean",
  "Holiday","Holiday.Flag","Days.Since.Last.Holiday"
)]


library(proto)

stack <- proto(expr = {
   l <- list()
   empty <- function(.) length(.$l) == 0
   push <- function(., x)
   {
      .$l <- c(list(x), .$l)
      print(.$l)
      invisible()
   }
   pop <- function(.)
   {
      if(.$empty()) stop("can't pop from an empty list")
      .$l[[1]] <- NULL
      print(.$l)
      invisible()
   }
})

stack$empty()
# [1] TRUE
stack$push(3)
# [[1]]
# [1] 3
stack$push("abc")
# [[1]]
# [1] "abc"
# [[2]]
# [1] 3
stack$push(matrix(1:6, nrow=2))
# [[1]]
#      [,1] [,2] [,3]
# [1,]    1    3    5
# [2,]    2    4    6
# [[2]]
# [1] "abc"
# [[3]]
# [1] 3
stack$empty()
# [1] FALSE
stack$pop()
# [[1]]
[1] "abc"
# [[2]]
# [1] 3
stack$pop()
# [[1]]
# [1] 3
stack$pop()
# list()
stack$pop()
# Error in get("pop", env = stack, inherits = TRUE)(stack, ...) :
#   can't pop from an empty list


#'---
#'title: "1.1 MEG performance"
#'author: "Denis A. Engemann"
#'date: "8/3/2019"
#'output:
#'    html_document:
#'        code_folding:
#'            hide
#'    md_document:
#'        variant:
#'            markdown_github
#'---

# seed!
set.seed(42)

#+
library(ggplot2)
library(ggbeeswarm)
library(ggrepel)
library(pmr)

# imports `color_cats` and `get_label_from_marker`
source('./utils.r')
source('./config.r')

#' We'll first set up the data and configure plotting.
#' Also, in this analysis we'll focus on the scores, not the predictions.

#+ setup
DUMMY <- './data/age_stacked_dummy.csv'
PREDICTIONS <- './data/age_stacked_predictions_megglobal.csv'
SCORES <- './data/age_stacked_scores_megglobal.csv'
IMPORTANCES <- './viz_intermediate_files/age_stacked_importance_5_global.csv'
IMPORTANCES2 <- './viz_intermediate_files/age_stacked_importance_8.csv'

data_pred_wide <- read.csv(PREDICTIONS)
data_scores_wide <- read.csv(SCORES)

data_dummy <- read.csv(DUMMY)
data_dummy$MAE <- -data_dummy$MAE
data_scores_wide$chance <- data_dummy$MAE

names(data_scores_wide) <- fix_column_names(names(data_scores_wide))
names(data_pred_wide) <- fix_column_names(names(data_pred_wide))

# Move to long format.
reshape_names <- names(data_scores_wide)[!names(data_scores_wide) %in%
                                         c('repeat_', 'repeat_idx')]
data_scores <- reshape(data = data_scores_wide,
                       direction = 'long',
                       varying = reshape_names,  # values
                       v.names = 'MAE',
                       times = factor(reshape_names), # keys
                       timevar = 'marker',
                       new.row.names = NULL)

data_scores['is_meg'] <- grepl('MEG', data_scores$marker)
#'Remap the names to be more compact for plotting.

# geom_beeswarm(alpha=0.4, show.legend = F, cex=0.7, size = 1.5,
#               groupOnX=FALSE)
#+ stack_labels
stacked_keys <- c(
  "MEG_handcrafted",
  "MEG_powers",
  "MEG_powers_cross_powers",
  "MEG_powers_cross_powers_handrafted",
  "MEG_cat_powers_cross_powers_correlation",
  "MEG_cat_powers_cross_powers_correlation_handcrafted",
  "MEG_cross_powers_correlation",
  "MEG_powers_cross_powers_correlation",
  "MEG_all"
)

stacked_labels <- c(
    'O',  # other
    'P',  # Powers (cat powers + single band powers + single band envelopes)
    'P~XP[f]',  # Powers + Cross Powers
    'P~XP[f]~O',  # . + Others
    'P[cat]~XP[f]~C[f]', # cat powers (power  + diag) + cross powers + Correlations
    'P[cat]~XP[f]~C[f]~O',  # . + O
    'XP[f]~C[f]', # Cross powers + correlation
    'P~XP[f]~C[f]', # Pwoers + Cross Powers + Corr
    'P~XP[f]~C[f]~O'  # . + O
)

#' Let's first generate some statistical summaries

data_all_scores <- data_scores_wide[,c(stacked_keys, "chance")]

data_scores_meg <- data_all_scores

#+ fig1b
color_breaks <- c('Full', 'Combined Source', 'Source Activity', 'Source Connectivity', 'Sensor Mixed', 'Chance')
color_values <-setNames(
  with(color_cats, c(black, orange, vermillon, blue, `sky blue`, gray)),
  color_breaks
)
color_labels <- tolower(c(color_breaks[1:4], "sensor", "chance"))

#+ subset_meg_stack

# XXX idea, rank statistics
sub_sel <- c(1, 2, 7, 8, 9)
sel_meg <- c(stacked_keys[sub_sel], "chance")
model_ranking <- do.call(
  rbind,
  lapply(seq_along(data_all_scores[,1]),
         function(ii) {
          out <- data.frame(
            rank = rank(data_all_scores[ii,sel_meg]),
            model = names(data_all_scores[,sel_meg]),
            fold = ii)
          rownames(out) <- NULL
          return(out)
        }))

model_ranking$family <- 'Combined Source'
model_ranking$family[
  model_ranking$model == 'MEG_powers'] <- 'Source Activity'
model_ranking$family[
  model_ranking$model == 'MEG_cross_powers_correlation'] <- 'Source Connectivity'
model_ranking$family[
  model_ranking$model == 'MEG_handcrafted'] <- 'Sensor Mixed'
model_ranking$family[
  model_ranking$model == 'MEG_all'] <- 'Full'
model_ranking$family[
  model_ranking$model == 'chance'] <- 'Chance'

model_ranking$family <- factor(model_ranking$family)

model_ranking$model <- factor(
  model_ranking$model,
  c("chance", stacked_keys[sub_sel]),
  c("Chance", stacked_labels[sub_sel]))

fig_rank_box <- ggplot(data = model_ranking,
       mapping = aes(x = rank, y = reorder(family, rank, mean), color = family, fill = family)) +
geom_boxplot(show.legend = T, alpha = 0.3) +
geom_jitter(show.legend = F, size=1.5, width = 0.12, alpha=0.5) +
scale_x_continuous(breaks = 1:7) +
scale_color_manual(values = color_values,
                   labels = color_breaks,
                   breaks = color_breaks, name = NULL) +
guides(color = guide_legend(nrow = 2, title.position = 'top'),
       fill = guide_legend(nrow = 2)) +
scale_fill_manual(values = color_values,
                  labels = color_breaks,
                  breaks = color_breaks, name = NULL) +
labs(x = 'Ranking across CV testing-splits', y = 'Stacking Models') +
theme(
      axis.text.y = element_blank(),
      legend.position = 'top',
      legend.justification = 'left',
      legend.text.align = 0)
print(fig_rank_box)

model_ranking$family <- factor(
  model_ranking$family,
  levels = rev(c("Chance", "Sensor Mixed", "Source Connectivity", "Source Activity", "Combined Source", "Full")),
  labels = rev(
      c("Chance", "Sensor\nMixed", "Source\nConnectivity", "Source\nActivity", "Combined\nSource", "Full")))

fname <- "./figures/elements_fig4_stacking_meg_supp_rank_box."
ggsave(paste0(fname, "pdf"),
       width = save_width, height = save_height, useDingbats = F)
embedFonts(file = paste0(fname, "pdf"), outfile = paste0(fname, "pdf"))
ggsave(paste0(fname, "png"),
       width = save_width, height = save_height, dpi = 300)
knitr::include_graphics(paste0(fname, "png"), dpi = 200)

##

rankmat <- data.frame(
  do.call(
    cbind,
    with(model_ranking,
      by(model_ranking, family, function(x) x$rank))))
rankmat$n <- 1
rank_ds <- destat(rankmat)
rownames(rank_ds$pair) <- names(rankmat)[-ncol(rankmat)]
colnames(rank_ds$pair) <- names(rankmat)[-ncol(rankmat)]
rownames(rank_ds$mar) <- names(rankmat)[-ncol(rankmat)]
colnames(rank_ds$mar) <- names(rankmat)[-ncol(rankmat)]

print(rank_ds$pair)
print(rank_ds$mar)

get_mat <- function(mat) {
  mat <- data.frame(mat)
  colnames(mat) <- levels(model_ranking$family)
  rownames(mat) <- levels(model_ranking$family)

  mat_long <- do.call(rbind, lapply(colnames(mat), function(x) {
    data.frame(count = mat[, x], x = x, y = rownames(mat))
  }))
  mat_long$x <- factor(mat_long$x, levels = colnames(mat))
  mat_long$y <- factor(mat_long$y, levels = colnames(mat))
  mat_long
}

fig_rank_mat_pair <- ggplot(data = get_mat(rank_ds$pair),
                            mapping = aes(x = x, y = y, fill = count, label = count)) +
  geom_tile() +
  scale_fill_viridis_c(begin = 0.01, end = 0.99) +
  theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
  geom_text(color = 'white', size = 8) +
  labs(x = element_blank(), y = element_blank())
print(fig_rank_mat_pair)

fname <- "./figures/elements_fig4_stacking_meg_supp_rank_mat_pair."
ggsave(paste0(fname, "pdf"),
       width = save_width, height = save_height, useDingbats = F)
embedFonts(file = paste0(fname, "pdf"), outfile = paste0(fname, "pdf"))
ggsave(paste0(fname, "png"),
       width = save_width, height = save_height, dpi = 300)
knitr::include_graphics(paste0(fname, "png"), dpi = 200)

summarize_table <- function(data){
    data <- rbind(
      apply(data, FUN = mean, 2),
      apply(data, FUN = sd, 2),
      apply(data, FUN = function(x) quantile(x, c(0.025, 0.975)), 2)
    )

    rownames(data) <- c("M", "SD", rownames(data)[c(3, 4)])
    data <- round(t(data), 3)
    data <- data.frame(model = rownames(data), data)
    rownames(data) <- NULL
    return(data)
}

data_all_summary <- summarize_table(data_all_scores)

knitr:::kable(data_all_summary)

fmt1 <- "$M=%0.2f,SD=%0.2f,P_{2.5,97.5}=[%0.2f,%0.2f]$"
formats1 <- vector(mode="character", length=nrow(data_all_summary))
for(ii in seq_along(formats1)){
    this <- paste(
      data_all_summary$model[ii],
      do.call(sprintf,
            c(list(fmt1),
              with(data_all_summary[ii,],
                   c(M, SD, X2.5., X97.5.)))),
      sep = '\t')
    formats1[[ii]] <- this
}
writeLines(
  formats1,
  './viz_intermediate_files/all_scores_meg_summary.txt'
)

data_dummy_diff <- data_all_scores - data_all_scores$chance

data_dummy_diff_summary <- summarize_table(data_dummy_diff)

data_dummy_diff_summary$Pr <- t(t(apply(data_dummy_diff, FUN = function(x) sum(x < 0), 2)))

knitr:::kable(data_dummy_diff_summary)

fmt2 <- "$Pr_{<Chance}=%0.2f%%,M=%0.2f,SD=%0.2f,P_{2.5,97.5}=[%0.2f,%0.2f]$"
formats2 <- vector(mode="character", length=nrow(data_dummy_diff_summary))
for(ii in seq_along(formats2)){
    this <- paste(
      data_dummy_diff_summary$model[ii],
      do.call(sprintf,
            c(list(fmt2),
              with(data_dummy_diff_summary[ii,],  c(Pr, M, SD, X2.5., X97.5.)))),
      sep = '\t')
    formats2[[ii]] <- this
}
writeLines(
  formats2,
  './viz_intermediate_files/all_scores_dummy_diff_meg_summary.txt'
)

#+ subset_meg
data_scores$prediction <- factor(ifelse(
  data_scores$marker %in% stacked_keys, 'stacked', 'linear'))

# For now ignore MRI
data_scores <- subset(data_scores, is_meg == T)
data_scores$marker <- factor(data_scores$marker)
data_scores$repeat_idx <- factor(data_scores$repeat_idx)

#'Now we compute best results, we need to aggregate by fold idx.

#+ agg_by_fold
data_scores_cv <- by(data_scores,
                     list(data_scores$repeat_idx,
                          data_scores$marker),
                     function(x){
                       data.frame(
                         marker = unique(x$marker),
                         repeat_idx = unique(x$repeat_idx),
                         cv_mean = mean(x$MAE),
                         cv_std = sd(x$MAE))
                     })
data_scores_cv <- do.call(rbind, data_scores_cv)

data_scores_cv$prediction <- factor(ifelse(
  data_scores_cv$marker %in% stacked_keys, 'stacked', 'linear'))

best_cv_mean_linear <- min(subset(data_scores_cv,
                                  prediction == 'linear')$cv_mean)
best_cv_mean_stacked <- min(subset(data_scores_cv,
                                   prediction == 'stacked')$cv_mean)

#'We are ready to plot the error distributions.

#+ fig1a
n_models <- by(data_scores,
               data_scores$prediction,
               function(x) data.frame(
                 marker = unique(x$prediction),
                 n_models =  length(unique(x$marker))))
n_models <- do.call(rbind, n_models)

labels_fig1 <- c(
  sprintf("%s (n=%d)", n_models[2,1], n_models[2,]$n_models),
  sprintf("%s (n=%d)", n_models[1, 1], n_models[1,]$n_models)
)

labels_fig1 <- setNames(labels_fig1, c('stacked', 'linear'))
colors_fig1 <- setNames(with(color_cats, c(black, `blueish green`)),
                        c('stacked', 'linear'))
data_scores$prediction <- relevel(data_scores$prediction, ref = "stacked")

fig1a <- ggplot(data = data_scores,
                mapping = aes(x = MAE,
                              color = prediction, fill = prediction)) +
  stat_density(trim = T, geom = 'area', size = 1, alpha = 0.3) +
  scale_x_log10(breaks = seq(0, 60, 5)) +
  scale_color_manual(
    values = colors_fig1,
    labels = labels_fig1) +
  scale_fill_manual(
    values = colors_fig1,
    labels = labels_fig1) +
  guides(
    color = guide_legend(nrow = 1, title.position = "left")) +
  theme(legend.position = c(0.4, 0.99)) +
  xlab("MAE (years)") +
  ylab("Density") +
  annotate(geom = "text", x = DUMMY_ERROR - 0.5, y = 5,
           label =  "predicting~bar(y)",
           parse = T,
           angle =90, size = annotate_text_size) +
  geom_vline(xintercept=DUMMY_ERROR, color = "black", linetype = 'dashed') +
  geom_rug(alpha = 0.5, mapping = aes(color = prediction, x = cv_mean),
           data = data_scores_cv)
print(fig1a)

fname <- "./figures/elements_fig1_error_distro."
ggsave(paste0(fname, "pdf"),
       width = save_width, height = save_height, useDingbats = F)
embedFonts(file = paste0(fname, "pdf"), outfile = paste0(fname, "pdf"))
ggsave(paste0(fname, "png"),
       width = save_width, height = save_height,
       dpi = 300)
knitr::include_graphics(paste0(fname, "png"), dpi = 200)

#'Remap the names to be more compact for plotting.

#'We can see that, across models, stacking stablizes and improves the results.
#'
#'Let's now look at the most interesting stacked models.
#'
#'However, we should first add some more description to the data.

#+ subset_meg_stack
data_meg_stacked <- subset(data_scores, prediction == 'stacked')

data_meg_stacked$family <- 'Combined Source'
data_meg_stacked$family[
  data_meg_stacked$marker == 'MEG_powers'] <- 'Source Activity'
data_meg_stacked$family[
  data_meg_stacked$marker == 'MEG_cross_powers_correlation'] <- 'Source Connectivity'
data_meg_stacked$family[
  data_meg_stacked$marker == 'MEG_handcrafted'] <- 'Sensor Mixed'
data_meg_stacked$family[
  data_meg_stacked$marker == 'MEG_all'] <- 'Full'

data_meg_stacked$family <- factor(data_meg_stacked$family)

data_meg_stacked$marker <- factor(
  data_meg_stacked$marker,
  stacked_keys,
  stacked_labels)

#+ fig1b

color_breaks <- c('Full', 'Combined Source',
                  'Source Activity', 'Source Connectivity',
                  'Sensor Mixed')
color_values <-setNames(
  with(color_cats, c(black, orange, vermillon, blue, `sky blue`)),
  color_breaks
)
color_labels <- color_breaks

sel_idx <- data_meg_stacked$marker %in% c(
  "O",
  "P",
  "XP[f]~C[f]",
  "P~XP[f]~C[f]",
  "P~XP[f]~C[f]~O"
)

if(FALSE){  # toggle to select everything
  sel_idx <- rep(T, nrow(data_meg_stacked))
}

data_meg_stacked_sel <- data_meg_stacked[sel_idx,]
data_meg_stacked_sel$marker <- factor(data_meg_stacked_sel$marker)
sort_idx <- order(by(data_meg_stacked_sel,
                     data_meg_stacked_sel$marker,
                     function(x) mean(x$MAE)))

fig1b <- ggplot(
  data = data_meg_stacked_sel,
  mapping = aes(y = MAE, x = reorder(marker, MAE, mean),
                color = family, fill = family)) +
  coord_flip() +
  geom_hline(yintercept=DUMMY_ERROR, color = "black", linetype = 'dashed') +
  geom_boxplot(show.legend = T, outlier.shape = NA, alpha = 0.5, size = 0.7) +
  stat_summary(geom = 'text',
               mapping = aes(label  = sprintf("%1.1f", ..y..)),
               fun.y= mean, size = 3.2, show.legend = FALSE,
               position = position_nudge(x=-0.49)) +
  geom_beeswarm(alpha=0.3, show.legend = F, size = 2.4) +
  guides(
    color = guide_legend(nrow = 3, title.position = "top")) +
  ylab("MAE (years)") +
  xlab("MEG stacking models") +
  annotate(geom = "text", y = DUMMY_ERROR - 0.3, x = 2.5,
           label =  "predicting~bar(y)",
           parse = T,
           angle = 90, size = annotate_text_size) +
  scale_color_manual(values = color_values,
                     labels = color_labels,
                     breaks = color_breaks, name = NULL) +
  scale_fill_manual(values = color_values,
                    labels = color_labels,
                    breaks = color_breaks, name = NULL) +
  guides(color = guide_legend(nrow = 2, title.position = 'top'),
         fill = guide_legend(nrow = 2)) +
  scale_y_continuous(breaks = seq(3, 20, 1)) +
  theme(
        axis.text.y = element_blank(),
        legend.position = 'top',
        legend.justification = 'left',
        legend.text.align = 0)
print(fig1b)

fname <- "./figures/elements_fig1_stacking_models."
ggsave(paste0(fname, "pdf"),
       width = save_width, height = save_height, useDingbats = F)
embedFonts(file = paste0(fname, "pdf"), outfile = paste0(fname, "pdf"))
ggsave(paste0(fname, "png"),
       width = save_width, height = save_height,
       dpi = 300)
knitr::include_graphics(paste0(fname, "png"), dpi = 200)

#'Now we investigate variable importance. We need to do some data massaging
#'in order to have everyhing in a neat structure.

#+ process_importance
stack_models <- c(
    'MEG-all-no-diag',
    'MEG all'
)

importance_methods <- c(
  'permutation',
  'mdi',
  'permutation_in'
)

# we'll expand the grid of options
importance_params <- expand.grid(stack_models, importance_methods)

data_importance <- read.csv(IMPORTANCES)
data_importance <- subset(data_importance, stack_model  == 'MEG all')

data_importance_perm <- subset(data_importance, imp_metric == 'permutation')
data_importance_mdi <- subset(data_importance, imp_metric == 'mdi')

data_importance_perm_in <- read.csv(IMPORTANCES2)
data_importance_perm_in <- subset(data_importance_perm_in, stack_model  == 'MEG all')

get_importance <- function(dat, data_scores = NULL) {

  # we have 1000 trees +the mean importance
  dat <- dat[, colSums(is.na(dat)) == 0]
  names(dat) <- fix_column_names(names(dat))
  # reshape
  stack_names <- Filter(function(x)!x %in% c(
                        "repeat_", "fold_idx",
                        "imp_metric", "mod_type", "index",
                        "stack_model", "X"), names(dat))
  dat <- reshape(
    data = dat, direction = "long", varying = stack_names,
    v.names = "importance", timevar = "marker", times = stack_names)
  dat$marker <- factor(dat$marker)
  dat$importance <- unlist(dat$importance)
  # prepare packaging output: 1) average importance, 2) linear prediction
  out <- data.frame(dat)
  out['stack_model'] <- unique(dat$stack_model)
  out['method'] <- unique(dat$mod_type)

  # make sure to only contrast with linear fits
  # and relevel factor after subsetting
  # XXX
  if(!is.null(data_scores)){
    print('Found scores. Attaching individual marker performance.\n')
    data_scores_lin <- subset(data_scores, prediction == 'linear')
    data_scores_lin$marker <- as.character(data_scores_lin$marker)
    # order by out marker
    out$marker  <- as.character(out$marker)
    # XXX by may not guarantee order ...
    unique_marker <- c()
    for (marker in out$marker){
      if(!marker %in% unique_marker){
        unique_marker <- c(unique_marker, marker)
      }
    }
    data_scores_lin <- do.call(rbind,
      lapply(unique_marker,
             function(x) {
               dd <- data_scores_lin[data_scores_lin$marker == x, c("MAE", "marker")]
               dd$marker <- x
               names(dd) <- c("cv_score", "marker")
               return(dd)
             })
    )
    stopifnot(out$marker == data_scores_lin$marker)
    out$cv_score <- data_scores_lin$cv_score
  }
  return(out)
}

importance_results_mdi <- get_importance(data_importance_mdi, data_scores)
importance_results_mdi$method <- 'mdi'
importance_results_perm <- get_importance(data_importance_perm, data_scores)
importance_results_perm$method <- 'permutation'

importance_results_perm2 <- get_importance(data_importance_perm_in)
importance_results_perm2$method <- 'permutation_in'

importance_results <- rbind(importance_results_mdi, importance_results_perm)

#+ enrich_importance_info

get_family_from_marker <- function(marker) {
  family <- rep('sensor mixed', length(marker))
  family[grepl('diag', marker)] <- 'source activity'
  family[grepl('corr', marker)] <- 'source connectivity'
  family[grepl('cross', marker)] <- 'source connectivity'
  return(factor(family))
}

get_variant_from_marker <- function(marker) {
  variant <- rep('base', length(marker))
  variant[grepl('power', marker)] <- 'signal'
  variant[grepl('envelope', marker)] <- 'envelope'
  variant[grepl('1_f', marker)] <- '1/f~slope'
  variant[grepl('MEG_aud', marker)] <- 'ERF~lat'
  variant[grepl('MEG_vis', marker)] <- 'ERF~lat'
  variant[grepl('MEG_alpha_peak', marker)] <- 'alpha~peak'

  return(factor(variant))
}

importance_results$family <- get_family_from_marker(importance_results$marker)
importance_results$variant <- get_variant_from_marker(importance_results$marker)

importance_results$marker_label <- get_label_from_marker(
  importance_results$marker)

importance_results$stack_model <- sub(
  "MEG all", "MEG_all", importance_results$stack_model)

importance_results_perm2$family <- get_family_from_marker(importance_results_perm2$marker)
importance_results_perm2$variant <- get_variant_from_marker(importance_results_perm2$marker)

importance_results_perm2$marker_label <- get_label_from_marker(
  importance_results_perm2$marker)

importance_results_perm2$stack_model <- sub(
  "MEG all", "MEG_all", importance_results_perm2$stack_model)

#' We are ready to plot our importance results.

#+ fig1c
color_labels <- c('source activity', 'source connectivity', 'sensor mixed')
color_breaks <- color_labels

color_values <-setNames(
  with(color_cats, c(vermillon, blue, `sky blue`)),
  color_breaks
)

importance_results$variant <- factor(importance_results$variant,
  levels = c("signal",  "envelope", "1/f~slope", "alpha~peak", "ERF~lat")
)

shape_breaks <- levels(importance_results$variant)
shape_values <- setNames(
  c(17, 25, 21, 22, 23),
  shape_breaks
)

method <- 'mdi'
stack_model <- 'MEG_all'

# lets dump the most important markers
percent_rank <- function(x) trunc(rank(x)) / length(x)
sub_data_agg <- aggregate(cbind(importance,cv_score) ~
                          marker + family + variant + marker_label * method,
                          importance_results, FUN = mean)

sub_data_agg2 <- aggregate(importance ~
                           marker + family + variant + marker_label * method,
                           importance_results_perm2, FUN = mean)

sub_data_agg2 <- merge(sub_data_agg2,
                       sub_data_agg[1:62,c('cv_score', 'marker')],
                       by = "marker", sort = F)

sub_data_agg <- rbind(sub_data_agg, sub_data_agg2)

# Write out in-sample permutation importance.

imp_table_sel <- c(2, 1, 3, 4, 6, 7)

write.csv(
  sub_data_agg2[order(percent_rank(sub_data_agg2$importance),
                      decreasing  = T),][1:10,imp_table_sel],
  file = paste0(paste('./viz_intermediate_files/importances', method, stack_model, sep = '_'),
                '.csv'))

writeLines(knitr::kable(
  sub_data_agg2[order(percent_rank(sub_data_agg2$importance),
                      decreasing  = T),][1:10,c(2, 1, 3, 4, 6, 7)],
  format = "latex"),
  "./viz_intermediate_files/importance_table.tex"
)

make_fig1c <- function(data){

  fig <- ggplot(
    data = data,
    mapping = aes(x = importance,
                  y = cv_score,
                  color = family,
                  fill = family,
                  shape = variant)) +

    geom_point(size = 3) +
    scale_shape_manual(
      values = shape_values,
      breaks = shape_breaks,
      labels = parse(text = shape_breaks),
      name = "input/feature") +
    scale_fill_manual(
      values = alpha(color_values, 0.2),
      labels = color_labels,
      breaks = color_breaks) +
    scale_color_manual(
      values = color_values,
      labels = color_labels,
      breaks = color_breaks) +
    guides(
      fill = F,
      color = guide_legend(
        nrow = 5, title.position = "top", order = 1),
      shape = guide_legend(
        nrow = 3, title.position = "top", order = 2)) +
    theme(
          legend.position = c(-0.1, 0.08),
          legend.justification = 'left',
          legend.box = "horizontal",
          legend.direction = 'horizontal') +
    scale_y_log10(breaks = seq(0, 50, 5)) +
    scale_x_log10(labels = function(x) format(x, scientific = FALSE)) +
    ylab("MAE (years)") +
    geom_label_repel(
      data = subset(data, percent_rank(data$importance) >= .9),
      aes(label = marker_label),
      parse = T,
      fill = 'white',
      force = 2,
      show.legend = F,
      segment.alpha = 0.4,
      box.padding = unit(0.35, "lines"),
      point.padding = unit(0.3, "lines")
    )
  return(fig)
}

for(method in importance_methods){
  fig <- make_fig1c(sub_data_agg[sub_data_agg$method == method,])

  if(method == "permutation"){
    fig <- fig + xlab("Variable importance (MAE)") +
      scale_x_log10(
        limits = c(0.0001, 1.1),
        breaks = c(0.0001, 0.001, 0.01, 0.1, 1),
        labels = function(x) format(x, scientific = FALSE))
  }else if(method == "permutation_in"){
    fig <- fig + xlab("Variable importance (MAE)") +
      scale_x_log10(
        labels = function(x) format(x, scientific = FALSE))
  }else if (method == 'mdi'){
    fig <- fig + xlab("Variable importance (%)") +
      scale_x_log10(labels = function(x) format(x * 1e2, scientific = FALSE))
  }

  print(fig)
  fname <- paste0("./figures/elements_fig1c_importance",
                  "_", method,
                  "_", stack_model, "_", method, ".")
  ggsave(paste0(fname, "pdf"), plot = fig,
         width = save_width, height = save_height, useDingbats = F)
  embedFonts(file = paste0(fname, "pdf"), outfile = paste0(fname, "pdf"))
  ggsave(paste0(fname, "png"), width = save_width, height = save_height,
         dpi = 300)
  knitr::include_graphics(paste0(fname, "png"), dpi = 200)
}

mdi <- subset(sub_data_agg, method == 'mdi')
perm <- subset(sub_data_agg, method == 'permutation')
perm2 <- subset(sub_data_agg, method == 'permutation_in')

cor1 <- cor.test(mdi[order(mdi$marker),]$importance,
                 perm[order(perm$marker),]$importance, method = 'spearman')
cor2 <- cor.test(mdi[order(mdi$marker),]$importance,
                 perm2[order(perm2$marker),]$importance, method = 'spearman')
cor3 <- cor.test(perm[order(perm$marker),]$importance,
                 perm2[order(perm2$marker),]$importance, method = 'spearman')

cor.details <- function(x){
  data.frame(
    p.value = ifelse(x$p.value == 0,
                     "2.2e-16",
                     sprintf("%e", x$p.value)),
    r2 = round(x$estimate ^ 2, 3),
    rho = round(x$estimate, 3),
    name = x$data.name
  )
}
cor.output <- do.call(rbind, lapply(list(cor1, cor2, cor3), cor.details))
write.csv(cor.output, "./viz_intermediate_files/corr_results_importance.csv")

#'Time to take a look at the partial dependencies.
#'We'll also enrich the data with descriptors for plotting, as above.

#+ read_dependence
OUT_DEPENDENCE_1D <- './data/age_stacked_dependence_model-full-1d.csv'
data_dependence_1d <- read.csv(OUT_DEPENDENCE_1D)
data_dependence_1d$marker <- factor(data_dependence_1d$marker)
data_dependence_1d$model_type <- factor(data_dependence_1d$model_type)
data_dependence_1d$model <- factor(data_dependence_1d$model)

#+ fig1d
data_dependence_1d$marker <- fix_marker_names(data_dependence_1d$marker)
data_dependence_1d$family <- get_family_from_marker(data_dependence_1d$marker)
data_dependence_1d$variant <- get_variant_from_marker(data_dependence_1d$marker)
data_dependence_1d$marker_label <- get_label_from_marker(
  data_dependence_1d$marker)

color_breaks_1d <- color_breaks[1:2]
color_labels_1d <- color_breaks[1:2]
color_values_1d <-setNames(
  with(color_cats, c(vermillon, blue)),
  color_breaks_1d
)

data_sel <- subset(data_dependence_1d,
  model_type == 'rf_msqrt' & model == 'MEG all')

data_sel_max <- aggregate(. ~ marker * family * variant * marker_label,
                          data = data_sel, FUN = max)

fig1d <- ggplot(data = data_sel,
       mapping = aes(x = value,  y = pred,
                     group = marker, color = family,
                     linetype = variant)) +
  geom_line(size = 1) +
  xlab('Input age (years)') +
  ylab('Age prediciton (years)') +
  scale_color_manual(
    values = color_values_1d,
    labels = color_labels_1d,
    breaks = color_breaks_1d) +

  guides(
    color = guide_legend(
      nrow = 4, title.position = "top", order = 1),
    linetype = guide_legend(
      title = 'input', nrow = 4, title.position = "top", order = 2))+
    theme(
      legend.position = c(0.01, 0.65),
      legend.justification = 'left',
      legend.box = "vertical",
      ) +
  geom_label_repel(
    data = data_sel_max,
    aes(label = marker_label),
    parse = T,
    force = 2,
    show.legend = F,
    segment.alpha = 0.4,
    box.padding = unit(0.35, "lines"),
    point.padding = unit(0.3, "lines")
  )
print(fig1d)

fname <- "./figures/elements_fig1d_dependence."
ggsave(paste0(fname, "pdf"), width = save_width,
       height = save_height, useDingbats = F)
embedFonts(file = paste0(fname, "pdf"), outfile = paste0(fname, "pdf"))
ggsave(paste0(fname, "png"), width = save_width,
       height = save_height, dpi = 300)
knitr::include_graphics(paste0(fname, "png"), dpi = 200)

#' ## Session info

#+ session_info
print(sessionInfo())


library(tidyr)
library(ggplot2)

source("./config.r")

annotate_text_size <- 7
##############################################################################
# Experiment 1 data

noise_exp <- read.csv("./outputs/simuls/individual_spatial/scores.csv",
                      nrows = 5, header = F)
for  (ii in c(2, 3, 4, 5, 1)){
  noise_exp[ii,] <- noise_exp[ii,] / noise_exp[1,]
}
noise_exp <- noise_exp[2:5,] %>%
  gather(key = "estimator", value = "score")

estimator_levels <- c("upper", "logdiag", "SPoC", "Riemann")
estimator <- estimator_levels %>% factor(levels = estimator_levels)
noise_exp$estimator <- rep(estimator, times = 10)

noises <- read.csv("./outputs/simuls/individual_spatial/noises_A.csv", header = F)
noise_exp$xaxis <- rep(noises[["V1"]], each = 4)

color_cats <- c(
  "#56B4E9",# sky blue
  "#009D79",# blueish green
  "#E36C2F",  #vermillon
  "#EEA535"  # orange
  # "#F0E442", #yellow
  # "#0072B2", #blue
  # "#CC79A7" #violet
)

ggplot(
  data = noise_exp %>% subset(estimator != "chance"),
  mapping = aes(y = score, x = xaxis, group = estimator,
                color = estimator)) +
  geom_line(size = 1.5, alpha = 0.8) +
  geom_point(fill = "white", size = 4, shape = 21) +
  my_theme +
  scale_y_continuous(limits = c(0, 1.10), breaks = seq(0, 1, 0.25)) +
  scale_x_log10(breaks =  10^(-10:10),
                minor_breaks = rep(1:9, 21) * (10 ^ rep(-10:10, each=9))) +
  scale_color_manual(values = color_cats, name = NULL) +
  geom_hline(yintercept = 1, color = "black", linetype = "dotted",
             size = 1) +
  annotate(geom = "text", x = 0.01, y = 1.05, label = "chance level",
           size = annotate_text_size) +
  labs(x = expression(sigma),
       y = "Normalized MAE") +
  theme(text = element_text(family = "Helvetica", size = 18),
        legend.position = "top", legend.title = element_text(size = 16))

fname <- "./outputs/fig_1c_individual_A_loglinear"
ggsave(paste0(fname, ".png"), width = 5, height = 5, dpi = 300)
ggsave(paste0(fname, ".pdf"), width = 5, height = 5, dpi = 300,
  useDingbats = F)
embedFonts(file = paste0(fname, ".pdf"), outfile = paste0(fname, ".pdf"))

##############################################################################
# Experiment 2 data

noise_exp <- read.csv("./outputs/simuls/individual_spatial/scores_powers.csv",
                      nrows = 5, header = F)
for  (ii in c(2, 3, 4, 5, 1)){
  noise_exp[ii,] <- noise_exp[ii,] / noise_exp[1,]
}
noise_exp <- noise_exp[2:5,] %>%
  gather(key = "estimator", value = "score")

estimator_levels <- c("upper", "diag", "SPoC", "Riemann")
estimator <- estimator_levels %>% factor(levels = estimator_levels)
noise_exp$estimator <- rep(estimator, times = 10)

noises <- read.csv("./outputs/simuls/individual_spatial/noises_A.csv", header = F)
noise_exp$xaxis <- rep(noises[["V1"]], each = 4)

color_cats <- c(
  "#56B4E9",# sky blue
  "#009D79",# blueish green
  "#E36C2F",  #vermillon
  "#EEA535"  # orange
  # "#F0E442", #yellow
  # "#0072B2", #blue
  # "#CC79A7" #violet
)

ggplot(
  data = noise_exp %>% subset(estimator != "chance"),
  mapping = aes(y = score, x = xaxis, group = estimator,
                color = estimator)) +
  geom_line(size = 1.5, alpha = 0.8) +
  geom_point(fill = "white", size = 4, shape = 21) +
  my_theme +
  scale_y_continuous(limits = c(0, 1.10), breaks = seq(0, 1, 0.25)) +
  scale_x_log10(breaks =  10^(-10:10),
                minor_breaks = rep(1:9, 21) * (10 ^ rep(-10:10, each=9))) +
  scale_color_manual(values = color_cats, name = NULL) +
  geom_hline(yintercept = 1, color = "black", linetype = "dotted",
             size = 1) +
  annotate(geom = "text", x = 0.01, y = 1.05, label = "chance level",
           size = annotate_text_size) +
  labs(x = expression(sigma),
       y = "Normalized MAE") +
  theme(legend.position = "top", legend.title = element_text(size = 16))

fname <- "./outputs/fig_1c_individual_A_linear"
ggsave(paste0(fname, ".png"), width = 5, height = 5, dpi = 300)
ggsave(paste0(fname, ".pdf"), width = 5, height = 5, dpi = 300,
  useDingbats = F)
embedFonts(file = paste0(fname, ".pdf"), outfile = paste0(fname, ".pdf"))


###############################
###  2010, David Ellinghaus ###
###############################

rm(list=ls())

file.lmiss = commandArgs()[4]
fraction_miss.thresh = as.numeric(commandArgs()[5])

lmiss = read.table(file.lmiss, as.is=T, header=T)

png(file=paste(file.lmiss, ".2.png", sep=""), width=960, height=960)

hist(lmiss$F_MISS, xlim=c(0,fraction_miss.thresh+0.01), main="All SNPs", xlab="SNP missingness", ylab="Number of SNPs", col="grey", border="black", axes=F)
axis(1, at=seq(0,fraction_miss.thresh+0.01,0.01), tick=T)
axis(2, at=seq(0,2000000,20000), tick=T)
abline(v=fraction_miss.thresh, col="red", lty=2)

dev.off()


# Note: when switching between tutorial examples,
# restart R by clicking Session | Restart R in RStudio

setwd("/home/sshuser/SparkMLADS/Code/MRS")
source("SetComputeContext.r")

library(sparklyr)
library(dplyr)

cc <- rxSparkConnect(interop = "sparklyr",
                     reset = T,
                     consoleOutput = TRUE
                     # numExecutors = 4,
                     # executorCores = 8,
                     # executorMem = "4g"
)

sc <- rxGetSparklyrConnection(cc)

################################################
# Specify the data sources
################################################

airlineDF <- sparklyr::spark_read_csv(sc = sc,
                                      name = "airline",
                                      path = "hdfs://mycluster/share/Air2009to2012CSV",
                                      header = TRUE,
                                      infer_schema = FALSE, # Avoids parsing error
                                      null_value = "null")

weatherDF <- sparklyr::spark_read_csv(sc = sc,
                                      name = "weather",
                                      path = "hdfs://mycluster/share/Weather",
                                      header = TRUE,
                                      infer_schema = TRUE,
                                      null_value = "null")

################################################
# Transform the data
################################################

airlineDF <- airlineDF %>% rename(
                    ArrDel15 = ARR_DEL15,
                    Year = YEAR,
                    Month = MONTH,
                    DayOfMonth = DAY_OF_MONTH,
                    DayOfWeek = DAY_OF_WEEK,
                    Carrier = UNIQUE_CARRIER,
                    OriginAirportID = ORIGIN_AIRPORT_ID,
                    DestAirportID = DEST_AIRPORT_ID,
                    CRSDepTime = CRS_DEP_TIME,
                    CRSArrTime = CRS_ARR_TIME
)

# Keep only the desired columns from the flight data

airlineDF <- airlineDF %>% select(ArrDel15, Year, Month, DayOfMonth,
                    DayOfWeek, Carrier, OriginAirportID,
                    DestAirportID, CRSDepTime, CRSArrTime)

# Round down scheduled departure time to full hour

airlineDF <- airlineDF %>% mutate(CRSDepTime = floor(CRSDepTime / 100))

weatherDF <- weatherDF %>% rename(
                    OriginAirportID = AirportID,
                    Year = AdjustedYear,
                    Month = AdjustedMonth,
                    DayOfMonth = AdjustedDay,
                    CRSDepTime = AdjustedHour)

# Average the weather readings by hour

weatherSummary <- weatherDF %>%
  group_by(Year, Month, DayOfMonth, CRSDepTime, OriginAirportID) %>%
  summarise(Visibility = mean(Visibility),
            DryBulbCelsius = mean(DryBulbCelsius),
            DewPointCelsius = mean(DewPointCelsius),
            RelativeHumidity = mean(RelativeHumidity),
            WindSpeed = mean(WindSpeed),
            Altimeter = mean(Altimeter))

#######################################################
# Join airline data with weather at Origin Airport
#######################################################

originDF <- left_join(x = airlineDF,
                      y = weatherSummary)

originDF <- originDF %>% rename(VisibilityOrigin = Visibility,
                                DryBulbCelsiusOrigin = DryBulbCelsius,
                                DewPointCelsiusOrigin = DewPointCelsius,
                                RelativeHumidityOrigin = RelativeHumidity,
                                WindSpeedOrigin = WindSpeed,
                                AltimeterOrigin = Altimeter)

#######################################################
# Join airline data with weather at Destination Airport
#######################################################

weatherSummary <- weatherSummary %>% rename(DestAirportID = OriginAirportID)

destDF <- left_join(x = originDF,
                    y = weatherSummary)

airWeatherDF <- destDF %>% rename(
                       VisibilityDest = Visibility,
                       DryBulbCelsiusDest = DryBulbCelsius,
                       DewPointCelsiusDest = DewPointCelsius,
                       RelativeHumidityDest = RelativeHumidity,
                       WindSpeedDest = WindSpeed,
                       AltimeterDest = Altimeter)

#######################################################
# Register the joined data as a Spark SQL/Hive table
#######################################################

airWeatherDF <- airWeatherDF %>% sdf_register("flightsweather")
tbl_cache(sc, "flightsweather")

#######################################################
# The table of joined data can be queried using SQL
#######################################################

# Count the number of rows
tbl(sc, sql("SELECT COUNT(*) FROM flightsweather"))

# Count each distinct value in the ArrDel15 column
tbl(sc, sql("SELECT ArrDel15, COUNT(*) FROM flightsweather GROUP BY ArrDel15"))


library(data.table)
library(tidyverse)

#---------------------------------#
# load data
#_________________________________#
# data
path_to_data = "../datasets/genes_data/"
dt_nodes <- fread(paste(path_to_data, "node_attributes.csv", sep=''), header=T)

#---------------------------------#
# load hops data
#_________________________________#
flist <- list.files(path = path_to_data, pattern="hops_")
hops_list <- list()
for(file in flist){
  dt <- fread(paste(path_to_data, file, sep=''), header=F)
  name_comp <- str_split(file, pattern='_')[[1]]
  depth <- str_split(name_comp[3], pattern='.csv')[[1]][1]
  edge_type = name_comp[2]
  hop_count <-  paste(edge_type, depth, 'hop_count', sep='_')
  hop_total <-  paste(edge_type, depth, 'hop_total', sep='_')
  data_name <- paste(edge_type, "hop", depth, sep="_")
  colnames(dt) <- c('ensg', hop_count, hop_total)
  dt <- mutate(dt, ratio = get(hop_count)/get(hop_total))
  colnames(dt)[4] <- paste(edge_type, depth, "hop_ratio", sep='_')
  assign(data_name, dt)
  hops_list[[data_name]] <- dt
}
dt_nodes_hops <- hops_list %>%
  Reduce(function(dtf1, dtf2) full_join(dtf1,dtf2,by="ensg"), .)

dt_nodes_hops <- left_join(dt_nodes, dt_nodes_hops, by=c('ensg'))
dt_nodes_hops[is.na(dt_nodes_hops)] <- 0

dt_nodes_hops$label <- ifelse(dt_nodes_hops$label=='disease', 1,
                              ifelse(dt_nodes_hops$label=='non-disease', 0, 2))

write.table(dt_nodes_hops[,c(1,2,235:252)], paste(path_to_data, "nodes_hops.csv", sep=''),
            col.names = T, row.names = F, sep=',')


rm(list = ls())
# setwd(dirname(parent.frame(2)$ofile))

library(plyr)
library(dplyr)

# ( '[-40,-20]' '[-6,-2]' '[-6.1,-1.2]' '[-2,-0.2]'  '[[-6,-2],[2,6]]' '[0.2,2]'   '[2,6]' '[1.2,6]'  '[20,40]' )
cases = rbind()
for (operation in c('add', 'sub', 'mul', 'div')){
  cases = rbind(cases,
    c(parameter='extrapolation.range', operation=operation, simple=F, input.size=2, subset.ratio=0.5, overlap.ratio=0, range.a=-40, range.b=-20, range.mirror=F),
    c(parameter='extrapolation.range', operation=operation, simple=F, input.size=2, subset.ratio=0.5, overlap.ratio=0, range.a=-6, range.b=-2, range.mirror=F),
    c(parameter='extrapolation.range', operation=operation, simple=F, input.size=2, subset.ratio=0.5, overlap.ratio=0, range.a=-6.1, range.b=-1.2, range.mirror=F),
    c(parameter='extrapolation.range', operation=operation, simple=F, input.size=2, subset.ratio=0.5, overlap.ratio=0, range.a=-2, range.b=-0.2, range.mirror=F),
    c(parameter='extrapolation.range', operation=operation, simple=F, input.size=2, subset.ratio=0.5, overlap.ratio=0, range.a=2, range.b=6, range.mirror=T),
    c(parameter='extrapolation.range', operation=operation, simple=F, input.size=2, subset.ratio=0.5, overlap.ratio=0, range.a=0.2, range.b=2, range.mirror=F),
    c(parameter='extrapolation.range', operation=operation, simple=F, input.size=2, subset.ratio=0.5, overlap.ratio=0, range.a=2, range.b=6, range.mirror=F),
    c(parameter='extrapolation.range', operation=operation, simple=F, input.size=2, subset.ratio=0.5, overlap.ratio=0, range.a=1.2, range.b=6, range.mirror=F),
    c(parameter='extrapolation.range', operation=operation, simple=F, input.size=2, subset.ratio=0.5, overlap.ratio=0, range.a=20, range.b=40, range.mirror=F)
  )
}

eps = data.frame(rbind(
  c(operation='mul', epsilon=0.00001),
  c(operation='add', epsilon=0.00001),
  c(operation='sub', epsilon=0.00001),
  c(operation='div', epsilon=0.00001),
  c(operation='squared', epsilon=0.00001),
  c(operation='root', epsilon=0.00001),
  c(operation='reciprocal', epsilon=0.00001)
))

dat = data.frame(cases) %>%
  merge(eps) %>%
  mutate(
    simple=as.logical(as.character(simple)),
    input.size=as.integer(as.character(input.size)),
    subset.ratio=as.numeric(as.character(subset.ratio)),
    overlap.ratio=as.numeric(as.character(overlap.ratio)),
    range.a=as.numeric(as.character(range.a)),
    range.b=as.numeric(as.character(range.b)),
    range.mirror=as.logical(as.character(range.mirror)),
    epsilon=as.numeric(as.character(epsilon))
  ) %>%
  rowwise() %>%
  mutate(
    extrapolation.range=ifelse(range.mirror, ifelse(range.b<=0, paste0('U[',range.b*-1,',',range.a*-1,'] & U[',range.a,',',range.b,']') , paste0('U[-',range.b,',-',range.a,'] & U[',range.a,',',range.b,']')), paste0('U[',range.a,',',range.b,']')), # if a and b are -ve then want: [[+,+],[-,-]]
    operation=paste0('op-', operation)
  )

write.csv(dat, file="exp_setups.csv", row.names=F)


sum_spec <- function(flux, ivar, indexes, wl.ind, cfn) {
  if (length(indexes)==1) {
    flux <- flux[indexes,]
    ivar <- ivar[indexes,]
  } else {
    flux <- apply(flux[indexes,], 2, sum)
    ivar <- 1/(apply(1/ivar[indexes,], 2, sum))
  }
  snr <- cfn(sqrt(pmax(flux[wl.ind[1]:wl.ind[2]], 0)^2 * ivar[wl.ind[1]:wl.ind[2]]), na.rm=TRUE)
  list(flux=flux, ivar=ivar, snr=snr)
}

bin2d <- function(gdat, snrthresh=6.25, f.fluxok=0.8, wl.limits = c(3700, 7500), cfn=mean, WVT=FALSE, PLOT=TRUE) {
  voronoi_tessellation <- function(x, y, xnode, ynode, scale) {
    if (scale[1] == 1) {
      classe <- nabor::knn(cbind(xnode, ynode), query=cbind(x, y), k=1)
      classe <- as.vector(classe$nn.idx)
    } else {
      classe <- apply((outer(x, xnode, '-')^2 + outer(y, ynode, '-')^2)/scale^2, 1, which.min)
    }
    classe
  }

  accretion <- function(flux, ivar, x, y, snr, snrthresh=5, wl.ind, cfn) {

    n <- length(x)
    classe <- numeric(n)
    good <- numeric(n)

    cbin <- which.max(snr)
    SN <- snr[cbin]

    for (ind in 1:n) {
      classe[cbin] <- ind
      xbar <- x[cbin]
      ybar <- y[cbin]

      repeat {
        if (all(classe>0)) break
          unbinned <- which(classe == 0)
          k <- which.min((x[unbinned]-xbar)^2+(y[unbinned]-ybar)^2)
          mindist <- sqrt(min((x[cbin] - x[unbinned[k]])^2 + (y[cbin]-y[unbinned[k]])^2))

          nextbin <- c(cbin, unbinned[k])

          SN.old <- SN
          binspec <- sum_spec(flux, ivar, nextbin, wl.ind=wl.ind, cfn=cfn)
          SN <- binspec$snr
          if (abs(SN-snrthresh) > abs(SN.old-snrthresh) || SN.old > SN) {
            if (SN.old > 0.8*snrthresh) {
              good[cbin] <- 1
              break
            }
          }
          classe[unbinned[k]] <- ind
          cbin <- nextbin
          good[cbin] <- 1

          xbar <- mean(x[cbin])
          ybar <- mean(y[cbin])
      }
      binned <- which(classe > 0)
      if (all(classe > 0)) break
        unbinned <- setdiff(1:n, binned)
        xbar <- mean(x[binned])
        ybar <- mean(y[binned])
        k <- which.min((x[unbinned]-xbar)^2+(y[unbinned]-ybar)^2)
        cbin <- unbinned[k]
        SN <- snr[unbinned[k]]
    }

    classe <- classe*good
    classe
  }

  reassign_bad_bins <- function(classe, x, y) {
    good <- unique(classe[classe>0])
    xnode <- numeric(length(good))
    ynode <- numeric(length(good))

    for (i in seq_along(good)) {
      xnode[i] <- mean(x[which(classe==good[i])])
      ynode[i] <- mean(y[which(classe==good[i])])
    }
    bad <- which(classe == 0)
    if (length(bad) > 0) {
      index <- voronoi_tessellation(x[bad], y[bad], xnode, ynode, scale=1)
      classe[bad] <- good[index]
      good <- unique(classe)
      for (i in seq_along(good)) {
        xnode[i] <- mean(x[which(classe==good[i])])
        ynode[i] <- mean(y[which(classe==good[i])])
      }
    }
    list(classe=classe, xnode=xnode, ynode=ynode)
  }

  cvt_equal_mass <- function(flux, ivar, x, y, snr, xnode, ynode, wl.ind, cfn, WVT) {
    dens2 <- snr^4
    scale <- rep(1, length(xnode))

    for (it in seq_along(xnode)) {
      xnode_old <- xnode
      ynode_old <- ynode
      classe <- voronoi_tessellation(x, y, xnode, ynode, scale)
      bins <- unique(classe)
      for (k in bins) {
        ind <- which(classe == k)
        if (WVT) {
          xnode[k] <- mean(x[ind])
          ynode[k] <- mean(y[ind])
          sn <- sum_spec(flux, ivar, ind, wl.ind=wl.ind, cfn=cfn)$snr
          scale[k] <- sqrt(length(ind)/sn)
        } else {
          mass <- sum(dens2[ind])
          xnode[k] <- sum(x[ind]*dens2[ind])/mass
          ynode[k] <- sum(y[ind]*dens2[ind])/mass
        }
      }
      diff <- sqrt(sum((xnode-xnode_old)^2 + (ynode-ynode_old)^2))
      if (diff < 0.1) break
    }
    if (diff > 0) {
      classe <- voronoi_tessellation(x, y, xnode, ynode, scale)
      bins <- unique(classe)
    }
    list(classe=classe, xnode = xnode[bins], ynode=ynode[bins], scale=scale[bins])
  }

 ## start of main routine

  if (is.null(wl.limits)) {
    wl.ind <- c(1, length(gdat$lambda))
  }
  else {
    wl.ind <- findInterval(wl.limits, gdat$lambda/(1+gdat$meta$z), all.inside=TRUE)
  }

  fluxok <- !is.na(gdat$flux[,wl.ind[1]:wl.ind[2]])
  p.fluxok <- apply(fluxok, 1, sum)/(wl.ind[2]-wl.ind[1]+1)
  ok2bin <- (p.fluxok >= f.fluxok)

  x <- gdat$xpos[ok2bin]
  y <- gdat$ypos[ok2bin]
  flux <- gdat$flux[ok2bin,]
  ivar <- gdat$ivar[ok2bin,]
  ra.f <- gdat$ra.f[ok2bin]
  dec.f <- gdat$dec.f[ok2bin]

  snr <- numeric(length(x))
  for (i in seq_along(x)) {
    snr[i] <- cfn(sqrt(pmax(flux[i,wl.ind[1]:wl.ind[2]], 0)^2 * ivar[i,wl.ind[1]:wl.ind[2]]), na.rm=TRUE)
  }

  classe <- accretion(flux, ivar, x, y, snr, snrthresh=snrthresh, wl.ind=wl.ind, cfn=cfn)
  starts <- reassign_bad_bins(classe, x, y)
  final <- cvt_equal_mass(flux, ivar, x, y, snr, starts$xnode, starts$ynode, wl.ind=wl.ind, cfn=cfn, WVT=WVT)
  classe <- final$classe
  bins <- unique(classe)
  nbins <- length(bins)
  fibersinbin <- numeric(nbins)
  flux.b <- matrix(0, nrow=nbins, ncol=length(gdat$lambda))
  ivar.b <- matrix(0, nrow=nbins, ncol=length(gdat$lambda))
  snr <- numeric(nbins)

  xpos <- final$xnode
  ypos <- final$ynode
  dec.f <- gdat$meta$dec + ypos/3600
  ra.f <- gdat$meta$ra - xpos/3600/cos(dec.f*pi/180)

  for (i in 1:nbins) {
    spec <- sum_spec(flux, ivar, which(classe==bins[i]), wl.ind=wl.ind, cfn=cfn)
    fibersinbin[i] <- length(which(classe==bins[i]))
    flux.b[i,] <- spec$flux
    ivar.b[i,] <- spec$ivar
    snr[i] <- spec$snr
  }
  bin.fiber <- rep(NA, length(ok2bin))
  bin.fiber[ok2bin] <- classe
  gdat.bin <- list(meta=gdat$meta, lambda=gdat$lambda, flux=flux.b, ivar=ivar.b, snr=snr,
                   xpos=xpos, ypos=ypos, ra.f=ra.f, dec.f=dec.f,
                   bin.fiber=bin.fiber, fibersinbin=fibersinbin,
                   x.orig = gdat$xpos, y.orig = gdat$ypos)
  if (PLOT) {
    ggbinplot(gdat.bin, unique(gdat.bin$bin.fiber[!is.na(gdat.bin$bin.fiber)]), addfiberpos=TRUE, addcentroid=TRUE,
              addborders=TRUE, show.legend=FALSE)
  }
  gdat.bin
}


# Compare Canada, 1907-2011, 1907-2014, and 2011-2014 outlier loci from null model analysis (25k)
# to be run on my mac

require(data.table)

##################
## Read in data
##################

# read in Lof
locnms11 <- fread('data_2019_03_18/Frequency_table_Lof07_Lof11.txt', header=TRUE) # the name and observed frequencies of all the loci, from output by Bastiaan Star
	setnames(locnms11, 3:7, c('cnt07', 'Freq_07', 'cnt11', 'Freq_11', 'ABS_DIFF0711'))
dat11 <- readRDS('analysis/wfs_nullmodel_pos&pvals_07-11.rds') # has the p-values from 1907-2011
	setnames(dat11, c('n', 'p'), c('nLof0711', 'pLof0711'))
locnms14 <- fread('data_2019_03_18/Frequency_table_Lof07_Lof14.txt', header=TRUE)
	setnames(locnms14, 3:7, c('cnt07', 'Freq_07', 'cnt14', 'Freq_14', 'ABS_DIFF0714'))
dat14 <- readRDS('analysis/wfs_nullmodel_pos&pvals_07-14.rds')
	setnames(dat14, c('n', 'p'), c('nLof0714', 'pLof0714'))

	# merge
setkey(dat11, CHROM, POS)
setkey(dat14, CHROM, POS)
datLof <- merge(dat11, dat14, all=TRUE)
	nrow(dat11)
	nrow(dat14)
	nrow(datLof)

setkey(datLof, CHROM, POS)
setkey(locnms11, CHROM, POS)
setkey(locnms14, CHROM, POS)
datLof <- merge(datLof, locnms11[, .(CHROM, POS, cnt07, Freq_07, cnt11, Freq_11)])
datLof <- merge(datLof, locnms14[, .(CHROM, POS, cnt14, Freq_14)])
	nrow(locnms11)
	nrow(locnms14)
	nrow(datLof)

# Read in Canada
locnmsCan <- fread('data_2019_03_18/Frequency_table_CAN_40_TGA.txt', header=TRUE)
	setnames(locnmsCan, 3:7, c('cntCan40', 'Freq_Can40', 'cntCanMod', 'Freq_CanMod', 'ABS_DIFFCan'))
	locnmsCan <- locnmsCan[cntCan40>0 & cntCanMod>0,] # trim to genotypes >0%
datCan <- readRDS('analysis/wfs_nullmodel_pos&pvals_Can.rds')
	setnames(datCan, c('n', 'p'), c('nCan', 'pCan'))

	# compare
	nrow(datCan) # now has 2019 dataset
	nrow(locnmsCan) # matches

	# merge
setkey(locnmsCan, CHROM, POS)
setkey(datCan, CHROM, POS)
datCan <- merge(datCan, locnmsCan)
	nrow(datCan)

##################
# merge Lof and Can
##################

setkey(datLof, CHROM, POS)
setkey(datCan, CHROM, POS)
dat <- merge(datCan, datLof, all=TRUE)[, .(CHROM, POS, cnt07, cnt11, cnt14, cntCan40, cntCanMod, Freq_07, Freq_11, Freq_14, Freq_Can40, Freq_CanMod, pLof0711, pLof0714, pCan)]

	# make sure the merge worked
	nrow(dat)
	nrow(dat11)
	nrow(dat14)
	dat[,.(sum(!is.na(Freq_07)), sum(!is.na(Freq_11)), sum(!is.na(Freq_14)))] # should match nrow(dat11) and nrow(dat14)
	nrow(datCan)
	dat[,.(sum(!is.na(Freq_Can40)), sum(!is.na(Freq_CanMod)))] # should match nrow(datCan)
	dat[,sum(!is.na(Freq_07) & !is.na(Freq_Can40))] # number of loci genotyped in both

###############################################
# combine p-values for individual loci
# https://mikelove.wordpress.com/2012/03/12/combining-p-values-fishers-method-sum-of-p-values-binomial/
###############################################

dat[,p.comb0711Can := pchisq(-2 * sum(log(c(pLof0711, pCan))),df=2*2,lower=FALSE), by=1:nrow(dat)] # Lof 07-11 and Can
dat[,p.comb0714Can := pchisq(-2 * sum(log(c(pLof0714, pCan))),df=2*2,lower=FALSE), by=1:nrow(dat)] # Lof 07-14 and Can

##################################
# FDR-correct p-values
##################################

# FDR-correct each population separately
# after masking out unplaced
dat[,q2.Lof0711:=as.double(NA)]
dat[,q2.Lof0714:=as.double(NA)]
dat[,q2.Can:=as.double(NA)]
dat[!(CHROM %in% c('Unplaced')), q2.Lof0711 := p.adjust(pLof0711, method='fdr')]
dat[!(CHROM %in% c('Unplaced')), q2.Lof0714 := p.adjust(pLof0714, method='fdr')]
dat[!(CHROM %in% c('Unplaced')), q2.Can := p.adjust(pCan, method='fdr')]

# FDR-correct each population separately
# after masking out inversions and unplaced
dat[,q3.Lof0711:=as.double(NA)]
dat[,q3.Lof0714:=as.double(NA)]
dat[,q3.Can:=as.double(NA)]
dat[!(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')),q3.Lof0711 := p.adjust(pLof0711, method='fdr')]
dat[!(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')),q3.Lof0714 := p.adjust(pLof0714, method='fdr')]
dat[!(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')),q3.Can := p.adjust(pCan, method='fdr')]

# For combined p-value
# after masking out unplaced
dat[,q2.comb0711Can:=as.double(NA)]
dat[,q2.comb0714Can:=as.double(NA)]
dat[!(CHROM %in% c('Unplaced')), q2.comb0711Can := p.adjust(p.comb0711Can, method='fdr')]
dat[!(CHROM %in% c('Unplaced')), q2.comb0714Can := p.adjust(p.comb0714Can, method='fdr')]

# For combined p-value
# after masking out inversions and unplaced
dat[,q3.comb0711Can:=as.double(NA)]
dat[,q3.comb0714Can:=as.double(NA)]
dat[!(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')), q3.comb0711Can := p.adjust(p.comb0711Can, method='fdr')]
dat[!(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')), q3.comb0714Can := p.adjust(p.comb0714Can, method='fdr')]

###################################################
# mark outliers based on fdr-corrected q-values
# or low p-values in both populations
###################################################
# qthresh <- 0.6
#
# # in each pop
# # with inversions
# #dat[,outlierLof0714_q2 := 0]
# #dat[q2.Lof0714<qthresh, outlierLof0714_q2 := 1]
# #	dat[,sum(outlierLof0714_q2, na.rm=TRUE)]
#
# dat[,outlierLof071114_q2 := 0]
# dat[q2.Lof071114<qthresh, outlierLof071114_q2 := 1]
# 	dat[,sum(outlierLof071114_q2, na.rm=TRUE)]
#
# dat[,outlierCan_q2 := 0]
# dat[q2.Can<qthresh, outlierCan_q2 := 1]
# 	dat[,sum(outlierCan_q2, na.rm=TRUE)]
#
# # in each pop
# # without inversions
# #dat[,outlierLof0714_q3 := 0]
# #dat[q3.Lof0714<qthresh, outlierLof0714_q3 := 1]
# #	dat[,sum(outlierLof0714_q3, na.rm=TRUE)]
#
# dat[,outlierLof071114_q3 := 0]
# dat[q3.Lof071114<qthresh, outlierLof071114_q3 := 1]
# 	dat[,sum(outlierLof071114_q3, na.rm=TRUE)]
#
# 	dat[, sum(q3.Lof071114<0.3, na.rm=TRUE)] # higher FDR threshold
#
#
# dat[,outlierCan_q3 := 0]
# dat[q3.Can<qthresh, outlierCan_q3 := 1]
# 	dat[,sum(outlierCan_q3, na.rm=TRUE)]
#
# 	dat[,sum(outlierLof071114_q3 & outlierCan_q3, na.rm=TRUE)] # Lof and Can?
#
#
# # combined Lof and Can
# # with inversions
# #dat[,outlierLof0714_Can_q2 := 0]
# #dat[q2.comb0714Can<qthresh, outlierLof0714_Can_q2 := 1]
# #	dat[,sum(outlierLof0714_Can_q2, na.rm=TRUE)]
#
# dat[,outlierLof071114_Can_q2 := 0]
# dat[q2.comb071114Can<qthresh, outlierLof071114_Can_q2 := 1]
# 	dat[,sum(outlierLof071114_Can_q2, na.rm=TRUE)]
#
# # combined Lof and Can
# # without inversions
# #dat[,outlierLof0714_Can_q3 := 0]
# #dat[q3.comb0714Can<qthresh, outlierLof0714_Can_q3 := 1]
# #	dat[,sum(outlierLof0714_Can_q3, na.rm=TRUE)]
#
# dat[,outlierLof071114_Can_q3 := 0]
# dat[q3.comb071114Can<qthresh, outlierLof071114_Can_q3 := 1]
# 	dat[,sum(outlierLof071114_Can_q3, na.rm=TRUE)]
#
# 	dat[,sum(outlierLof071114_q3 & outlierLof071114_Can_q3, na.rm=TRUE)] # Lof and combined?
# 	dat[,sum(q3.Lof071114<0.3 & outlierLof071114_Can_q3, na.rm=TRUE)] # Lof<0.03 and combined?
# 	dat[,sum(outlierCan_q3 & outlierLof071114_Can_q3, na.rm=TRUE)] # Can and combined?
#
#
# # loci with low p-values in both populations
# # with inversions
# #dat[,outlierLof0714andCan_p2 := 0]
# #dat[kmer25==1 & dpFlag==1 & !(CHROM %in% c('Unplaced')) & pLof0714<0.001 & pCan<0.001, outlierLof0714andCan_p2 := 1]
# #	dat[,sum(outlierLof0714andCan_p2, na.rm=TRUE)]
#
# dat[,outlierLof071114andCan_p2 := 0]
# dat[kmer25==1 & dpFlag==1 & densFlag==1 & !(CHROM %in% c('Unplaced')) & pLof071114<0.001 & pCan<0.001, outlierLof071114andCan_p2 := 1]
# 	dat[,sum(outlierLof071114andCan_p2, na.rm=TRUE)]
#
#
# # loci with low p-values in both populations
# # without inversions
# #dat[,outlierLof0714andCan_p3 := 0]
# #dat[kmer25==1 & dpFlag==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')) & pLof0714<0.001 & pCan<0.001, outlierLof0714andCan_p3 := 1]
# #	dat[,sum(outlierLof0714andCan_p3, na.rm=TRUE)]
#
# dat[,outlierLof071114andCan_p3 := 0]
# dat[kmer25==1 & dpFlag==1 & densFlag==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')) & pLof071114<0.001 & pCan<0.001, outlierLof071114andCan_p3 := 1]
# 	dat[,sum(outlierLof071114andCan_p3, na.rm=TRUE)]
#
# 	dat[,sum(outlierLof071114_Can_q3 & outlierLof071114andCan_p3, na.rm=TRUE)]
#

#############
# write out
#############
# write out
outfile <- paste('analysis/wfs_nullmodel_outliers_07-11-14_Can.csv.gz', sep='')
outfile
write.table(dat, file=gzfile(outfile), sep=',', row.names=FALSE, quote=FALSE)

#write out for Udi: just the ranked p-values, dropping Unplaced, inversions
# have to write out each population separately so that locus trimming is done appropriately
# NEED TO REDO WITH 07-11 AND 07-14
outfile1 <- paste('analysis/wfs_nullmodel_outliers_Udi_Lof.tsv.gz', sep='')
outfile1
out1 <- dat[!(CHROM %in% c("Unplaced", "LG01", 'LG02', 'LG07', 'LG12')) & !is.na(q3.Lof0711), .(CHROM, POS, q3.Lof071114)]
nrow(out1)
write.table(out1, file=gzfile(outfile1), sep='\t', row.names=FALSE, quote=FALSE)

outfile2 <- paste('analysis/wfs_nullmodel_outliers_Udi_Can.tsv.gz', sep='')
outfile2
out2 <- dat[!(CHROM %in% c("Unplaced", "LG01", 'LG02', 'LG07', 'LG12')) & !is.na(q3.Can), .(CHROM, POS, q3.Can)]
nrow(out2)
write.table(out2, file=gzfile(outfile2), sep='\t', row.names=FALSE, quote=FALSE)

outfile3 <- paste('analysis/wfs_nullmodel_outliers_Udi_comb.tsv.gz', sep='')
outfile3
out3 <- dat[!(CHROM %in% c("Unplaced", "LG01", 'LG02', 'LG07', 'LG12')) & !is.na(q3.comb071114Can), .(CHROM, POS, q3.comb071114Can)]
nrow(out3)
write.table(out3, file=gzfile(outfile3), sep='\t', row.names=FALSE, quote=FALSE)

outfile4 <- paste('analysis/wfs_nullmodel_outliers_Udi_union.tsv.gz', sep='')
outfile4
out4 <- dat[!(CHROM %in% c("Unplaced", "LG01", 'LG02', 'LG07', 'LG12')) & (!is.na(q3.Lof0711) | !is.na(q3.Lof0714) | !is.na(q3.Can) | !is.na(q3.comb071114Can)), .(CHROM, POS, q3.union = pmin(q3.Lof071114, q3.Can, q3.comb071114Can, na.rm=TRUE))]
nrow(out4)
write.table(out4, file=gzfile(outfile4), sep='\t', row.names=FALSE, quote=FALSE)

#########################
# examine
#########################
## number of loci
nrow(dat) # total
dat[,.(sum(!is.na(Freq_11)), sum(!is.na(Freq_11))/.N)] # Lof 07-11
dat[,.(sum(!is.na(Freq_14)), sum(!is.na(Freq_14))/.N)] # Lof 07-14
dat[,.(sum(!is.na(Freq_Can40)), sum(!is.na(Freq_Can40))/.N)] # Can
dat[,.(sum(!is.na(Freq_11) & !is.na(Freq_14)), sum(!is.na(Freq_11) & !is.na(Freq_14))/.N)] # both
dat[,.(sum(!is.na(Freq_11) & !is.na(Freq_Can40)), sum(!is.na(Freq_11) & !is.na(Freq_Can40))/.N)] # both
dat[,.(sum(!is.na(Freq_14) & !is.na(Freq_Can40)), sum(!is.na(Freq_14) & !is.na(Freq_Can40))/.N)] # both
dat[,.(sum(!is.na(Freq_11) & !is.na(Freq_14) & !is.na(Freq_Can40)), sum(!is.na(Freq_11) & !is.na(Freq_14) & !is.na(Freq_Can40))/.N)] # all

	# not in unplaced
dat[,.(sum(!is.na(Freq_11) & !(CHROM %in% c('Unplaced'))), round(sum(!is.na(Freq_11) & !(CHROM %in% c('Unplaced')))/.N, 2))] # Lof 07-11
dat[,.(sum(!is.na(Freq_14) & !(CHROM %in% c('Unplaced'))), round(sum(!is.na(Freq_14) & !(CHROM %in% c('Unplaced')))/.N, 2))] # Lof 07-14
dat[,.(sum(!is.na(Freq_Can40) & !(CHROM %in% c('Unplaced'))), round(sum(!is.na(Freq_Can40) & !(CHROM %in% c('Unplaced')))/.N,2))] # Can
dat[,.(sum(!is.na(Freq_11) & !is.na(Freq_14) & !(CHROM %in% c('Unplaced'))), round(sum(!is.na(Freq_11) & !is.na(Freq_14) & !(CHROM %in% c('Unplaced')))/.N,2))] # both
dat[,.(sum(!is.na(Freq_11) & !is.na(Freq_Can40) & !(CHROM %in% c('Unplaced'))), round(sum(!is.na(Freq_11) & !is.na(Freq_Can40) & !(CHROM %in% c('Unplaced')))/.N, 2))] # both
dat[,.(sum(!is.na(Freq_14) & !is.na(Freq_Can40) & !(CHROM %in% c('Unplaced'))), round(sum(!is.na(Freq_14) & !is.na(Freq_Can40) & !(CHROM %in% c('Unplaced')))/.N,2))] # both
dat[,.(sum(!is.na(Freq_11) & !is.na(Freq_14) & !is.na(Freq_Can40) & !(CHROM %in% c('Unplaced'))), round(sum(!is.na(Freq_11) & !is.na(Freq_14) & !is.na(Freq_Can40) & !(CHROM %in% c('Unplaced')))/.N,2))] # all

	# not in unplaced or inversion LGs
locs <- c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')
dat[,.(sum(!is.na(Freq_11) & !(CHROM %in% locs)), round(sum(!is.na(Freq_11) & !(CHROM %in% locs))/.N, 2))] # Lof 07-11
dat[,.(sum(!is.na(Freq_14) & !(CHROM %in% locs)), round(sum(!is.na(Freq_14) & !(CHROM %in% locs))/.N, 2))] # Lof 07-14
dat[,.(sum(!is.na(Freq_Can40) & !(CHROM %in% locs)), round(sum(!is.na(Freq_Can40) & !(CHROM %in% locs))/.N,2))] # Can
dat[,.(sum(!is.na(Freq_11) & !is.na(Freq_14) & !(CHROM %in% locs)), round(sum(!is.na(Freq_11) & !is.na(Freq_14) & !(CHROM %in% locs))/.N,2))] # both
dat[,.(sum(!is.na(Freq_11) & !is.na(Freq_Can40) & !(CHROM %in% locs)), round(sum(!is.na(Freq_11) & !is.na(Freq_Can40) & !(CHROM %in% locs))/.N, 2))] # both
dat[,.(sum(!is.na(Freq_14) & !is.na(Freq_Can40) & !(CHROM %in% locs)), round(sum(!is.na(Freq_14) & !is.na(Freq_Can40) & !(CHROM %in% locs))/.N,2))] # both
dat[,.(sum(!is.na(Freq_11) & !is.na(Freq_14) & !is.na(Freq_Can40) & !(CHROM %in% locs)), round(sum(!is.na(Freq_11) & !is.na(Freq_14) & !is.na(Freq_Can40) & !(CHROM %in% locs))/.N,2))] # all

## number of outliers: each population separately
	# without unplaced
dat[,sum(q2.Lof0711<0.2, na.rm=TRUE)]
	dat[q2.Lof0711<0.2, table(CHROM)]
	dat[q2.Lof0711<0.2, .(CHROM, POS, Freq_07, Freq_11, Freq_14, pLof0711, q2.Lof0711)]

dat[,sum(q2.Lof0714<0.2, na.rm=TRUE)]
	dat[q2.Lof0714<0.2, table(CHROM)]
	dat[q2.Lof0714<0.2, .(CHROM, POS, Freq_07, Freq_11, Freq_14, pLof0714, q2.Lof0714)]

dat[,sum(q2.Can<0.2, na.rm=TRUE)]
	dat[q2.Can<0.2, table(CHROM)]
	dat[q2.Can<0.2, .(CHROM, POS, Freq_Can40, Freq_CanMod, pCan, q2.Can)]

		# overlap
	dat[,sum(q2.Lof0711<0.2 & q2.Lof0714<0.2, na.rm=TRUE)]
	dat[,sum(q2.Lof0711<0.2 & q2.Can<0.2, na.rm=TRUE)]
	dat[,sum(q2.Lof0714<0.2 & q2.Can<0.2, na.rm=TRUE)]

	# without inversions or unplaced
dat[,sum(q3.Lof0711<0.2, na.rm=TRUE)]
	dat[q3.Lof0711<0.2, table(CHROM)]
	dat[q3.Lof0711<0.2, .(CHROM, POS, Freq_07, Freq_11, Freq_14, pLof0711, q3.Lof0711)]

dat[,sum(q3.Lof0714<0.2, na.rm=TRUE)]
	dat[q3.Lof0714<0.2, table(CHROM)]
	dat[q3.Lof0714<0.2, .(CHROM, POS, Freq_07, Freq_11, Freq_14, pLof0714, q3.Lof0714)]

dat[,sum(q3.Can<0.2, na.rm=TRUE)]
	dat[q3.Can<0.2, table(CHROM)]
	dat[q3.Can<0.2, .(CHROM, POS, Freq_Can40, Freq_CanMod, pCan, q3.Can)]

		# overlap
	dat[,sum(q3.Lof0711<0.2 & q3.Lof0714<0.2, na.rm=TRUE)]
	dat[,sum(q3.Lof0711<0.2 & q3.Can<0.2, na.rm=TRUE)]
	dat[,sum(q3.Lof0714<0.2 & q3.Can<0.2, na.rm=TRUE)]

# number of outliers: combined p-values
	# with inversions
dat[, sum(q2.comb0711Can<0.2, na.rm=TRUE)]
	dat[q2.comb0711Can<0.2, .(CHROM, POS, Freq_07, Freq_11, Freq_14, Freq_Can40, Freq_CanMod, pLof0711, pCan)]

dat[, sum(q2.comb0714Can<0.2, na.rm=TRUE)]
	dat[q2.comb0714Can<0.2, .(CHROM, POS, Freq_07, Freq_11, Freq_14, Freq_Can40, Freq_CanMod, pLof0714, pCan)]

		# overlap
	dat[,sum(q2.comb0711Can<0.2 & q2.comb0714Can<0.2, na.rm=TRUE)]

	# without inversions
dat[, sum(q3.comb0711Can<0.2, na.rm=TRUE)]
	dat[q3.comb0711Can<0.2, .(CHROM, POS, Freq_07, Freq_11, Freq_14, Freq_Can40, Freq_CanMod, pLof0711, pCan)]

dat[, sum(q3.comb0714Can<0.2, na.rm=TRUE)]
	dat[q3.comb0714Can<0.2, .(CHROM, POS, Freq_07, Freq_11, Freq_14, Freq_Can40, Freq_CanMod, pLof0714, pCan)]

		# overlap
	dat[,sum(q3.comb0711Can<0.2 & q3.Lof0711<0.2, na.rm=TRUE)]
	dat[,sum(q3.comb0711Can<0.2 & q3.Lof0714<0.2, na.rm=TRUE)]
	dat[,sum(q3.comb0711Can<0.2 & q3.Can<0.2, na.rm=TRUE)]

	dat[,sum(q3.comb0711Can<0.2 & q3.comb0714Can<0.2, na.rm=TRUE)]
	dat[,sum(q3.comb0714Can<0.2 & q3.Lof0711<0.2, na.rm=TRUE)]
	dat[,sum(q3.comb0714Can<0.2 & q3.Lof0714<0.2, na.rm=TRUE)]
	dat[,sum(q3.comb0714Can<0.2 & q3.Can<0.2, na.rm=TRUE)]

####################################################################
## do the same SNPs appear as outliers in both? p value approach
####################################################################

	# Lof 1907-2014 and Can
	# with inversions
# ntot <- dat[!(CHROM %in% c('Unplaced')) & !is.na(q2.Can) & !is.na(q2.Lof0714),.N]
# nLof <- dat[!(CHROM %in% c('Unplaced')) & !is.na(pCan),sum(q2.Lof0714<0.2, na.rm=TRUE)]
# nCan <- dat[!(CHROM %in% c('Unplaced')) & !is.na(q2.Lof0714),sum(q2.Can<0.2, na.rm=TRUE)]
# ncomb <- dat[!(CHROM %in% c('Unplaced')),sum(q2.Can<0.2 & q2.Lof0714<0.2, na.rm=TRUE)]
# nexp <- nLof/ntot * nCan/ntot * ntot # expected number in both
# nLof
# nCan
# ncomb # number in both
# nexp
#
# dat[!(CHROM %in% c('Unplaced')) & q2.Can<0.2 & q2.Lof0714<0.2,.(CHROM, POS, Freq_07, Freq_11, Freq_14, Freq_Can40, Freq_CanMod, pCan, pLof0714)]
#
# binom.test(x=ncomb, n=ntot, p=nLof/ntot * nCan/ntot) # statistical test relative to expectations
# binom.test(x=5, n=ntot, p=nLof/ntot * nCan/ntot) # statistical test relative to expectations: each cluster separately

	# Lof 1907-2014 and Can
	# without inversions
# ntot <- dat[kmer25==1 & dpLofFlag==1 & dpCanFlag==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')) & !is.na(pCan) & !is.na(pLof0714),.N]
# nLof <- dat[kmer25==1 & dpLofFlag==1 & dpCanFlag==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')) & !is.na(pCan),sum(pLof0714<1e-3)]
# nCan <- dat[kmer25==1 & dpLofFlag==1 & dpCanFlag==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')) & !is.na(pLof0714),sum(pCan<1e-3)]
# ncomb <- dat[kmer25==1 & dpCanFlag==1 & dpLofFlag==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')),sum(pCan<1e-3 & pLof0714<1e-3)]
# nexp <- nLof/ntot * nCan/ntot * ntot # expected number in both
# nLof
# nCan
# ncomb # number in both
# nexp
#
# dat[kmer25==1 & dpCanFlag==1 & dpLofFlag==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')) & pCan<1e-3 & pLof0714<1e-3,.(CHROM, POS, Freq_07, Freq_11, Freq_14, Freq_Can40, Freq_CanMod, pCan, pLof0714)]
#
# binom.test(x=ncomb, n=ntot, p=nLof/ntot * nCan/ntot) # statistical test relative to expectations
# binom.test(x=4, n=ntot, p=nLof/ntot * nCan/ntot) # statistical test relative to expectations: each cluster separately

	# Lof 1907-2011-2014 and Can
	# with inversions
#ntot <- dat[kmer25==1 & dpLofFlag==1 & dpCanFlag==1 & densFlag==1 & !(CHROM %in% c('Unplaced')) & !is.na(pCan) & !is.na(pLof071114), .N]
#nLof <- dat[kmer25==1 & dpLofFlag==1 & dpCanFlag==1 & densFlag==1 & !(CHROM %in% c('Unplaced')) & !is.na(pCan), sum(pLof071114<1e-3)]
#nCan <- dat[kmer25==1 & dpLofFlag==1 & dpCanFlag==1 & densFlag==1 & !(CHROM %in% c('Unplaced')) & !is.na(pLof071114), sum(pCan<1e-3)]
#ncomb <- dat[kmer25==1 & dpCanFlag==1 & dpLofFlag==1 & densFlag==1 & !(CHROM %in% c('Unplaced')), sum(pCan<1e-3 & pLof071114<1e-3)]
#nexp <- nLof/ntot * nCan/ntot * ntot # expected number in both
#nLof
#nCan
#ncomb # number in both
#nexp
#
#dat[kmer25==1 & dpCanFlag==1 & dpLofFlag==1 & densFlag==1 & !(CHROM %in% c('Unplaced')) & pCan<1e-3 & pLof071114<1e-3,.(CHROM, POS, Freq_07, Freq_11, Freq_14, Freq_Can40, Freq_CanMod, pCan, pLof071114)]
#
#binom.test(x=ncomb, n=ntot, p=nLof/ntot * nCan/ntot) # statistical test relative to expectations
#binom.test(x=8, n=ntot, p=nLof/ntot * nCan/ntot) # statistical test relative to expectations: each cluster separately

	# Lof 1907-2011-2014 and Can
	# without inversions
# pthresh <- 1e-2
# ntot <- dat[kmer25==1 & dpLofFlag==1 & dpCanFlag==1 & densFlag==1 & binomp>0.05 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')) & !is.na(pCan) & !is.na(pLof071114),.N]
# nLof <- dat[kmer25==1 & dpLofFlag==1 & dpCanFlag==1 & densFlag==1 & binomp>0.05 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')) & !is.na(pCan),sum(pLof071114<pthresh)]
# nCan <- dat[kmer25==1 & dpLofFlag==1 & dpCanFlag==1 & densFlag==1 & binomp>0.05 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')) & !is.na(pLof071114),sum(pCan<pthresh)]
# ncomb <- dat[kmer25==1 & dpCanFlag==1 & dpLofFlag==1 & densFlag==1 & binomp>0.05 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')),sum(pCan<1e-2 & pLof071114<pthresh)]
# nexp <- nLof/ntot * nCan/ntot * ntot # expected number in both
# nLof
# nCan
# ncomb # number in both
# nexp
#
# dat[kmer25==1 & dpCanFlag==1 & dpLofFlag==1 & densFlag==1 & binomp>0.05 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')) & pCan<pthresh & pLof071114<pthresh,.(CHROM, POS, Freq_07, Freq_11, Freq_14, Freq_Can40, Freq_CanMod, pCan, pLof071114)] # look at loci
# dat[kmer25==1 & dpCanFlag==1 & dpLofFlag==1 & densFlag==1 & binomp>0.05 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')) & pCan<pthresh & pLof071114<pthresh,table(CHROM)] # look at number of LGs
#
# binom.test(x=ncomb, n=ntot, p=nLof/ntot * nCan/ntot) # statistical test relative to expectations
# binom.test(x=7, n=ntot, p=nLof/ntot * nCan/ntot) # statistical test relative to expectations: each cluster separately

###########################
# other examination code
###########################

# examine combined p-values in various classes
dat[,range(p.comb, na.rm=TRUE)]
dat[kmer25==1 & dpFlag==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')),range(p.comb, na.rm=TRUE)]

hist(dat[,-log10(p.comb)], breaks=40, col='grey')

	require(RColorBrewer)
	cols <- brewer.pal(3, 'Set1')
	bks <- seq(0,1,by=0.01)
	hist14_25k <- dat14_25k[,hist(ABS_DIFF_0714, breaks=bks, plot=FALSE)]
	hist11_25k <- dat11_25k[,hist(ABS_DIFF_0711, breaks=bks, plot=FALSE)]
	hist11_14_25k <- dat11_14_25k[,hist(ABS_DIFF_1114, breaks=bks, plot=FALSE)]

	quartz(width=9, height=3)
	# pdf(width=9, height=3, file='analysis/figures/abs_diff_hist_25k&150k.pdf')
	par(mfrow=c(1,3), las=1, cex.axis=0.8, tcl=-0.2, mgp=c(2.5,0.5, 0), mai=c(0.5, 0.5, 0.2, 0.1))

	plot(hist11_25k$mids, hist11_25k$density/sum(hist11_25k$density), type='o', col=cols[1], cex=0.5, xlab='Frequency change', ylab='Proportion of loci', log='y', main='1907-2011', ylim=c(1e-6, 1e-1), xlim=c(0,0.6))
	lines(hist11_150k$mids, hist11_150k$density/sum(hist11_150k$density), type='o', col=cols[2], cex=0.5, main='1907-2011')

	plot(hist14_25k$mids, hist14_25k$density/sum(hist14_25k$density), type='o', col=cols[1], cex=0.5, xlab='Frequency change', ylab='', log='y', main='1907-2014', ylim=c(1e-6, 1e-1), xlim=c(0,0.6))
	lines(hist14_150k$mids, hist14_150k$density/sum(hist14_150k$density), type='o', col=cols[2], cex=0.5)

	plot(hist11_14_25k$mids, hist11_14_25k$density/sum(hist11_14_25k$density), type='o', col=cols[1], cex=0.5, xlab='Frequency change', ylab='', log='y', main='2011-2014', ylim=c(1e-6, 1e-1), xlim=c(0,0.6))
	lines(hist11_14_150k$mids, hist11_14_150k$density/sum(hist11_14_150k$density), type='o', col=cols[2], cex=0.5)

	legend('topright', legend=c('25 kmer', '150 kmer'), lwd=1, pch=1, col=cols[1:2], cex=0.8)

# examine adjusted combined p-values
dat[,range(p.comb.adj, na.rm=TRUE)]
dat[,range(p.comb.adj2, na.rm=TRUE)]

dat[kmer25==1 & dpFlag==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')),range(p.comb.adj, na.rm=TRUE)]
dat[kmer25==1 & dpFlag==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')),range(p.comb.adj2, na.rm=TRUE)]
dat[kmer25==1 & dpFlag==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')),range(p.comb.adj3, na.rm=TRUE)]

hist(dat[,-log10(p.comb.adj)], breaks=40, col='grey')
hist(dat[,-log10(p.comb.adj2)], breaks=40, col='grey')

	# zoom
hist(dat[,-log10(p.comb.adj)], breaks=200, col='grey', xlim=c(2,6), ylim=c(0,50))
hist(dat[,-log10(p.comb.adj2)], breaks=200, col='grey', xlim=c(2,6), ylim=c(0,50))

# plot outliers based on allele frequency change in both populations
par(mfrow=c(1,2))
dat[kmer25==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')),][sample(.N,10000), plot(abs((Freq_11 +Freq_14)/2 - Freq_07), abs(Freq_CanMod - Freq_Can40), main='all that pass filters\n(sample of 5000)', xlim=c(0,0.5), ylim=c(0,0.5), col=rgb(0,0,0,0.2), cex=0.5)]
dat[p.comb.adj3<0.2 & kmer25==1 & !(CHROM %in% c('LG01', 'LG02', 'LG07', 'LG12', 'Unplaced')), plot(abs((Freq_11 +Freq_14)/2 - Freq_07), abs(Freq_CanMod - Freq_Can40), main='outliers p.comb.adj2<0.05', xlim=c(0,0.5), ylim=c(0,0.5))]


#' diffusivity
#'
#' Calculate air diffusivity.
#'
#' @param tk   numeric Air temperature in degK.
#' @param pair numeric Air pressure in hPa.
#' @return diffusivity
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#'
#' @export
#'
#'
#'
#'

diffusivity=function(tk,pair) {
                         ct$assign("tk", as.array(tk))
                         ct$assign("pair", as.array(pair))
                         ct$eval("var res=[]; for(var i=0, len=tk.length; i < len; i++){ res[i]=diffusivity(tk[i],pair[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


#' Create a tidy stats data frame from an lmerModLmerTest object
#'
#' \code{tidy_stats.lmerModLmerTest} takes an lmerModLmerTest object and converts the object to a tidy stats data frame.
#'
#' @param model Output of lmerTest's \code{lmer()}.
#' @param args Unused.
#'
#' @examples
#' # Check if lme4 and lmerTest packages are available
#' if(!requireNamespace("lme4", quietly = TRUE) &
#'    !requireNamespace("lmerTest", quietly = TRUE)) {
#'
#'   message(paste0("Packages 'lme4' and 'lme4Test are needed for this ",
#'                  "example to work. Please install them."), .call = FALSE)
#' } else {
#'
#'   # Conduct a linear mixed model
#'   model_lmerTest <- lmerTest::lmer(Reaction ~ Days + (Days | Subject), lme4::sleepstudy)
#'
#'   # Tidy stats
#'   tidy_stats(model_lmerTest)
#' }
#'
#' @export

tidy_stats.lmerModLmerTest <- function(model, args = NULL) {

  # Get summary statistics
  summary <- summary(model)

  # Extract model statistics
  model_N <- data_frame(
    value = summary$devcomp$dims[1],
    statistic = "N",
    term = "(Observations)",
    term_nr = 1,
    group = "model"
  )

  model_N_groups <- as_data_frame(summary$ngrps) %>%
    mutate(
      statistic = "N",
      term = names(summary$ngrps),
      term_nr = 1:dplyr::n() + 1,
      group = "model"
    )

  model_N <- bind_rows(model_N, model_N_groups)

  # Extract random effects statistics
  random <- as_data_frame(summary$varcor) %>%
    dplyr::mutate(pair = if_else(is.na(var2), FALSE, TRUE)) %>%
    tidyr::unite(term, grp, starts_with("var"), sep = " - ") %>%
    dplyr::mutate(
      term = stringr::str_replace_all(term, " - ?NA", ""),
      term_nr = 1:dplyr::n() + max(model_N$term_nr),
      group = "random"
    ) %>%
    tidyr::gather("statistic", "value", vcov, sdcor) %>%
    dplyr::mutate(statistic = case_when(
      statistic == "vcov" & !pair ~ "var",
      statistic == "vcov" & pair ~ "cov",
      statistic == "sdcor" & !pair ~ "sd",
      statistic == "sdcor" & pair ~ "r"
    )) %>%
    dplyr::arrange(term_nr)

  # Convert fixed effects statistics to a data frame
  fixed <- tibble::as_data_frame(summary$coefficients)

  # Rename columns
  fixed <- rename_columns(fixed)

  # Set group and term information
  fixed <- fixed %>%
    dplyr::mutate(
      term = rownames(summary$coefficients),
      term_nr = 1:dplyr::n() + max(random$term_nr),
      group = "fixed"
    )

  # Tidy stats
  fixed <- fixed %>%
    tidyr::gather("statistic", "value", -term, -term_nr, -group) %>%
    dplyr::arrange(term_nr)

  # Add fixed effects correlations
  cors <- lme4::cov2sdcor(as.matrix(summary$vcov))
  cors[lower.tri(cors, diag = TRUE)] <- NA
  cors <- cors %>%
    as.data.frame() %>%
    tibble::rownames_to_column("term1") %>%
    tidyr::gather("term2", "value", -term1) %>%
    dplyr::filter(term1 != term2 & !is.na(value)) %>%
    tidyr::unite(col = "term", term1, term2, sep = " - ") %>%
    dplyr::mutate(
      statistic = "r",
      group = "fixed",
      term_nr = 1:dplyr::n() + max(fixed$term_nr)
    )

  # Combine all parts of the output
  output <- dplyr::bind_rows(model_N, random, fixed, cors)

  # TODO:
  # - REML criterion at convergence
  # - Scaled residuals

  # Add method
  output$method <- "Linear mixed model {lmerTest}"

  # Order variables
  output <- dplyr::select(output, group, term_nr, term, statistic, value,
    method)

  return(output)
}


# comments
# to run a command press Control + Enter.
# to clear the console press Control + l or broom .

# To create and assign a variable
# use <- (assignment operator)
# the right side window will show
#you all the variables
# and their values associated.

print("Hello world")
2+5
x <- 2
x <- 3
x # print the value

# to store multiple values
#use concatenation operator c(value1,val2,...)
# array of numbers containing 1-5.
y<-c(1,2,3,4,5)
# for serial values u can use slicing
# create a variables to store values like array.
z<-1:10

# for storing same values to different variable
m<-n<-1:10
# created 2 variables m and n both store array.

# for adding each element of x with of y
# like a[1]=x[1]+y[1],a[2]=x[2]+y[2]...
# also we can multiply.
a1<-m+n
a2<-m*n

# to see  all the values of the work space
ls()

# delete one variable from teh work space use rm(x) or remove(x)
rm(a)
remove(x)

# to remove all the variables from the workspace
# use command rm(list = ls())
rm(list=ls())
#workspace is empty now

# to use packeges in the rigt down
# clicks the packages section and select the package
#it will itself get installed.

# packages
# http://cran.r-project.org/web/views/
# http://cran.stat.ucla.edu/web/packages/available_packages_by_nav
# http://crantastic.org

# to open any link
browseURL("http://cran.r-project.org/web/views/")
# to show all the available packages
library()
# to search currently loaded packages
search()

# how to add data on which we want to do analysis
# 3 ways:
# 1. Use R's buildin datasets
#2. enter data manualyy and store it
#3.Import the data from csv file or text file.

# method 1
data() # show all inbuilt library
library(help="datasets") #documentation of all available packages
?iris # tell us all about iris
# it has same data of flowers contains petal len sepal le and all

str(iris) #structure of iris
# has 150 rows and 5 columns

# to view whole iris dataset
iris

#to load the dataset in your workspace
data("iris")
# in the rigt window we can see the iris has got loded in our workspace.

# method 2- Manual data entry

x1<-1:10
x2<-c(2,5,7,4)
x3<-seq(5,50, by=5) #to store number from 5 till 50 by the increment of 5.
x4<-scan() # to input manually ,once u r done press enter twice.

# import data from a csv file or a text file into our work space.
# in text file the delimiter is tab
# that is all the columns are separated by 1 tab
# in csv file the delimiter is , csv=comma separated values.

# to lode the data set in our wok space
# how to insert data from a txt file
Product <- read.table("C:/Users/KIIT/Data-Science-and-ML/ML USING PYTHON AND R/CrashCourseFiles/Product.txt", header = TRUE, sep = "\t")

str(Product)# to know the structure of the product variable

# how to insert data from a csv file.
Customer<- read.csv("C:/Users/KIIT/Data-Science-and-ML/ML USING PYTHON AND R/CrashCourseFiles/Customer.csv", header = TRUE, sep = ",")
# to view the customer details
View(Customer)

# Creating Bar plot in R

# to find the frequency distribution for region variables

y <- table(Customer$Region)
y
View(y)#to view y in tabular format.

# to create a bar plot
barplot(y) #here the height of the bar is giving you the frequency of the particular region.

#parameter of the barplot graph
# 1. soth the barplot in ascendig order
barplot(y[order(y)])#ascending order

barplot(y[order(-y)])#decending order

# 2. to change the orientation of the bar plot in horizontal direction
barplot(y[order(y)],horiz = TRUE)# to make it horinzontal

# 3. to change the colour
barplot(y[order(y)],col = "purple")# for all bar to be same colour.

# 4. for all bars of different colour use concatination c
barplot(y[order(y)],col = c("purple","yellow","pink","orange"))
# also if u want u can also mention the colour number inspite of colour names.
# to see the list of colours available
colors()

# To remeobethe boundry of the bars
barplot(y[order(y)],col = c("purple","yellow","pink","orange"),border = NA)

# to add a title to the graph
barplot(y[order(y)],col = c("purple","yellow","pink","orange"),main = "Frequencies of regions")

# to use two lines add \n
barplot(y[order(y)],col = c("purple","yellow","pink","orange"),main = "Frequencies of \n regions")

# to lable the x-axis and y-axis
barplot(y[order(y)],col = c("purple","yellow","pink","orange"),main = "Frequencies of \n regions",xlab = "Regions",ylab = "Number of Customers")

# to use the bar plot we have to export the bar plot in terms of pic or pdf
# there is a option in r studio t export

# how to create a histogram in R

# to see the distribution in age variable in different age category

# histogram is a plot which gives us the frequency of each category comming in our data

# to make a histogram of age variable
hist(Customer$Age)

# if we want only few buckets
hist(Customer$Age, breaks = 5) #here we suggest to give only 5 bars

# for manipulating the difference between 2 bars
hist(Customer$Age, breaks = c(0,40,60,100)) #we only created 3 catogery
#here by default histogram will take the frequency density

#for viewing the frequency
hist(Customer$Age, breaks = c(0,40,60,100),freq = TRUE)

# we can change the colour of this distribution also
hist(Customer$Age, breaks = c(0,40,60,100),col="purple")

# for changing the heading of the graph
hist(Customer$Age, breaks = c(0,40,60,100),col="purple",main = "Histogram of Ages")

# once the histograph is created u can export it in pdf or image using the export option.


#!/usr/bin/env Rscript
#	Building a statistical model for predicting sediment reworking from fraction of preserved bar structures.
#	Eric Barefoot
#	Oct 2019

# load packages

library(tidyverse)
library(here)
library(broom)
library(lme4)
if (interactive()) {
    require(colorout)
}

# load data

chamb_data = readRDS(file = here('data','derived_data', 'chamberlin_model_data.rds'))

# for helpfulness later - plot up the data with factors, etc
# factors are that the model results were generated by either:
  # (1) compensational avulsions or
  # (2) random avulsions.
# The other factors shown are sets of experiments with the same input overbank/channel material ratio ("input ratio")
# This is a strong controlling factor, and is also mapped to a frac_input continuous variable.

# chamb_data %>%
# ggplot(., aes(x = frac_elems, y = frac_supply)) +
# geom_point(aes(color = exp_set, shape = model))

# We are interested in finding the best predictive model for these data.
# Let's try out some.

# null
# fixed-effects model with
# fixed effects on % fully preserved structures

fixed_model_null = lm(frac_supply ~ frac_elems, data = chamb_data)

# fixed-effects model with
# fixed effects on % fully preserved structures
# fixed effects on input ratio

fixed_model_input = lm(frac_supply ~ frac_elems + frac_input, data = chamb_data)

# fixed-effects model with
# fixed effects on % fully preserved structures
# fixed effects on input ratio
# also interactions between two predictors.

fixed_model_input_interactions = lm(frac_supply ~ frac_elems*frac_input, data = chamb_data)

# AIC(fixed_model_null, fixed_model_input, fixed_model_input_interactions)

# mixed-effects model with
# fixed effects on % fully preserved structures
# random effects on experiment set (proxy for input ratio) mean

mixed_model_int_expSet = lmer(frac_supply ~ frac_elems + (1|exp_set), data = chamb_data)

# mixed-effects model with
# fixed effects on % fully preserved structures
# random effects on experiment set (proxy for input ratio) mean
# random effects on avulsion type mean

mixed_model_int_expSet_avulType = lmer(frac_supply ~ frac_elems + (1|exp_set) + (1|model), data = chamb_data)

# mixed-effects model with
# fixed effects on % fully preserved structures
# random effects on experiment set (proxy for input ratio) mean and slope

mixed_model_slp_expSet = lmer(frac_supply ~ frac_elems + (1 + frac_elems|exp_set), data = chamb_data, REML = FALSE, control = lmerControl(optimizer = 'Nelder_Mead'))

# mixed-effects model with
# fixed effects on % fully preserved structures
# random effects on experiment set (proxy for input ratio) mean and slope
# random effects on avulsion type mean and slope

mixed_model_slp_expSet_avulType = lmer(frac_supply ~ frac_elems + (1+frac_elems|exp_set) + (1+frac_elems|model), data = chamb_data, REML = FALSE)

# mixed-effects model with
# fixed effects on % fully preserved structures
# fixed effects on input ratio
# random effects on experiment set (proxy for input ratio) mean and slope
# random effects on avulsion type mean and slope

mixed_model_input_slp_expSet_avulType = lmer(frac_supply ~ frac_elems + frac_input + (1+frac_elems|model), data = chamb_data, REML = FALSE)

# So after doing all of those models, we need to evaluate them.

models_aic = AIC(fixed_model_null, fixed_model_input, mixed_model_int_expSet, mixed_model_int_expSet_avulType, mixed_model_slp_expSet, mixed_model_slp_expSet_avulType, mixed_model_input_slp_expSet_avulType)

# based on this, it looks like the best model is really the simplest fixed-effects model with the input ratio included.
# That effect seems to be pretty important! Since we have NO way of constraining that in the ancient, the best route forward is determine the sensitivity of the analysis to overbank vs channel deposition and work that in somehow.

# for fun, plot this model on the data.

# chamb_data_pred = chamb_data %>% mutate(pred_supply = predict(fixed_model_input_interactions))
#
# ggplot(data = chamb_data_pred) +
# geom_point(aes(x = frac_elems, y = frac_supply, color = frac_input, shape = model)) +
# geom_point(aes(x = frac_elems, y = pred_supply), color = 'red3')

# export the best model as a derived data product.

saveRDS(fixed_model_input_interactions, file = here('data','derived_data', 'chamberlin_stat_model.rds'))