library(ggplot2)
library(reshape2)

args <- commandArgs(trailingOnly = TRUE)

inputfile = "D:/wd/wur/WellG07.cpout"
inputfile = args[1]
plot_file_names = unlist(strsplit(args[2], ","))
outputdir = args[3]

setwd(outputdir)

inputdata = read.table(inputfile, sep="\t", header=TRUE, fill=T, comment.char="")

cpout = inputdata[inputdata$ImageNumber == 1,]

# ---------------------- find biggest gap in first image ----------------------

y_freq = data.frame(table(cpout$AreaShape_Center_Y))
names(y_freq) = c("y", "freq")
y_freq$y = as.numeric(as.character(y_freq$y))
y_freq$freq = as.numeric(y_freq$freq)

biggest_gap_size = 0
biggest_gap_start = 0
biggest_gap_start_index = 0
biggest_gap_end = 0
biggest_gap_end_index = 0

#print(y_freq)

for(i in 1:(nrow(y_freq)-1)){
  gap_size = y_freq[i+1,]$y - y_freq[i,"y"]
  if(gap_size > biggest_gap_size){
    biggest_gap_size = gap_size
    biggest_gap_start = y_freq[i,"y"]
    biggest_gap_start_index = i

    biggest_gap_end_index = i+1
    biggest_gap_end = y_freq[i,"y"]
  }
}

#search up/down through the image for smaller gaps
while((y_freq[biggest_gap_start_index,"y"] - y_freq[biggest_gap_start_index-1, "y"]) > 1){
  biggest_gap_start_index = biggest_gap_start_index - 1
}
biggest_gap_start = y_freq[biggest_gap_start_index,"y"]

while(y_freq[biggest_gap_end_index + 1,"y"] - y_freq[biggest_gap_end_index,"y"] > 1){
  biggest_gap_end_index = biggest_gap_end_index + 1
}
biggest_gap_end = y_freq[biggest_gap_end_index,"y"]

# ---------- for every image, find how many are inside the gap, plot them ----------

image_numbers = unique(inputdata$ImageNumber)
number_of_images = length(image_numbers)
result = data.frame(image=1:number_of_images, inside=1:number_of_images, outside=1:number_of_images, total=1:number_of_images)
for(i in image_numbers){
  name = paste("Image_", i, ".cpout", sep="")
  cpout = inputdata[inputdata$ImageNumber == i,]
  inside_rows = cpout$AreaShape_Center_Y >= biggest_gap_start & cpout$AreaShape_Center_Y <= biggest_gap_end
  inside = sum(inside_rows)
  result[i,"inside"] = inside
  total = nrow(cpout)
  result[i,"total"] = total
  outside = total - inside
  result[i,"outside"] = outside

  cpout$col = factor(ifelse(cpout$AreaShape_Center_Y >= biggest_gap_start & cpout$AreaShape_Center_Y <= biggest_gap_end, paste("inside -", inside), paste("outside -", outside)))

  p = ggplot(cpout, aes(AreaShape_Center_X, AreaShape_Center_Y))
  p = p + geom_point(aes(colour = col)) #+ scale_colour_manual(values=c("red", "blue"))
  p = p + geom_rect(xmin = 0, xmax = Inf,   ymin = biggest_gap_start, ymax = biggest_gap_end,   fill = "red", alpha = 0.0002)
  p = p + ggtitle(paste("Nuclei_", plot_file_names[i], " - " , total, sep=""))

  png(paste("Nuclei_", plot_file_names[i], ".png", sep=""))
  print(p)
  dev.off()
	cpout$col = gsub(" - .*", "", cpout$col)
	write.table(cpout[,c("AreaShape_Center_X", "AreaShape_Center_Y", "col")], paste("Nuclei_", plot_file_names[i], ".txt", sep=""), sep="\t", row.names=F, col.names=T, quote=F)
}

test = melt(result, id.vars=c("image"))
png("bar.png")
ggplot(test, aes(x=image, y = value, fill=variable, colour=variable)) + geom_bar(stat='identity', position='dodge' )
dev.off()
png("line.png")
ggplot(test, aes(x=image, y = value, fill=variable, colour=variable)) + geom_line()
dev.off()

write.table(result, "numbers.txt", sep="\t", row.names=F, col.names=T, quote=F)
write.table(result, "numbers_no_header.txt", sep="\t", row.names=F, col.names=F, quote=F)

growth = data.frame(image=result$image[2:nrow(result)], inside_growth=diff(result$inside), outside_growth=diff(result$outside), total_growth=diff(result$total))

write.table(growth, "growth.txt", sep="\t", row.names=F, col.names=T, quote=F)

summ <- do.call(data.frame,
               list(mean = apply(growth, 2, mean),
                    sd = apply(growth, 2, sd),
                    median = apply(growth, 2, median),
                    min = apply(growth, 2, min),
                    max = apply(growth, 2, max),
                    n = apply(growth, 2, length)))

summ_numeric_colls = sapply(summ, is.numeric)
summ[,summ_numeric_colls] = round(summ[,summ_numeric_colls], 2)
write.table(summ, "summary.txt", sep="\t", row.names=T, col.names=NA, quote=F)

# ---------- for follow up analysis ----------

result=result[,c("total", "inside")]
result$perc = round((result$inside / result$total) * 100, 2)

write.table(result, "in_out_perc.txt", sep="\t", row.names=F, col.names=F)

# ---------- csv for d3.js? ----------

write.table(inputdata[,c("ImageNumber", "ObjectNumber", "AreaShape_Center_X", "AreaShape_Center_Y")], file="objects.csv", quote=F, sep=",", row.names=F, col.names=T)


library(tidyverse)
library(data.table)
library(albersusa)
library(quantmod)
library(gganimate)
library(ggforce)
library(ggrepel)
library(extrafont)
library(uuid)
library(scales)

loadfonts(device = "win")
font_family = 'Calibri'

us_pop = getSymbols('POP', src = 'FRED', auto.assign = F)
us_pop_df =
  tibble(
    population = as.numeric(us_pop$POP * 1000),
    date = index(us_pop),
    year = year(date)
  ) %>%
  arrange(date) %>%
  group_by(year) %>%
  summarize(
    year_end_pop = tail(population, 1)
  )

us_sf <- usa_sf("laea")

setwd("~/Public_Policy_Upd/Projects/Voting/data")

heritage_voterfraud_database = read_csv("heritage_voterfraud_database.csv")
fraud_stats_by_year = group_by(heritage_voterfraud_database, Year) %>%
  summarize(
    count = n()
  )

##### Get political data #####

# MIT data lab

get_margins_by_race = function(grouped_df) {

  margins_by_race = grouped_df %>%
    summarize(
      total_votes = totalvotes[1],
      n_candidates = n_distinct(candidate[writein == FALSE]),
      top_vote_count = candidate_votes[1],
      second_vote_count = ifelse(n_candidates > 1, candidate_votes[2], 0)
    ) %>%
    ungroup() %>%
    mutate(
      uncontested = total_votes <= 1 | n_candidates <= 1,
      winning_margin = top_vote_count - second_vote_count,
      winning_margin_pct = winning_margin / total_votes
    )

  return(margins_by_race)
}

house_elections = read.csv('1976-2018-house.csv') %>%
  mutate(candidate_votes = as.numeric(candidatevotes %>% str_remove(','))) %>%
  filter(stage == 'gen') %>%
  arrange(state, year, district, -candidate_votes )

margins_by_house_race = get_margins_by_race(house_elections %>%
                                              group_by(state, year, district)) %>%
  mutate(
    race_id = paste(state, year, district, sep = '_')
  )

house_totals_by_state_year = group_by(margins_by_house_race, state, year) %>%
  summarize(
    house_total_votes = sum(total_votes, na.rm = T)
  )

group_by(margins_by_house_race, year) %>%
  summarize(
    n_races = n_distinct(race_id)
  )

# get winning margins for house, senate, and president
# get total votes for each race as well

senate_elections = read.csv('1976-2018-senate.csv') %>%
  mutate(candidate_votes = as.numeric(candidatevotes %>% str_remove(','))) %>%
  filter(stage == 'gen') %>%
  arrange(state, year, district, -candidate_votes )

margins_by_senate_race = get_margins_by_race(senate_elections %>% group_by(state, year, district))

senate_totals_by_state_year = group_by(margins_by_senate_race, state, year) %>%
  summarize(
    senate_total_votes = sum(total_votes, na.rm = T)
  )

presidential_elections = read.csv('1976-2016-president.csv') %>%
  mutate(candidate_votes = as.numeric(candidatevotes %>% str_remove(','))) %>%
  arrange(state, year, -candidate_votes )

margins_by_presidential_race = get_margins_by_race(presidential_elections %>% group_by(state, year))
president_totals_by_state_year = group_by(margins_by_presidential_race, state, year) %>%
  summarize(
    president_total_votes = sum(total_votes, na.rm = T)
  )

combined_margin_analysis = bind_rows(
  margins_by_house_race %>% mutate(race = 'House', district = as.character(district)) %>% filter(!uncontested) %>% select(state, year, district, race, winning_margin, winning_margin_pct),
  margins_by_senate_race %>% mutate(race = 'Senate') %>% filter(!uncontested) %>% select(state, year, district, race, winning_margin, winning_margin_pct),
  margins_by_presidential_race %>% mutate(race = 'President', district = 'statewide') %>% select(state, year, district, race, winning_margin, winning_margin_pct)
) %>%
  mutate(
    race_id = 1:length(year),
    plot_order = 7
  )
races_less_1k_margin = filter(combined_margin_analysis, winning_margin <= 1000) %>% nrow()
percent_races_less_1k_margin = races_less_1k_margin / nrow(combined_margin_analysis)

total_votes_by_year_state = full_join(
  house_totals_by_state_year,
  senate_totals_by_state_year,
  by = c('state', 'year')
) %>%
  full_join(
    president_totals_by_state_year, by = c('state', 'year')
  ) %>%
  mutate(
    annual_total_votes = pmax(
      house_total_votes,  senate_total_votes, president_total_votes,
      na.rm = T
    )
  )

total_votes_by_year = group_by(total_votes_by_year_state, year) %>%
  summarize(
    total_votes = sum(annual_total_votes, na.rm = T)
  ) %>%
  bind_rows(
    data.frame(
      year = 2020,
      total_votes = 81283077 + 74222965
    )
  ) %>%
  left_join(us_pop_df)

# https://www.weather.gov/safety/lightning-odds

yearly_odds_lightning = 1/1222000
not_struck = 1-yearly_odds_lightning
odds_struck_in_50_years = 1-(not_struck^80)
odds_struck_in_50_years

voter_fraud_counts_2009_2018 = filter(fraud_stats_by_year, Year >= 2009, Year <= 2018)
total_fraud_cases = sum(voter_fraud_counts_2009_2018$count)
annual_avg_fraud_cases = total_cases / length(2018:2009)
lighning_strikes_per_year = 270
lightning_strikes_over_period = lighning_strikes_per_year * length(2018:2009)

total_votes_2009_2018 = filter(total_votes_by_year, between(year, 2009, 2018)) %>% pull(total_votes) %>% sum()
ratio_lightning_fraud = lighning_strikes_per_year / annual_avg_fraud_cases

get_circle_radius = function(area) {
  (area / pi)^(1/2)
}

# title, circle 1, circle 1:2, title, circle 1:3
# People are more likely to be struck by lightning\nthan commit voter fraud.

circle_areas = tibble(
  counts = c(total_fraud_cases, lightning_strikes_over_period, total_votes_2009_2018),
  circle_alphas = c(.9, 0.75, 0.65),
  desc = c('proven cases of voter fraud',
           'lightning strikes on people', 'votes in federal elections'),
  source = c('Heritage Foundation\nVoter Fraud Database', 'Weather.gov','MIT Election Lab'),
  circle_r = get_circle_radius(counts),
  circle_desc = sprintf('There were %s %s\nbetween 2009 and 2018', comma(counts), desc),
  voter_fraud_label = c(NA, 'Voter Fraud', 'Voter fraud is represented\nby this pixel'),
  voter_fraud_label_y = c(0, min(circle_r) * .25, min(circle_r) * 230),
  circle_label = c('Voter Fraud', 'Lightning Strikes on People', 'Votes in Federal Elections'),
  circle_label_y = c(0, -get_circle_radius(lightning_strikes_over_period) * .85, -get_circle_radius(total_votes_2009_2018) * .85),
  source_label = sprintf('Source: %s', source),
  order = 1:length(counts)
) %>%
  mutate(
    circle_desc = ifelse(circle_alphas == 0, desc, circle_desc),
    source_label = ifelse(circle_alphas == 0, source, source_label),
    desc_position = ifelse(circle_alphas == 0, 0, circle_r * 1.2),
    desc_size = c(10, 10, 10)
  )

stacked_circle_dat = bind_rows(
  tibble(
    plot_order = 1,
    circle_desc = 'Americans are more likely to be\nstruck by lightning\nthan commit voter fraud.',
    desc = circle_desc,
    source_label = 'Chart: Taylor G. White (@t_g_white)',
    desc_position = 0, desc_size = 20,
    voter_fraud_label = NA,
    circle_label = NA,
    circle_label_y = 0,
    voter_fraud_label_y = 0,
    circle_alphas = 0,
    circle_r = min(circle_areas$circle_r)
  ),
  filter(circle_areas, order == 1) %>% mutate(plot_order = 2),

  filter(circle_areas, order %in% 1:2) %>%
    mutate(plot_order = 3,
           voter_fraud_label = ifelse(order < 2, NA, voter_fraud_label),
           circle_label = ifelse(order < 2, NA, circle_label),
           source_label = ifelse(order < 2, NA, source_label),
           circle_desc = ifelse(order < 2, NA, circle_desc),
    ),
  tibble(
    plot_order = 4,
    circle_desc = 'Voter fraud represents a small proportion of all votes cast.' %>% str_wrap(20),
    desc = "fraud in federal elections desc",
    source_label = '',
    desc_position = 0, desc_size = 20,
    voter_fraud_label = NA,
    circle_label = NA,
    circle_label_y = 0,
    voter_fraud_label_y = 0,
    circle_alphas = 0,
    circle_r = min(circle_areas$circle_r)
  ),
  filter(circle_areas, order %in% 1:3) %>%
    mutate(plot_order = 5,
           voter_fraud_label = ifelse(order < 3, NA, voter_fraud_label),
           circle_label = ifelse(order < 3, NA, circle_label),
           source_label = ifelse(order < 3, NA, source_label),
           circle_desc = ifelse(order < 3, NA, circle_desc),
    ),
  tibble(
    plot_order = 6,
    circle_desc = "Voter fraud is rare because it doesn't pay off." %>% str_wrap(24),
    desc = "doesn't pay off",
    source_label = '',
    desc_position = 0, desc_size = 20,
    voter_fraud_label = NA,
    circle_label = NA,
    circle_label_y = 0,
    voter_fraud_label_y = 0,
    circle_alphas = 0,
    circle_r = min(circle_areas$circle_r)
  ),
  tibble(
    plot_order = 7,
    # circle_desc = NA,
    circle_desc = 'Few federal elections are close enough to be impacted by fraud.' %>% str_wrap(32),
    desc = "close race desc",
    source_label = '',
    desc_position = 0,
    desc_size = 20,
    voter_fraud_label = NA,
    circle_label = NA,
    circle_label_y = 0,
    voter_fraud_label_y = 0,
    circle_alphas = 0,
    circle_r = 0.0001
  ),
  tibble(
    plot_order = 8,
    # circle_desc = NA,
    circle_desc = sprintf('Only %s percent of the %s contested federal elections between 1976-2018 were decided by a thousand votes or less.', percent(percent_races_less_1k_margin, accuracy = 0.01), comma(nrow(combined_margin_analysis))) %>% str_wrap(32),
    desc = "close race desc",
    source_label = '',
    desc_position = 0,
    desc_size = 20,
    voter_fraud_label = NA,
    circle_label = NA,
    circle_label_y = 0,
    voter_fraud_label_y = 0,
    circle_alphas = 0,
    circle_r = 0.0001
  ),
  tibble(
    plot_order = 9,
    # circle_desc = NA,
    circle_desc = 'Large-scale fraud carries a strong punishment and can be detected easily, which serves as a deterrent.' %>% str_wrap(28),
    desc = "last panel desc",
    source_label = '',
    desc_position = 0,
    desc_size = 20,
    voter_fraud_label = NA,
    circle_label = NA,
    circle_label_y = 0,
    voter_fraud_label_y = 0,
    circle_alphas = 0,
    circle_r = 0.0001
  )
) %>%
  mutate(
    circle_x = 0,
    circle_y = 0
  )

plot_colors = c('white', '#e41a1c', 'yellow', 'white','#386cb0', 'white', 'white', 'white')
names(plot_colors) = c('People are more likely to be\nstruck by lightning\nthan commit voter fraud.',
                       "proven cases of voter fraud", "lightning strikes on people",
                       "fraud in federal elections desc",
                       "votes in federal elections", "doesn't pay off", 'close race desc', "last panel desc")

combined_margin_analysis_counts = group_by(combined_margin_analysis, year, winning_margin <= 1000) %>%
  summarize(
    obs = n()
  ) %>%
  ungroup() %>%
  rename(
    close_margin = `winning_margin <= 1000`
  ) %>%
  mutate(
    plot_order = 7
  )

seg_dat = data.frame(plot_order = 5, x = 0, y = min(circle_areas$circle_r) * 130)

fraud_anim = ggplot(stacked_circle_dat) +
  geom_circle(aes(x0 = circle_x, y0 = circle_y, r = circle_r, fill = desc, alpha = circle_alphas, group = plot_order), colour = NA, na.rm = T) +
  # geom_bar(data = combined_margin_analysis_counts, aes(year, obs, fill = close_margin, group = plot_order), show.legend = F, stat = 'identity') +
  coord_equal() +
  scale_size(guide = F, range = c(6.5, 9)) +
  scale_alpha(guide = F, range = c(0, .75)) +
  theme_bw() +
  theme_void() +
  scale_fill_manual(guide = F, values = plot_colors) +
  geom_text(aes(x = circle_x, y = desc_position, label = circle_desc, size = desc_size), fontface = 'bold', family = font_family, show.legend = F, na.rm = T) +
  geom_text(aes(x = circle_x, y = -circle_r * 1.2, label = source_label), family = font_family, size = 6, fontface = 'italic') +
  geom_text(aes(x = circle_x, y = voter_fraud_label_y, label = voter_fraud_label), na.rm = T, family = font_family, size = 6) +
  geom_text(aes(x = circle_x, y = circle_label_y, label = circle_label), na.rm = T, family = font_family, size = 6) +
  geom_segment(data = seg_dat, aes(x = 0, xend = 0, y = 0, yend = y, group = plot_order), size = 0.25) +
  transition_states(
    plot_order,
    transition_length = 2,
    state_length = 8
  ) +
  # shadow_mark(exclude_layer = c(2, 3, 4, 5)) +
  view_zoom(pause_length = 40, step_length = 10, nsteps = max(stacked_circle_dat$plot_order), ease = 'sine-in-out')

setwd('~/Public_Policy_Upd/Projects/Voting/output')

animate(fraud_anim,
         renderer = gifski_renderer("fraud_frequency_comparison_upd.gif"),
          nframes = 300,
         height = 8, width = 8, units = 'in',  type = 'cairo-png', res = 200)

# consider creating barchart, saving that down separately, and then reading that in as a set of pixels
# plot the pixels and view_zoom will show it perfectly.
# http://mfviz.com/r-image-art/


#' Convert data to target units
#'
#' This converts flat data to target units as defined in the dataset. It creates three new columns in your dataset: 1. The converted unit value, 3. the conversion factor used, & 4. a recommended acceptance/rejection based on pairs of input & target units.
#' All original columns are retained.
#' @param x Input dataset.
#' @param input_unit Column name of x with units to convert from (in quotes).
#' @param target_unit Column name of x with units to convert to (in quotes).
#' @param value_var Column name of x containing result values (in quotes).
#' @param conv_val_col Name of new values column for converted values (in quotes).

#' @examples
#' # Make example data
#' value=c(abs(rnorm(5,1, 0.1)), rnorm(5, 1000, 100), rnorm(5, 20, 1))
#' raw_units=c(rep('mg/l',5), rep('ug/L', 5), rep('deg C',5))
#' preferred_units=c(rep('mg/L', 10), rep('deg C',5))
#' data=data.frame(value,raw_units,preferred_units)
#' data
#'
#' # Unit conversion
#' conv_data=convertUnits(data, input_units='raw_units', target_units='preferred_units', value_var='value', conv_val_col='converted_value')
#' conv_data

#' @export
convertUnits=function(x, input_units, target_units='target_unit', value_var, conv_val_col='converted_value'){

	if(! input_units %in% names(x)){stop('input_units name not in x')}
	if(! target_units %in% names(x)){stop('target_units name not in x')}

	unit_conv_table=read.csv(system.file("extdata", "unit_conv_table.csv", package = "wqTools"))

	names(unit_conv_table)[names(unit_conv_table)=='target_unit'] = paste(target_units)
	names(unit_conv_table)[names(unit_conv_table)=='input_unit'] = paste(input_units)
	x=merge(x, unit_conv_table, all.x=T)
	x[,input_units]=as.character(x[,input_units])
	x[,target_units]=as.character(x[,target_units])

	conv_x=x
	conv_x$conversion_flag[is.na(conv_x$conversion_factor) & toupper(conv_x[,input_units])==toupper(conv_x[,target_units])] = "ACCEPT"
	conv_x$conversion_factor[is.na(conv_x$conversion_factor) & toupper(conv_x[,input_units])==toupper(conv_x[,target_units])] = 1
	conv_x$conv_val_col = conv_x[,value_var] * conv_x[,'conversion_factor']
	if(any(is.na(conv_x$conv_val_col) & !is.na(conv_x[,value_var]))){
		warning('Unable to convert one or more unit combinations. These values are expressed as NA.')
	}

	names(conv_x)[names(conv_x)=='conv_val_col'] = conv_val_col

	return(conv_x)
}


#' Greedy ensemble selection for regression model
#'
#'
#' Medley is a package which implements the Caruana et al., 2004 algorithm for
#' stepwise greedy ensemble selection in R, allowing disparate regression
#' models to be combined easily.
#'
#' @author Martin O'Leary \email{m.e.w.oleary@@gmail.com}
#' @name medley
#' @docType package
NULL


setwd('/home/pc-752828/Dev/results-search-master/outputs-normal')

library(ggplot2)
library(reshape2)
library(ggstatsplot)
library(tcltk)
library(rstatix)
library(PMCMRplus)
library(pgirmess)

data_norm <- read.csv(file = 'output-n-norm.csv', sep = ',', header = T)
data_def <- read.csv(file = 'output-n-price.csv', sep = ',', header = T)

get_df <- function(seed, data) {
  my_ite <- 10
  bo1 <- list()
  bo2 <- list()
  bo3 <- list()
  bo4 <- list()
  rs <- list()
  app <- list()
  seed_l <- list()

  for(i in levels(factor(data$name))) {
    r_bo1 <- data[data['name'] == i & data['bo'] == 'bo1' & data['ite'] == my_ite,][seed,]
    r_bo4 <- data[data['name'] == i & data['bo'] == 'bo4' & data['ite'] == my_ite,][seed,]
    r_bo3 <- data[data['name'] == i & data['bo'] == 'bo3' & data['ite'] == my_ite,][seed,]
    r_bo2 <- data[data['name'] == i & data['bo'] == 'bo5' & data['ite'] == my_ite,][seed,]
    r_rs <- data[data['name'] == i & data['bo'] == 'rs' & data['ite'] == my_ite,][seed,]
    bo1 <- append(bo1, levels(factor(r_bo1$best)))
    bo2 <- append(bo2, levels(factor(r_bo2$best)))
    bo3 <- append(bo3, levels(factor(r_bo3$best)))
    bo4 <- append(bo4, levels(factor(r_bo4$best)))
    rs <- append(rs, levels(factor(r_rs$best)))
    app <- append(app, i)
    seed_l <- append(seed_l, seed)
  }

  df <- cbind(bo1, bo2, bo3, bo4, rs, app)
  df <- data.frame(df)
  df$bo1 = as.numeric(as.character(df$bo1))
  df$bo2 = as.numeric(as.character(df$bo2))
  df$bo3 = as.numeric(as.character(df$bo3))
  df$bo4 = as.numeric(as.character(df$bo4))
  df$rs = as.numeric(as.character(df$rs))

  return(df)
}

df_1 <- get_df(1, data_norm)
df_2 <- get_df(2, data_norm)
df_3 <- get_df(3, data_norm)
df_4 <- get_df(4, data_norm)
df_5 <- get_df(5, data_norm)

df_1 <- get_df(1, data_def)
df_2 <- get_df(2, data_def)
df_3 <- get_df(3, data_def)
df_4 <- get_df(4, data_def)
df_5 <- get_df(5, data_def)

df_norm <- rbind(df_1, df_2, df_3, df_4, df_5)
df_def <- rbind(df_1, df_2, df_3, df_4, df_5)

df <- df_norm

summary(df$bo1)
summary(df$bo2)
summary(df$bo3)
summary(df$bo4)
summary(df$rs)

df_1

ks.test(df_5$bo1, "pnorm")
ks.test(df_5$bo2, "pnorm")
ks.test(df_5$bo3, "pnorm")
ks.test(df_5$bo4, "pnorm")
ks.test(df_5$rs, "pnorm")

df <- df_1

cols <- c("BO-6rnd-EIdef","BO-6rnd-EInova","BO-6sel-EIdef", "PB3Opt", "Ranking Search", "ID")
colnames(df) <- cols
df$ID = as.character(df$ID)
df$ID <- factor(df$ID)
cols <- c("BO-6rnd-EIdef","BO-6rnd-EInova","BO-6sel-EIdef", "PB3Opt", "Ranking Search")
new_df <- melt(df, id = c("ID"), measured = cols)
glimpse(new_df)
friedman.test(value ~ variable | ID, data = new_df)

new_df %>% friedman_effsize(value ~ variable | ID)

colnames(new_df) <- c("ID", "Abordagem", "Best")
frdAllPairsSiegelTest (new_df$Best, new_df$Abordagem, new_df$ID, p.adjust = "bonferroni")
frdAllPairsConoverTest(new_df$Best, new_df$Abordagem, new_df$ID, p.adjust = "bonferroni")
frdAllPairsNemenyiTest(new_df$Best, new_df$Abordagem, new_df$ID, p.adjust = "bonferroni")

new_df %>% group_by(Abordagem) %>%
  get_summary_stats(Best, type = "median_iqr")

list_id <- cols
list_value <- list(
length(which(df$`BO-6rnd-EIdef`==1))/length(df$PB3Opt),
length(which(df$`BO-6rnd-EInova`==1))/length(df$PB3Opt),
length(which(df$`BO-6sel-EIdef`==1))/length(df$PB3Opt),
length(which(df$PB3Opt==1))/length(df$PB3Opt),
length(which(df$`Ranking Search`==1))/length(df$PB3Opt)
)

df <- cbind(list_id, list_value)
df <- data.frame(df)
df

df$list_id = as.character(df$list_id)
df$list_value = as.numeric(as.character(df$list_value))

glimpse(df)

tikz('bar1.tex')

ggplot(df) +
  geom_bar( aes(x=list_id, y=list_value), stat="identity", alpha=0.7)+
  labs(color = element_blank(), x="Abordagem", y="Frequência da Melhor Solução ()")+
  theme_bw()

dev.off()

write.csv(x=df_1,file="teste-new.csv", row.names = FALSE)

p1<-ggplot(new_df, aes(x = value, y= variable,  add = "jitter"))+
  geom_boxplot(alpha=0.7, colour = "black", fill="gray")+
  stat_summary(fun=mean, geom="point", shape=20, size=2, color="red", fill="red") +
  theme(legend.position="none")+
  theme(panel.background = element_rect(fill = 'white', colour = 'gray'),
        panel.grid.major = element_line(color = 'light gray'),
        panel.grid.minor = element_line(color = 'light gray'),
        axis.title.y=element_blank(),
        axis.text.y = element_text(size=8))+
  ggtitle('a) Boxplot do Melhor Custo Encontrado')+
  labs(color = element_blank(), x="Custo Normalizado", y="Frequência")

ylim1<- c(1, 3)
p2<-p1 + coord_cartesian(xlim = ylim1) +
  ggtitle('b) Zoom da Figura a')

tikz('boxplot.tex')
grid.arrange(p1, p2, nrow = 2, ncol=1, top="", left="Abordagem")

dev.off()

par(mfrow=c(2, 3))

boxplot(df$bo1,df$bo2, df$bo3, df$bo4, df$rs, xlab = "Abordagem", ylab = "Custo Normalizado", outline = FALSE)
grid(nx=16, ny=16)
boxplot(df$bo1,df$bo2, df$bo3, df$bo4, df$rs,
        xlab = "Abordagem",
        ylab = "Custo Normalizado",
        names=c('A1', 'A2', 'A3', 'A4', 'A5'))
legend("topright", inset=c(-0.2,0),legend=c("A1 - BO-6rnd-EIdef",
                                            "A2 - BO-6rnd-EInova",
                                            "A3 - BO-6sel-EIdef",
                                            "A4 - BO3Opt",
                                            "A5 - Ranking Search"),
       fill=c("white","white","white","white","white"), bty = "n")


## library(plyr)
## library(meffil)
## library(splitstackshape)
## library(matrixStats)

#' Calculate CNVs from IDAT files
#'
#' Based on the algorithm developed in \code{R/CopyNumber450k} bioconductor package
#'
#' @param samplesheet Output from \code{meffil.create.samplesheet}
#' @param cnv.reference Name returned by \code{\link{meffil.list.cnv.references}()}.
#' @param chip Name returned by \code{\link{meffil.list.chips()}} (Default: NA).
#' @param verbose Default = FALSE
#' @param ... Extra parameters to be passed to \code{DNAcopy} for segmentation. See details.
#'
#' @details
#' The following default values are being used:
#' - trim = 0.1
#' - min.width = 5
#' - nperm = 10000
#' - alpha = 0.001
#' - undo.splits = "sdundo"
#' - undo.SD = 2
#'
#' @export
#' @return Dataframe of segmented results
meffil.calculate.cnv <- function(samplesheet, cnv.reference, chip=NA, verbose=FALSE, ...) {
    cnv.reference <- meffil:::get.cnv.reference(cnv.reference)
    l1 <- meffil:::get.index.list(nrow(samplesheet), options("mc.cores")[[1]])

    l <- lapply(l1, function(x) {
        l2 <- mclapply(x, function(i) {
            calculate.cnv(samplesheet$Basename[i],
                          samplesheet$Sample_Name[i],
                          cnv.reference=cnv.reference,
                          chip=chip,
                          verbose=verbose, ...)
        })
        names(l2) <- samplesheet$Sample_Name[x]
        return(l2)
    })
    nom <- unlist(sapply(l, names))
    l <- unlist(l, recursive=FALSE)
    names(l) <- nom
    return(l) # list of data frames (output of calculate.cnv), one per sample
}

calculate.cnv <- function(bname, samplename=basename(bname), cnv.reference,
                          chip=NA,
                          trim=0.1, min.width = 5, nperm = 10000, alpha = 0.001,
                          undo.splits = "sdundo", undo.SD = 2, verbose = TRUE, smoothing=TRUE) {
    msg("Reading idat file for", bname, verbose=verbose)
    rg <- meffil:::read.rg(bname, verbose=verbose)

    chip <- meffil:::guess.chip(rg, chip)

    featureset <- cnv.reference$featureset

    probes <- meffil.probe.info(chip, featureset)
    case <- meffil:::mu.to.cn(meffil:::rg.to.mu(rg, probes))

    msg("Predicting sex", verbose=verbose)
    sex <- meffil:::cnv.predict.sex(case, featureset)

    if (ncol(cnv.reference$intensity.sex[[sex]]) == 0)
        stop(paste("Sample is predicted to be",
                   ifelse(sex == "M", "male", "female"),
                   "but none found in CNV reference."))

    msg("Normalisting against controls", verbose=verbose)
    int.sex <- case[rownames(cnv.reference$intensity.sex[[sex]])]
    int.sex[order(int.sex)] <- sort(cnv.reference$intensity.sex[[sex]][,1])

    int.aut <- case[rownames(cnv.reference$intensity.aut)]
    int.aut[order(int.aut)] <- sort(cnv.reference$intensity.aut[,1])

    msg("Estimating CNVs", verbose=verbose)
    int.sex.prop <- log2(int.sex / cnv.reference$control.medians.sex[[sex]])
    int.aut.prop <- log2(int.aut / cnv.reference$control.medians.aut)

    features <- meffil:::cnv.features(featureset)

    int.sex.prop <- int.sex.prop[names(int.sex.prop) %in% features$name]
    int.aut.prop <- int.aut.prop[names(int.aut.prop) %in% features$name]

    p.sex <- features[match(names(int.sex.prop), features$name),c("name","chromosome","position")]
    p.aut <- features[match(names(int.aut.prop), features$name),c("name","chromosome","position")]

    cna.sex <- CNA(int.sex.prop, chrom=p.sex$chromosome, maploc=p.sex$position,
                   data.type="logratio", sampleid=samplename)
    cna.aut <- CNA(int.aut.prop, chrom=p.aut$chromosome, maploc=p.aut$position,
                   data.type="logratio", sampleid=samplename)

    if(smoothing) {
        cna.sex <- smooth.CNA(cna.sex, trim=trim)
        cna.aut <- smooth.CNA(cna.aut, trim=trim)
    }

    segment.cna.sex <- segment(cna.sex, min.width=min.width, verbose = verbose, nperm = nperm,
                               alpha = alpha, undo.splits = undo.splits, undo.SD = undo.SD,
                               trim = trim)
    segment.cna.aut <- segment(cna.aut, min.width=min.width, verbose = verbose, nperm = nperm,
                               alpha = alpha, undo.splits = undo.splits, undo.SD = undo.SD,
                               trim = trim)
    out <- rbind(segment.cna.aut$output, segment.cna.sex$output)
    out$chrom <- ordered(out$chrom, levels = paste("chr", c(1:22, "X","Y"), sep=""))
    out$ID <- samplename

    msg("Calculating p-values", verbose=verbose)
    out <- meffil:::cnv.pvalue(out, int.aut, int.sex, sex, cnv.reference)
    return(out)
}

get.index.list <- function(n, mc.cores) {
    mc.cores <- ifelse(is.null(mc.cores) || mc.cores < 1, 1, min(mc.cores, n))
    div <- floor(n / mc.cores)
    rem <- n %% mc.cores
    l1 <- lapply(1:div, function(x) (x-1) * mc.cores + 1:mc.cores)
    if(rem != 0) l1[[div+1]] <- l1[[div]][mc.cores] + 1:rem
    return(l1)
}

mu.to.cn <- function(mu) {
    mu$M + mu$U
}

cnv.predict.sex <- function(cn, featureset, sex.cutoff=-2) {
    log.cn <- log2(cn)

    sites.x <- meffil.get.x.sites(featureset)
    stopifnot(all(sites.x %in% names(log.cn)))
    x.signal <- median(log.cn[sites.x], na.rm=T)

    sites.y <- meffil.get.y.sites(featureset)
    stopifnot(all(sites.y %in% names(log.cn)))
    y.signal <- median(log.cn[sites.y], na.rm=T)

    xy.diff <- y.signal-x.signal
    ifelse(xy.diff < sex.cutoff, "F", "M")
}

cnv.pvalue <- function(out, int.aut, int.sex, sex, cnv.reference) {
    ## Get the sum of the intensities for the probes in each of the controls
    ## Get the mean sum of intensities
    ## Get the SD of the sum of intensities
    ## Get the sum of intensities of probes in the target
    features <- cnv.features(cnv.reference$featureset)
    for(i in 1:nrow(out)) {
        feature.sub <- subset(features, (chromosome == out$chrom[i]
                                         & position <= out$loc.end[i]
                                         & position >= out$loc.start[i]))$name
        if(out$chrom[i] %in% c("chrX", "chrY")) {
            control.int.sum <- colSums(cnv.reference$intensity.sex[[sex]][feature.sub, , drop=FALSE])
            sample.sum <- sum(int.sex[feature.sub])
        } else {
            control.int.sum <- colSums(cnv.reference$intensity.aut[feature.sub, , drop=FALSE])
            sample.sum <- sum(int.aut[feature.sub])
        }
        control.mean <- mean(control.int.sum)
        control.sd <- sd(control.int.sum)

        z.score <- (sample.sum - control.mean)/control.sd
        pval <- 2 * pnorm(-abs(z.score))

        ## Compute p-value (2 sided t-test)
        out$nprobe[i] <- length(feature.sub)
        out$sample.sum[i] <- sample.sum
        out$control.mean[i] <- control.mean
        out$control.sd[i] <- control.sd
        out$z.score[i] <- z.score
        out$pvalue[i] <- pval
    }
    out$adjusted.pvalue <- p.adjust(out$pvalue, method="bonferroni")
    return(out)
}

cnv.features <- function(featureset) {
    features <- meffil.get.features(featureset)
    sites <- features[which(!is.na(features$chromosome)
                            & features$target == "methylation"
                            & !features$snp.exclude),]
    sites$chromosome <- ordered(sites$chromosome, levels=paste("chr", c(1:22, "X", "Y"), sep=""))
    sites <- sites[with(sites, order(chromosome, position, decreasing=F)),]
    sites
}


library(GenomicRanges)
library(SnapATAC)

buenrostro2018_bmat<-readRDS("../input/bmat_buenrostro2018.rds")
rangeList<-readRDS("../input/rangeList_buenrostro2018.rds")
colnames(buenrostro2018_bmat)<-rangeList$name

buenrostro2018_fullRange<-read.table("../input/buenrostro2018_5k_full.txt")

buenrostro2018_bmat_full<-matrix(ncol = length(buenrostro2018_fullRange$V1),nrow = nrow(buenrostro2018_bmat))

rownames(buenrostro2018_bmat_full)<-rownames(buenrostro2018_bmat)
colnames(buenrostro2018_bmat_full)<-buenrostro2018_fullRange$V1

for(i in 1:length(buenrostro2018_fullRange$V1)){
    range<-as.character(buenrostro2018_fullRange$V1[i])
    if(range %in% colnames(buenrostro2018_bmat)){
        buenrostro2018_bmat_full[,range]<-buenrostro2018_bmat[,range]
    } else{
        buenrostro2018_bmat_full[,range]<-0
    }
    print(paste0(i,"/",length(buenrostro2018_fullRange$V1)," finished"))
}
buenrostro2018_bmat_full<-as(buenrostro2018_bmat_full,"dgCMatrix")

saveRDS(buenrostro2018_bmat_full,file="../output/buenrostro2018-snap-full.rds")


data("mtcars")
library(dplyr)
arrange(mtcars,mtcars$mpg+mtcars$carb+mtcars$cyl)

R Community/R functions Assignments/Assignment6.r


context("Mentor matching")

# ------------------------------------------------------------------------------
test_that("Mentor matching", {
  set.seed(1)

  g <- igraph::make_graph(~1--2,1--3,1--4,4--5,6)
  g <- igraph::as_adj(g)

  ans <- mentor_matching(g, 2)
  expect_equal(sort(unique(ans$match)), as.character(c(1,4)))
})

# ------------------------------------------------------------------------------
test_that("Plot mentor", {
  set.seed(1)

  g <- igraph::make_graph(~1--2,1--3,1--4,4--5,6)
  g <- igraph::as_adj(g)
  ans <- mentor_matching(g, 2)

  expect_silent(plot(ans))
})


#' @useDynLib coop R_co_sparse
co_sparse <- function(n, a, i, j, index, type, use, inverse)
{
  check.is.flag(inverse)

  if (!is.double(a))
    storage.mode(a) <- "double"
  if (!is.integer(i))
    storage.mode(i) <- "integer"
  if (!is.integer(j))
    storage.mode(j) <- "integer"

  use <- check_use(use)
  if (use == "everything")
  {}
  else if (use == "all.obs")
  {
    if (anyNA(a))
      stop("missing observations in covar/pcor/cosine")
  }
  ### TODO
  # else if (use == "complete.obs")
  # {
  #   if (anyNA(x))
  #   {
  #     out <- naomit_coo(a, i, j)
  #     a <- out[[1]]
  #     i <- out[[2]]
  #     j <- out[[3]]
  #   }
  # }
  else
    stop("unsupported 'use' method")

  .Call(R_co_sparse, as.integer(n), a, i, j, as.integer(index), as.integer(type), as.integer(inverse))
}

#' @useDynLib coop R_csc_to_coo
csc_to_coo <- function(row_ind, col_ptr)
{
  .Call(R_csc_to_coo, row_ind, col_ptr)
}


require('ggplot2')
require('dplyr')

csv_path <- '/home/sage/play/ores-changes/spring_2017-articles-2017-09-14.csv'
# csv_path <- '/home/sage/play/ores-changes/visiting_scholars-articles-2017-09-15.csv'
campaign_data <- read.csv(csv_path)
campaign_data$ores_diff <- with(campaign_data, ores_after - ores_before)

# All articles
before <- select(campaign_data, select=('ores_before'))
after <- select(campaign_data, select=('ores_after'))
names(before)[1] = 'structural_completeness'
names(after)[1] = 'structural_completeness'
before$when <- 'before'
after$when <- 'after'
before_after_histogram <- rbind(before, after)

png(filename="before-after.png", width = 600, height = 400)
ggplot(before_after_histogram, aes(structural_completeness, fill=when)) + geom_density(alpha = 0.4, adjust = 1/2)
dev.off()

# major edits + diff
diff <- select(campaign_data, select=('ores_diff'))

major_edits <- campaign_data[campaign_data$bytes_added >= 6000, ]
# major_edits_existing <- major_edits
major_edits_existing <- major_edits[major_edits$ores_before > 0.0, ]
major_diff <- select(major_edits, select=('ores_diff'))

major_edits_existing_before <- select(major_edits_existing, select=('ores_before'))
major_edits_existing_after <- select(major_edits_existing, select=('ores_after'))

names(diff)[1] = 'change_in_structural_completeness'
names(major_diff)[1] = 'change_in_structural_completeness'
names(major_edits_existing_before)[1] = 'structural_completeness'
names(major_edits_existing_after)[1] = 'structural_completeness'

major_edits_existing_before$when <- 'before'
major_edits_existing_after$when <- 'after'

major_edits_existing_histogram <- rbind(major_edits_existing_before, major_edits_existing_after)
png(filename="before-after-major-edits.png", width = 600, height = 400)
ggplot(major_edits_existing_histogram, aes(structural_completeness, fill=when)) + geom_density(alpha = 0.4, adjust = 1/2)
dev.off()

# ggplot(diff, aes(change_in_structural_completeness)) + geom_density(alpha = 0.4, adjust = 1/2)
png(filename="major_articles_improvement.png", width = 600, height = 400)
ggplot(major_diff, aes(change_in_structural_completeness)) + geom_density(alpha = 0.4, adjust = 1/2)
dev.off()

# New articles
new_articles <- campaign_data[campaign_data$ores_before == 0.0, ]
new_articles <- new_articles[new_articles$bytes_added >= 2000, ]
new_articles_after <- select(new_articles, select=('ores_after'))
names(new_articles_after)[1] = 'structural_completeness'
new_articles_after$when <- 'after'

png(filename="new-articles.png", width = 600, height = 400)
ggplot(new_articles_after, aes(structural_completeness, fill=when)) + geom_density(alpha = 0.4, adjust = 1/2)
dev.off()

# Existing articles
existing_articles <- campaign_data[campaign_data$ores_before > 0.0, ]
existing_articles_before <- select(existing_articles, select=('ores_before'))
existing_articles_after <- select(existing_articles, select=('ores_after'))

names(existing_articles_before)[1] = 'structural_completeness'
names(existing_articles_after)[1] = 'structural_completeness'
existing_articles_before$when = 'before'
existing_articles_after$when = 'after'

existing_articles_histogram <- rbind(existing_articles_before, existing_articles_after)
png(filename="existing-before-after.png", width = 600, height = 400)
ggplot(before_after_histogram, aes(structural_completeness, fill=when)) + geom_density(alpha = 0.4, adjust = 1/2)
dev.off()


recode.time.maturity = function( x, time.resolution="daily" ) {
  if (time.resolution == "daily" ) {
    zz = 1
  } else if( time.resolution == "weekly" ) {
    zz = 52/365
  } else if( time.resolution == "monthly" ) {
    zz = 12/365
  }
  x = round( x * zz )
  return(x)
}


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

library(data.table)
library(ggplot2)
library(dplyr)
library(dtplyr)
library(magrittr)

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

if(! file.exists(dirname(ofile))) dir.create(dirname(ofile))

#################
# Load data
load(path_rdata)

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

to_string = dtpval[, sprintf("%s\np=%.3e", group, pval.raw_new)]
names(to_string) = dtpval[, group]

# Color by p-value
dt = merge(dt, dtpval[, .(group, isRs)], by = "group")

## Reorder by p-value
# neworder = dtpval %>% arrange(pval.raw_new) %>% select(group) %>% unlist
# dt[, group := factor(group, levels = neworder)]

title = dtpval$id[1]

# labeller =  dtpval[, sprintf("%s (p=%.3e)", group, pval.raw)]
# names(labeller) = dtpval[,group]
# labeller = as_labeller(labeller)

xmin = dt[, min(bp)]

pdfname = ofile
pdf(pdfname, paper="a4", height = 11, width = 8)

ymax = dt[, max(depth)]

g = ggplot(dt, aes(x = bp, y = depth))
g = g + geom_histogram(stat="identity",  aes(fill = isRs), width=dt$bp[2]-dt$bp[1])
g = g + scale_fill_manual(values = c(`TRUE` = "red", `FALSE`="grey"))
g = g + geom_line(aes(x = bp, y = y.rss.pred), size = 0.2)
g = g + facet_wrap(~group, ncol = 6, strip.position = "left", labeller=as_labeller(to_string))
# g = g + geom_text(data = dtpval, aes(label = sprintf("p=%.3e", pval.raw)), x = xmin, y = ymax, hjust=0, vjust=1)
g = g + ggtitle(title)
g = g + scale_y_continuous(position = "right")
g = g + theme_bw()
# g = g + theme(aspect.ratio = 1/10)
g = g + theme(legend.position = "none")
g = g + theme(panel.grid.major = element_blank(),
              panel.grid.minor = element_blank(),
              panel.background = element_blank(),
              panel.border = element_rect(colour="grey")
)
g = g + theme(strip.background = element_blank())
g = g + theme(strip.text = element_text(size = 2))
g = g + theme(strip.text.y = element_text(angle = 180))
g = g + theme(axis.text.x = element_text(size = 2))
g = g + theme(axis.text.y = element_text(size = 2))
g = g + theme(panel.spacing.y = unit(0, "lines"))
g = g + theme(axis.ticks = element_line(size = 0.1))
g = g + theme(axis.ticks.length = unit(0.1, "lines"))
g = g + theme(aspect.ratio = 1/2)

plot(g)

g = g + facet_wrap(~group, ncol = 6, strip.position = "left", labeller=as_labeller(to_string), scales = "free_y")
plot(g)
# ymax = dt[, max(depth.sm)]

# g = ggplot(dt, aes(x = bp, y = depth.sm))
# g = g + geom_histogram(stat="identity",  aes(fill = group), width=dt$bp[2]-dt$bp[1])
# g = g + scale_fill_manual(breaks = groups, values = color_labels)
# g = g + geom_line(aes(x = bp, y = y.sm.rss.pred))
# g = g + facet_wrap(~group, ncol = 10, strip.position = "left")
# g = g + geom_text(data = dtpval, aes(label = sprintf("p=%.3e", pval.sm)), x = xmin, y = ymax, hjust=0, vjust=1)
# g = g + ggtitle(title)
# g = g + scale_y_continuous(position = "right")
# g = g + theme_bw()
# # g = g + theme(aspect.ratio = 1/10)
# g = g + theme(legend.position = "none")
# g = g + theme(panel.grid.major = element_blank(),
#               panel.grid.minor = element_blank(),
#               panel.background = element_blank()
# )

# print(g)

dev.off()


##########################################################################
# This script plots evolutionary trajectories over time. It will produce #
# two plots: mean fitness over replicate populations over time, and mean #
# epistatis over replicate populations over time.                        #
#                                                                        #
# Author: Dariya K. Sydykova                                             #
##########################################################################

# load packages necessary to run the following script
library(tidyverse)
library(glue)
library(cowplot)
library(readr)
library(here)

# supress scientific notation in R to make plots
options(scipen = 999)

# set up input file. Output plot files are generated automatically and are stored in /evolving_q_sim/test_plots
root_dir <- here() # get the directory of the root of the project
base_name <- "mu_prob0.01_s0.01" # set base name to match input and output files
infile <- paste(root_dir, "/evolving_q_sim/processed_results/evolved_q_", base_name, ".csv", sep = "") # data frame that contains simulation results for the plot

# read in simulation output for evolving q
t <- read_csv(
  infile,
  col_types = cols(
    time = col_integer(),
    sel_coef = col_double(),
    mu_prob = col_double(),
    Ne = col_integer(),
    L = col_integer(),
    k_start = col_integer(),
    q_start = col_double(),
    q_prob = col_double(),
    q_step = col_double(),
    mean_fitness = col_double(),
    mean_q = col_double(),
    rep = col_character(),
    q_prob_label = col_character()
  )
)

# extract output for less time points to reduce the data frame
times_wanted <- seq(0, max(t$time), 100000)
t %>% filter(time %in% times_wanted) -> t_filtered

# # make `rep` (number of replicates) and `q_start` (starting q) into a factor
# # this allows for grouping on two variables possible later
# t_final$rep <- factor(t_final$rep)
# t_final$q_start <- factor(t_final$q_start)

# calculate mean fitness per replicates
t_filtered %>%
  group_by(q_start, q_prob_label, q_step, time) %>%
  summarise(
    mean_rep_fitness = mean(mean_fitness),
    mean_rep_q = mean(mean_q)
  ) ->
t_summary

##########################################################################
# Plotting fitness over time
##########################################################################

# plot fitness over time for different q mutation rate and delta q
p_fitness1 <-
  t_summary %>%
  filter(q_prob_label == "0.0001") %>%
  ggplot(aes(x = time, y = mean_rep_fitness, group = q_start)) +
  geom_line(aes(color = factor(q_start))) +
  scale_y_continuous(
    name = "mean fitness",
    limits = c(0, 1.00),
    breaks = seq(0, 1, 0.2)
  ) +
  scale_x_continuous(
    name = "time (millions)",
    limits = c(0, 100200000),
    breaks = seq(0, 100200000, 25000000),
    labels = c("0", "25", "50", "75", "100")
  ) +
  background_grid(major = "xy", minor = "ny") +
  draw_text(
    x = 0,
    y = 0,
    hjust = 0,
    vjust = 0,
    text = "pr(q) = 0.0001, dq = 0.001",
    size = 12,
    fontface = "bold"
  ) +
  scale_color_manual(
    values = c(
      "#FDE333",
      "#C6E149",
      "#88D867",
      "#38C980",
      "#00B691",
      "#009F99",
      "#008599",
      "#00698F",
      "#324C7F",
      "#432D68",
      "#46024E"
    )
  )

p_fitness2 <- t_summary %>%
  filter(q_prob_label == "0.001") %>%
  ggplot(aes(x = time, y = mean_rep_fitness, group = q_start)) +
  geom_line(aes(color = factor(q_start))) +
  scale_y_continuous(
    name = "mean fitness",
    limits = c(0, 1.00),
    breaks = seq(0, 1, 0.2)
  ) +
  scale_x_continuous(
    name = "time (millions)",
    limits = c(0, 100200000),
    breaks = seq(0, 100200000, 25000000),
    labels = c("0", "25", "50", "75", "100")
  ) +
  background_grid(major = "xy", minor = "ny") +
  geom_text(
    x = 0,
    y = 0,
    hjust = 0,
    vjust = 0,
    label = "mu[q] = 0.001 Delta q = 0.001",
    size = 12,
    fontface = "bold",
    parse = T
  ) +
  scale_color_manual(values = c("#FDE333", "#C6E149", "#88D867", "#38C980", "#00B691", "#009F99", "#008599", "#00698F", "#324C7F", "#432D68", "#46024E"))

p_fitness3 <-
  t_summary %>%
  filter(q_prob_label == "0.01") %>%
  ggplot(aes(x = time, y = mean_rep_fitness, group = q_start)) +
  geom_line(aes(color = factor(q_start))) +
  scale_y_continuous(
    name = "mean fitness",
    limits = c(0, 1.00),
    breaks = seq(0, 1, 0.2)
  ) +
  scale_x_continuous(
    name = "time (millions)",
    limits = c(0, 100200000),
    breaks = seq(0, 100200000, 25000000),
    labels = c("0", "25", "50", "75", "100")
  ) +
  background_grid(major = "xy", minor = "ny") +
  draw_text(x = 0, y = 0, hjust = 0, vjust = 0, text = "pr(q) = 0.01, dq = 0.0001", size = 12, fontface = "bold") +
  scale_color_manual(values = c("#FDE333", "#C6E149", "#88D867", "#38C980", "#00B691", "#009F99", "#008599", "#00698F", "#324C7F", "#432D68", "#46024E"))

# arrange subfigures
p_fitness <-
  plot_grid(
    p_fitness1 +
      theme(legend.position = "none"),
    p_fitness2 +
      theme(axis.title.y = element_blank(), legend.position = "none"),
    p_fitness3 +
      theme(axis.title.y = element_blank(), legend.position = "none"),
    align = "vh",
    hjust = -1,
    ncol = 3,
    nrow = 1
  )

# save the plot
save_plot(paste0(root_dir, "/evolving_q_sim/plots/fitness_v_time_", base_name, ".png", sep = ""),
  p_fitness,
  base_height = 3,
  base_width = 10
)

##########################################################################
# Plotting epistasis over time
##########################################################################
t_summary$q_prob_label <- factor(t_summary$q_prob_label,
  labels = c(
    "list(mu[q]==0.0001, Delta*q==0.001)",
    "list(mu[q]==0.001, Delta*q==0.001)",
    "list(mu[q]==0.01, Delta*q==0.0001)"
  )
)

p_epistasis <- t_summary %>%
  ggplot(aes(x = time, y = mean_rep_q, group = q_start)) +
  geom_line(aes(color = factor(q_start))) +
  scale_y_continuous(
    name = "mean epistasis",
    limits = c(0, 2.1),
    breaks = seq(0, 2.0, 0.5)
  ) +
  scale_x_continuous(
    name = "time (millions)",
    limits = c(0, 100200000),
    breaks = seq(0, 100200000, 25000000),
    labels = c("0", "25", "50", "75", "100")
  ) +
  background_grid(major = "xy", minor = "y") +
  facet_grid(~q_prob_label, labeller = label_parsed) +
  scale_color_manual(values = c("#FDE333", "#C6E149", "#88D867", "#38C980", "#00B691", "#009F99", "#008599", "#00698F", "#324C7F", "#432D68", "#46024E")) +
  theme(legend.position = "none")

# save the plot
save_plot(paste(root_dir, "/evolving_q_sim/plots/epistasis_v_time_", base_name, ".png", sep = ""),
  p_epistasis,
  base_height = 4,
  base_width = 12
)

##########################################################################
# Plotting epistasis over time (2 trajectories)
##########################################################################

# create a data frame with labels for the plot
labels_df <- data.frame(
  q_start = c(1.4, 1.6, 1.8),
  q_start_label = c(
    "q[t==0]==1.4",
    "q[t==0]==1.6",
    "q[t==0]==1.8"
  )
)

# filter for all trajectories that start at 1.8, 1.6, or 1.4
t_filtered %>%
  filter(
    q_prob_label == "0.001",
    q_start == 1.8 | q_start == 1.6 | q_start == 1.4
  ) %>%
  left_join(labels_df) -> t_subset1

# plot epistasis over time for different q mutation rate and delta q
t_summary %>%
  filter(
    q_prob_label == "list(mu[q]==0.001, Delta*q==0.001)",
    q_start == 1.8 | q_start == 1.6 | q_start == 1.4
  ) %>%
  left_join(labels_df) -> t_subset2

p_epistasis1 <- ggplot() +
  geom_line(data = t_subset1, aes(x = time, y = mean_q, group = rep), color = "#7d7d7d", size = 0.3) +
  geom_line(data = t_subset2, aes(x = time, y = mean_rep_q, group = q_start, color = factor(q_start)), size = 1.2) +
  scale_y_continuous(
    name = "epistasis",
    limits = c(0, 2.6),
    breaks = seq(0, 2.5, 0.5)
  ) +
  scale_x_continuous(
    name = "time (millions)",
    limits = c(0, 100200000),
    breaks = seq(0, 100200000, 25000000),
    labels = c("0", "25", "50", "75", "100")
  ) +
  background_grid(major = "xy", minor = "y") +
  facet_grid(~q_start_label, labeller = label_parsed) +
  scale_color_manual(values = c("#00698F", "#324C7F", "#432D68")) +
  theme(legend.position = "none")

# save the plot
save_plot(paste(root_dir, "/evolving_q_sim/plots/epistasis_v_time_", base_name, "_subset.png", sep = ""),
  p_epistasis1,
  base_height = 4,
  base_width = 12
)


#' Create a customized summary table
#'
#' @param data A data frame
#' @param y  categorical variable name in the data.
#'
#' @returnA categorical variable name (quoted or unquoted) in data.
#'  Summary statistics will be calculated separately for each level of the variable
#' @export
#'
#' @examples create_journaltable(data =infert, y = 'case')
create_journaltable <- function(data, y) {
  data %>%
    gtsummary::tbl_summary(
      by = all_of(y),
      type = where(is.character) ~ "categorical") %>%
    gtsummary::add_p(test = where(is.numeric) ~ "t.test") %>%
    gtsummary::modify_header(update = list(
      label ~ "**Variable**"
    ))
}


#!/apps/well/R/3.4.3/bin/Rscript
#$ -cwd
#$ -q short.qc
#$ -o ./loglmer/
#$ -e ./loglmer/

library(MASS)
library(Matrix)
library(lme4)
library(tictoc)

# ---------------------------------------------------------------------------------------
# IMPORTANT: Input options
# ---------------------------------------------------------------------------------------
#
# The below variables control which simulation is run and how. The variable names match
# those used in the `LMMPaperSim.py` file and are given as follows:
#
# - OutDir: The output directory.
# - desInd: Integer value between 1 and 3 representing which design to run. The
#           designs are as follows:
#           - Design 1: nlevels=[50], nraneffs=[2]
#           - Design 2: nlevels=[50,10], nraneffs=[3,2]
#           - Design 3: nlevels=[100,50,10], nraneffs=[4,3,2]
# - nsim: Number of simulations (default=1000)
# - mode: String indicating whether to run parameter estimation simulations (mode=
#         'param') or T statistic simulations (mode='Tstat').
# - reml: Boolean indicating whether to use ML or ReML estimation.
#
# ---------------------------------------------------------------------------------------
# For parameter simulations example use this directory
outDir <- paste(dirname(rstudioapi::getSourceEditorContext()$path), '..', '..', 'data', 'ParamSimulation', sep=.Platform$file.sep)
# For T simulations example use this directory
#outDir <- paste(dirname(rstudioapi::getSourceEditorContext()$path), '..', '..', 'data', 'TstatSimulation', sep=.Platform$file.sep)
desInd <- 2
nsim <- 3
mode <- 'param'
reml <- TRUE
# ---------------------------------------------------------------------------------------

# If we are timing code, don't import lmerTest since it can reduces the performance of lmer
if (mode=='param'){
  timing <- TRUE
} else {
  timing <- FALSE
}
if (!timing){
  library(lmerTest)
}

# Loop through the simulations running lmer
for (simInd in 1:nsim){
  if (desInd==3){

    # Read in the results file
    results <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design3_results.csv',sep=''))

    # Read in the fixed effects design
    X <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design3_X.csv',sep=''),sep=' ', header=FALSE)

    # Read in the response vector
    Y <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design3_Y.csv',sep=''),sep=' ', header=FALSE)

    # Read in the factor vector for the first random factor in the design
    Zfactor0 <- factor(read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design3_Zfactor0.csv',sep=''), sep=' ', header=FALSE)[,1])

    # Read in the raw regressor for the first random factor in the design
    Zdata0 <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design3_Zdata0.csv',sep=''),sep=' ', header=FALSE)

    # Read in the factor vector for the second random factor in the design
    Zfactor1 <- factor(read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design3_Zfactor1.csv',sep=''), sep=' ', header=FALSE)[,1])

    # Read in the raw regressor for the second random factor in the design
    Zdata1 <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design3_Zdata1.csv',sep=''),sep=' ', header=FALSE)

    # Read in the factor vector for the third random factor in the design
    Zfactor2 <- factor(read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design3_Zfactor2.csv',sep=''), sep=' ', header=FALSE)[,1])

    # Read in the raw regressor for the third random factor in the design
    Zdata2 <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design3_Zdata2.csv',sep=''),sep=' ', header=FALSE)

    # Reformat Y
    y <- as.matrix(Y[,1])

    # Reformat X into columns
    x2 <- as.matrix(X[,2])
    x3 <- as.matrix(X[,3])
    x4 <- as.matrix(X[,4])
    x5 <- as.matrix(X[,5])

    # Reformat the raw regressor matrix for the first random factor into columns
    z01 <- as.matrix(Zdata0[,1])
    z02 <- as.matrix(Zdata0[,2])
    z03 <- as.matrix(Zdata0[,3])
    z04 <- as.matrix(Zdata0[,4])

    # Reformat the raw regressor matrix for the second random factor into columns
    z11 <- as.matrix(Zdata1[,1])
    z12 <- as.matrix(Zdata1[,2])
    z13 <- as.matrix(Zdata1[,3])

    # Reformat the raw regressor matrix for the third random factor into columns
    z21 <- as.matrix(Zdata2[,1])
    z22 <- as.matrix(Zdata2[,2])

    # Run the model
    m <- lmer(y ~ x2 + x3 + x4 + x5 + (0 + z01 + z02 + z03 + z04|Zfactor0) + (0 + z11 + z12 + z13|Zfactor1) + (0 + z21 + z22|Zfactor2), REML=reml) #Don't need intercepts in R - automatically assumed

    # Get the function which is optimized
    devfun <- lmer(y ~ x2 + x3 + x4 + x5 + (0 + z01 + z02 + z03 + z04|Zfactor0) + (0 + z11 + z12 + z13|Zfactor1) + (0 + z21 + z22|Zfactor2), REML=reml, devFunOnly = TRUE) #Don't need intercepts in R - automatically assumed

    # Time lmer from only the devfun point onwards (to ensure fair comparison)
    tic('lmer time')
    opt<-optimizeLmer(devfun)
    t<-toc()

    # Calculate time
    lmertime <- t$toc-t$tic

    # Record time
    results[1,'lmer']<-lmertime

    # Record closest thing we have to number of iterations
    results[2,'lmer'] <- opt$feval

    # Record log likelihood
    if (!reml){
      results[3,'lmer']<-logLik(m)[1]
    } else {
      results[3,'lmer']<-logLik(m)[1]
    }

    # Record fixed effects estimates
    results[4:8,'lmer'] <- fixef(m)

    # Record fixed effects variance estimate
    results[9,'lmer']<-as.data.frame(VarCorr(m))$vcov[20]

    # Recover D parameters
    Ds <- as.matrix(Matrix::bdiag(VarCorr(m)))

    # Calculate vech(D_0)*sigma2
    vechD0 <- Ds[1:4,1:4][lower.tri(Ds[1:4,1:4],diag = TRUE)]

    # Calculate vech(D_1)*sigma2
    vechD1 <- Ds[5:7,5:7][lower.tri(Ds[5:7,5:7],diag = TRUE)]

    # Calculate vech(D_2)*sigma2
    vechD2 <- Ds[8:9,8:9][lower.tri(Ds[8:9,8:9],diag = TRUE)]

    # Record vech(D_0)
    results[10:19,'lmer']<-vechD0/as.data.frame(VarCorr(m))$vcov[20]

    # Record vech(D_1)
    results[20:25,'lmer']<-vechD1/as.data.frame(VarCorr(m))$vcov[20]

    # Record vech(D_2)
    results[26:28,'lmer']<-vechD2/as.data.frame(VarCorr(m))$vcov[20]

    # Record vech(D_0)*sigma2
    results[29:38,'lmer']<-vechD0

    # Record vech(D_1)*sigma2
    results[39:44,'lmer']<-vechD1

    # Record vech(D_2)*sigma2
    results[45:47,'lmer']<-vechD2

    # If we're not using the simulations to test performance, output everything we can.
    if (!timing){

      # Run T statistic inference
      Tresults<-lmerTest::contest1D(m, c(0,0,0,0,1),ddf=c("Satterthwaite"))

      # Get the P value
      p<-Tresults$`Pr(>|t|)`

      # Get the T statistic
      Tstat<-Tresults$`t value`

      # Get the degrees of freedom estimates
      df<-Tresults$df

      # Make p-values 1 sided
      if (Tstat>0){
        p <- p/2
      } else {
        p <- 1-p/2
      }

      # Record T statsitic
      results[48,'lmer']<-Tstat

      # Record P valye
      results[49,'lmer']<-p

      # Record degrees of freedom estimate
      results[50,'lmer']<-df

    }

    # Write results back to csv file
    write.csv(results,paste(outDir,'/Sim',toString(simInd),'_Design3_results.csv',sep=''), row.names = FALSE)

  } else if (desInd==2){

    # Read in the results file
    results <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design2_results.csv',sep=''))

    # Read in the fixed effects design
    X <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design2_X.csv',sep=''),sep=' ', header=FALSE)

    # Read in the response vector
    Y <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design2_Y.csv',sep=''),sep=' ', header=FALSE)

    # Read in the factor vector for the first random factor in the design
    Zfactor0 <- factor(read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design2_Zfactor0.csv',sep=''), sep=' ', header=FALSE)[,1])

    # Read in the raw regressor for the first random factor in the design
    Zdata0 <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design2_Zdata0.csv',sep=''),sep=' ', header=FALSE)

    # Read in the factor vector for the second random factor in the design
    Zfactor1 <- factor(read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design2_Zfactor1.csv',sep=''), sep=' ', header=FALSE)[,1])

    # Read in the raw regressor for the second random factor in the design
    Zdata1 <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design2_Zdata1.csv',sep=''),sep=' ', header=FALSE)

    # Reformat Y
    y <- as.matrix(Y[,1])

    # Reformat X into columns
    x2 <- as.matrix(X[,2])
    x3 <- as.matrix(X[,3])
    x4 <- as.matrix(X[,4])
    x5 <- as.matrix(X[,5])

    # Reformat the raw regressor matrix for the first random factor into columns
    z01 <- as.matrix(Zdata0[,1])
    z02 <- as.matrix(Zdata0[,2])
    z03 <- as.matrix(Zdata0[,3])

    # Reformat the raw regressor matrix for the second random factor into columns
    z11 <- as.matrix(Zdata1[,1])
    z12 <- as.matrix(Zdata1[,2])

    # Run the model
    m <- lmer(y ~ x2 + x3 + x4 + x5 + (0 + z01 + z02 + z03|Zfactor0) + (0 + z11 + z12|Zfactor1), REML=reml) #Don't need intercepts in R - automatically assumed

    # Get the function which is optimized
    devfun <- lmer(y ~ x2 + x3 + x4 + x5 + (0 + z01 + z02 + z03|Zfactor0) + (0 + z11 + z12|Zfactor1), REML=reml, devFunOnly = TRUE) #Don't need intercepts in R - automatically assumed

    # Time lmer from only the devfun point onwards (to ensure fair comparison)
    tic('lmer time')
    opt<-optimizeLmer(devfun)
    t<-toc()

    # Calculate time
    lmertime <- t$toc-t$tic

    # Record time
    results[1,'lmer']<-lmertime

    # Record closest thing we have to number of iterations
    results[2,'lmer'] <- opt$feval

    # Record log likelihood
    if (!reml){
      results[3,'lmer']<-logLik(m)[1]
    } else {
      results[3,'lmer']<-logLik(m)[1]
    }

    # Record fixed effects estimates
    results[4:8,'lmer'] <- fixef(m)

    # Record fixed effects variance estimate
    results[9,'lmer']<-as.data.frame(VarCorr(m))$vcov[10]

    # Recover D parameters
    Ds <- as.matrix(Matrix::bdiag(VarCorr(m)))

    # Calculate vech(D_0)*sigma2
    vechD0 <- Ds[1:3,1:3][lower.tri(Ds[1:3,1:3],diag = TRUE)]

    # Calculate vech(D_1)*sigma2
    vechD1 <- Ds[4:5,4:5][lower.tri(Ds[4:5,4:5],diag = TRUE)]

    # Record vech(D_0)
    results[10:15,'lmer']<-vechD0/as.data.frame(VarCorr(m))$vcov[10]

    # Record vech(D_1)
    results[16:18,'lmer']<-vechD1/as.data.frame(VarCorr(m))$vcov[10]

    # Record vech(D_0)*sigma2
    results[19:24,'lmer']<-vechD0

    # Record vech(D_1)*sigma2
    results[25:27,'lmer']<-vechD1

    # If we're not using the simulations to test performance, output everything we can.
    if (!timing){

      # Run T statistic inference
      Tresults<-lmerTest::contest1D(m, c(0,0,0,0,1),ddf=c("Satterthwaite"))

      # Get the P value
      p<-Tresults$`Pr(>|t|)`

      # Get the T statistic
      Tstat<-Tresults$`t value`

      # Get the degrees of freedom estimates
      df<-Tresults$df

      # Make p-values 1 sided
      if (Tstat>0){
        p <- p/2
      } else {
        p <- 1-p/2
      }

      # Record T statsitic
      results[28,'lmer']<-Tstat

      # Record P value
      results[29,'lmer']<-p

      # Record degrees of freedom estimate
      results[30,'lmer']<-df
    }

    # Write results back to csv file
    write.csv(results,paste(outDir,'/Sim',toString(simInd),'_Design2_results.csv',sep=''), row.names = FALSE)

  } else if (desInd==1){

    # Read in the results file
    results <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design',toString(desInd),'_results.csv',sep=''))

    # Read in the fixed effects design
    X <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design',toString(desInd),'_X.csv',sep=''),sep=' ', header=FALSE)

    # Read in the response vector
    Y <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design',toString(desInd),'_Y.csv',sep=''),sep=' ', header=FALSE)

    # Read in the factor vector for the first random factor in the design
    Zfactor0 <- factor(read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design',toString(desInd),'_Zfactor0.csv',sep=''), sep=' ', header=FALSE)[,1])

    # Read in the raw regressor for the first random factor in the design
    Zdata0 <- read.csv(file = paste(outDir,'/Sim',toString(simInd),'_Design',toString(desInd),'_Zdata0.csv',sep=''),sep=' ', header=FALSE)

    # Reformat Y
    y <- as.matrix(Y[,1])

    # Reformat X into columns
    x2 <- as.matrix(X[,2])
    x3 <- as.matrix(X[,3])
    x4 <- as.matrix(X[,4])
    x5 <- as.matrix(X[,5])

    # Reformat the raw regressor matrix for the first random factor into columns
    z01 <- as.matrix(Zdata0[,1])
    z02 <- as.matrix(Zdata0[,2])

    # Run the model
    m <- lmer(y ~ x2 + x3 + x4 + x5 + (0 + z01 + z02|Zfactor0), REML=reml) #Don't need intercepts in R - automatically assumed

    # Get the function which is optimized
    devfun <- lmer(y ~ x2 + x3 + x4 + x5 + (0 + z01 + z02|Zfactor0), REML=reml, devFunOnly = TRUE) #Don't need intercepts in R - automatically assumed

    # Time lmer from only the devfun point onwards (to ensure fair comparison)
    tic('lmer time')
    opt<-optimizeLmer(devfun)
    t<-toc()

    # Calculate time
    lmertime <- t$toc-t$tic

    # Record time
    results[1,'lmer']<-lmertime

    # Record closest thing we have to number of iterations
    results[2,'lmer'] <- opt$feval

    # Record log likelihood
    if (!reml){
      results[3,'lmer']<-logLik(m)[1]
    } else {
      results[3,'lmer']<-logLik(m)[1]
    }

    # Record fixed effects estimates
    results[4:8,'lmer'] <- fixef(m)

    # Record fixed effects variance estimate
    results[9,'lmer']<-as.data.frame(VarCorr(m))$vcov[4]

    # Recover D parameters
    Ds <- as.matrix(Matrix::bdiag(VarCorr(m)))

    # Calculate vech(D_0)*sigma2
    vechD0 <- Ds[1:2,1:2][lower.tri(Ds[1:2,1:2],diag = TRUE)]

    # Record vech(D_0)
    results[10:12,'lmer']<-vechD0/as.data.frame(VarCorr(m))$vcov[10]

    # Record vech(D_0)*sigma2
    results[13:15,'lmer']<-vechD0

    # If we're not using the simulations to test performance, output everything we can.
    if (!timing){

      # Run T statistic inference
      Tresults<-lmerTest::contest1D(m, c(0,0,0,0,1),ddf=c("Satterthwaite"))

      # Get the P value
      p<-Tresults$`Pr(>|t|)`

      # Get the T statistic
      Tstat<-Tresults$`t value`

      # Get the degrees of freedom estimates
      df<-Tresults$df

      # Make p-values 1 sided
      if (Tstat>0){
        p <- p/2
      } else {
        p <- 1-p/2
      }

      # Record T statsitic
      results[16,'lmer']<-Tstat

      # Record P value
      results[17,'lmer']<-p

      # Record degrees of freedom estimate
      results[18,'lmer']<-df

    }

    # Write results back to csv file
    write.csv(results,paste(outDir,'/Sim',toString(simInd),'_Design',toString(desInd),'_results.csv',sep=''), row.names = FALSE)

  }
}

# Display results
results


#get depth and bulk density weighted NEON micronutrients to 30cm (to match Tedersoo/Bahram priors).
rm(list=ls())
library(runjags)
source('paths.r')
source('NEFI_functions/convert_P.r')
source('NEFI_functions/convert_K.r')

#set output path.----
output.path <- micronutrient_converted.path

#load raw chemical and physical data.----
chem <- readRDS(dp1.10008.00_output.path)
phys <- readRDS(dp1.10047.00_output.path)

#P conversion data sets for downstream.
oxalate_olsen_P.dat <- read.csv(oxalate_olsen_P.conv_data.path)
oxalate_olsen_P.dat <- sapply(oxalate_olsen_P.dat[,-1], as.numeric)
     olsen_AL_P.dat <- read.csv(olsen_AL_P.conv_data.path)
oxalate_olsen_P.dat <- oxalate_olsen_P.dat[,c('Oxalate','Olsen')]
     olsen_AL_P.dat <- olsen_AL_P.dat[,c('Olsen.PICP','P.AL_color')]

#for converting K to ammonium lactate
AA_AL_K.dat <- data.frame(AL <- c(179.57, 202.89, 210.26, 188.07, 197.05, 86.66, 197.98, 195.13, 184.98, 165.99),
                          AA <- c(170, 183.09, 197.23, 177.28, 168.88, 83.14, 187.73, 182.01, 190.9, 166.94))
AA_AL_K.dat <- read.csv('/fs/data3/caverill/NEFI_data/16S/pecan_gen/potassium_AL_AA.csv')
AA_AL_K.dat <- AA_AL_K.dat[,'K.aa','K.al']

#There are two duplicated "unique" horizons in physical table. deal with this.----
#Generally, one duplicate has some BD data, other duplicate has other BD data.
#For pair of duplicates, one BD sampling method is "compliant cavity" and the other is "clod".
#most horizons sampled using one method or the other, most are clod. These are the only two with both.
#Lets grab the clod duped observations.
duped <- phys[duplicated(phys$horizonID),]$horizonID
phys <- phys[!(phys$horizonID %in% duped & phys$bulkDensSampleType == 'compliant cavity'),]

#merge together chemical and physical dataframes. Only retain horizons that have both physical and chemical data.----
col.drop <- colnames(chem)[colnames(chem) %in% colnames(phys)]
col.drop <- col.drop[!(col.drop %in% "horizonID")]
chem <- chem[,!(colnames(chem) %in% col.drop)]
d <- merge(chem, phys, by = 'horizonID')

#They measure bulk density using many methods. Merge these together to a single consensus BD.----
#first use the clod observations, "bulkDensOvenDry
d$bd <- d$bulkDensOvenDry
#then use compliant cavity data.
d$bd <- ifelse(is.na(d$bd),d$bulkDensDryWeight/d$bulkDensVolume, d$bd)
#there are 47 horizons that just don't have data to compute BD. oh well.

#subset to 30cm depth and elements of interest.----
#We only conside to 5cm depth, because that's what Leho did.
d <- d[!(d$bulkDensTopDepth >= 5),]
#6 plots are still duplicated because first horizon doesn't extend to 5cm. This is fine.

#Grab: bulk density, top/bottom depth, horizonID, elements of interest.
d <- d[,c('horizonID','siteID','plotID','bd','bulkDensTopDepth','bulkDensBottomDepth','mgNh4d','caNh4d','kNh4d','pOxalate','MehlichIIITotP','OlsenPExtractable')]

#Unit conversion.----
#P is mg/kg (same as Tedersoo/Bahram)
#others are centimoles / kg. We need to convert to mg/kg to match Tedersoo/Bahram.
#Multiply centimoles by 100 to get moles. Multiply by MW to get grams. Divide by 1000 to get milligrams.
mw.Ca <- 40.078
mw.K  <- 39.0983
mw.Mg <- 24.305
d$caNh4d <- ((d$caNh4d * 100) * mw.Ca) / 1000
d$kNh4d  <- ((d$kNh4d  * 100) * mw.K ) / 1000
d$mgNh4d <- ((d$mgNh4d * 100) * mw.Mg) / 1000

#Get weighted mean for observations with more than one horizon within 5cm.----
#this affects 6 profiles.
d$bulkDensBottomDepth <- ifelse(d$bulkDensBottomDepth > 5, 5, d$bulkDensBottomDepth)
nutrients <- c('mgNh4d','caNh4d','kNh4d','pOxalate')
plotID <- as.character(unique(d$plotID))
soil.5cm <- list()
nut.output <- list()
for(i in 1:length(nutrients)){
  nut <- list()
  for(k in 1:length(plotID)){
    ag <- d[d$plotID == plotID[k],]
    ag$f.depth <- (ag$bulkDensBottomDepth - ag$bulkDensTopDepth) / 5
    nut[[k]] <- sum(ag[,nutrients[i]]*ag$f.depth, na.rm = T)
  }
  nut <- unlist(nut)
  nut.output[[i]] <- nut
}
nut <- do.call(cbind, nut.output)
colnames(nut) <- nutrients

#drop new values into data object.
d <- data.frame(nut,plotID)
d$siteID <- substr(d$plotID, 1, 4)

#if a micronutrient is zero, set it to the lowest non-zero observation in dataset. otherwise can't log10 transform.
d$caNh4d <- ifelse(d$caNh4d == 0, min(d$caNh4d[d$caNh4d > 0]), d$caNh4d)
d$mgNh4d <- ifelse(d$mgNh4d == 0, min(d$mgNh4d[d$mgNh4d > 0]), d$mgNh4d)

#convert Phosphorus to estimate based on different extraction method to match prior.----
P.flip <- convert_P(d$pOxalate, oxalate_olsen_P.dat, olsen_AL_P.dat, log10_flip = T)
K.flip <- convert_K(d$kNh4d, AA_AL_K.dat, log10_flip = T)

#log 10 transform ones already measured with the same methods (Ca, Mg).----
Ca <- log10(d$caNh4d)
Mg <- log10(d$mgNh4d)

#Save micronutrients and their standard deviations for analysis. Make sure everything on log10 scale to match Tedersoo.----
output <- data.frame(d$plotID,d$siteID,P.flip$mean, K.flip$mean, Ca, Mg, P.flip$sd, K.flip$sd)
colnames(output) <- c('plotID','siteID','P','K','Ca','Mg','P_sd','K_sd')
saveRDS(output,output.path)


row.names(mi) = 1:I
colnames(mi) = 1:N
d_long <- reshape2::melt(t(mi))

### lout: list of output directory

for (out_dir in lout) {
load(paste0(out_dir,fname))
dll = t(mll)
colnames(dll) = 1:I
row.names(dll) = 1:N
d_add <- reshape2::melt(dll)
d_long = plyr::join(d_long, d_add, by = c("Var1","Var2"))
}

names(d_long) = c("person","item","res", "LogLoss_np", "LogLoss_no", "LogLoss_pn")
d_long$LogLoss_diff_np = d_long$LogLoss_no - d_long$LogLoss_np
d_long$LogLoss_diff_pn = d_long$LogLoss_no - d_long$LogLoss_pn
d_long$res = factor(d_long$res, labels=c("incorrect","correct"))

ll_boxp_np_by <- ggplot(d_long, aes(x=item,y=LogLoss_diff_np,fill=factor(item))) + facet_wrap(~res) +
  geom_boxplot() + theme(legend.position = "none") + ggtitle("baseline - M1 log loss")+
  ylab("Difference in LogLoss")

ll_boxp_pn_by <- ggplot(d_long, aes(x=item,y=LogLoss_diff_pn,fill=factor(item))) + facet_wrap(~res) +
  geom_boxplot() + theme(legend.position = "none") + ggtitle("baseline - M2 log loss") +
    ylab("Difference in LogLoss")

ll_boxp_np <- ggplot(d_long, aes(x=item,y=LogLoss_diff_np,fill=factor(item))) +
  geom_boxplot() + theme(legend.position = "none") + ggtitle("baseline - M1 log loss")+
  ylab("Difference in LogLoss")

ll_boxp_pn <- ggplot(d_long, aes(x=item,y=LogLoss_diff_pn,fill=factor(item))) +
  geom_boxplot() + theme(legend.position = "none") + ggtitle("baseline - M2 log loss") +
    ylab("Difference in LogLoss")

pdf(pname)
print(ll_boxp_np_by)
print(ll_boxp_pn_by)
print(ll_boxp_np)
print(ll_boxp_pn)
dev.off()


#plotting variable importance: functional groups.
#Clear environment, source paths, packages and functions.
rm(list=ls())
source('paths.r')
library(ggplot2)

#load data.
d <- readRDS(NEON_dmulti.ddirch_var.importance_fg.path)
mu <- d$mean
lo_95 <- d$ci_0.025
hi_95 <- d$ci_0.975

#drop "other" group.----
mu <- mu[,!(colnames(mu) %in% c('other'))]
lo_95 <- lo_95[,!(colnames(lo_95) %in% c('other'))]
hi_95 <- hi_95[,!(colnames(hi_95) %in% c('other'))]

#Global plot settings.----
#i = 2 #2=Ectomycorrhizal fungi.
par(mfrow = c(2,2))
outer.lab.cex <- 1.5

#loop over different fungal groups.----
for(i in 2:ncol(d$mean)){
  #plot importance in decreasing order.
  mu   <- d$mean[,i][order(d$mean[,i], decreasing = T)]
  hi95 <- d$ci_0.975[,i][order(match(names(d$ci_0.975[,i]), names(mu)))]
  lo95 <- d$ci_0.025[,i][order(match(names(d$ci_0.025[,i]), names(mu)))]
  limy <- c(0,max(mu) * 1.01)
  lab <- names(mu)
  fungi.name <- colnames(d$mean)[i]
  J<-barplot(height = mu,
             beside = true, las = 2,
             ylim = limy,
             cex.names = 0.75, xaxt = "n",
             main = paste0(fungi.name,' fungi'),
             border = "black", axes = TRUE)
  #add error bars.
  #segments(J, lo95, J, hi95, lwd = 1.5)
  #add variable labels.
  ypos <- -limy[2] / 10
  text(x = J, y = ypos, srt = 45,
       adj = 1, labels = lab, xpd = TRUE)
}
#Outer labels.----
mtext('Variable Importance',side = 2, line = -1.5, cex = outer.lab.cex, outer = T)


 source("R/header.r")

theme_blank <- list(theme(
			panel.grid.minor = element_blank(),
                        panel.grid.major = element_blank(),
                        panel.background=element_blank(),
#                        panel.background = element_rect(color = "black",fill=NA,  size = .5, linetype = "solid"),
                        #panel.border=element_rect(color = "black",fill=NA,  size = 0.4, linetype = "solid"),
                        plot.background = element_blank(),
                        plot.background=element_blank(),
 						panel.border=element_blank(),
 #                       panel.border=element_rect(color = "black",fill=NA,  size = .5, linetype = "solid"),
                        legend.position="right",
                        panel.border = element_blank(),
                        axis.line = element_blank(),
                        axis.text.x = element_blank(),
                        axis.text.y = element_blank(),
                        axis.ticks = element_blank(),
                        panel.margin = unit(5,"lines"),
                        panel.margin = unit(0,"null"),
                        plot.margin = rep(unit(0,"null"),4),
                        axis.title.x = element_blank(),
                        axis.title.y = element_blank(),
                        plot.title = element_text()))

 country<-new("shapefile",dir="data/admin_countries/110m/",layer="ne_110m_admin_0_countries",
 	     proj_to= to)
g<-ggplot()
w_h<-function(lim){
	return(abs((lim[2]-lim[1])/(lim[3]-lim[4])))
}
a<-readOGR("data/shape/110m_cultural/","ne_110m_populated_places")
a<-spTransform(a,CRS(to))
pp<-as.data.frame(cbind(a@coords,a$POP2010,a$MIN_AREAKM))
d<-addPoly(country,gg=g,size=0.1,color="black",fill="grey")
lines_proj<-graticules(20,10,to)
lines<-lines2dataframe(lines_proj)
#p<-gratText(lines_proj)

names(pp)<-c("lon","lat","pop","area")

dd<-d+geom_point(data=pp,aes(lon,lat,size=pop,color=area),alpha=0.6)+
scale_colour_gradient(low = "blue",high="red")+
scale_size_continuous(range=c(0,10))+theme_opts+coord_equal()+
ggtitle(bquote("World Metropolitan Population and Area in 2010"))+
geom_path(data=lines,aes(lon,as.numeric(lat),group=group),color="black",size=0.2)+
#scale_x_continuous(expand = c(0, 0),breaks=as.vector(p$x[,1]),labels=bquote(.(as.vector(p$x$txt))))+
#scale_y_continuous(expand = c(0, 0),breaks=as.vector(p$y[,1]), labels=p$y[,2])+

guides(size=guide_legend("K Habitants",title.position="top",direction="vertical",label.position="right"),color=guide_colorbar(title="Area KM²",direction="vertical"))+
theme_blank

saveMap("point_pj.jpeg",plot=dd,width=7,height=4,dpi=600)

f<-getShpAttrib(country,slot=c("labpt"),"pop_est")
names(f)<-c("lon","lat","pop")


# Plot predictions
# Requires data to be in the same format as spiral
#   - two variables and three classes

png('plot.png')

data_orig = read.csv('spiral.csv', header=F)
colnames(data_orig) <- c('t1','t2','t3','d1','d2')
data = read.csv('test_output.csv', header=F)
colnames(data) <- c('t1','t2','t3','d1','d2')

data$result = apply(data[c('t1','t2','t3')],1,which.max)
colfn <- function(n){ ifelse(n==1,'red',ifelse(n==2,'green','blue')) }
plot(data[c('d1','d2')], col=colfn(data['result']))
points(data_orig[,c('d1','d2')])

dev.off()


## Turn experiments: indirect vs no reported speech

source("../scripts/collate-word-feats.r")

load("word.pros.dt")
load("xprospn.dt")

turn.pros <- get.turn.pros(word.pros)
rs.pros <- get.rs.pros(word.pros, turn.pros)
xturn <- get.turn.data(turn.pros, rs.pros, xprospn)
xturn.ind <- xturn[rstype %in% c("I", "N")]

save(xturn.ind, file="xturn.ind")
xturn.ind.params.all <- train.test.turn(xturn.ind)
save(xturn.ind.params.all, file="xturn.ind.params.all")

turn.ind.feats <- names(xturn.ind.params.all[["x0.data"]])
print(turn.ind.feats)

turn.ind.feats <- turn.ind.feats[!(turn.ind.feats %in% c("pdur","ndur","pgap","ngap"))]
turn.ind.feats <- grep("^d[pn]", turn.ind.feats, invert=T, value=T)

turn.ind.pred.all <- pred.tune(xturn.ind.params.all, feats=turn.ind.feats, outfile="pred.turn.ind.all")
fs.turn.ind.all <- get.fs.pred(xturn.ind.params.all, feats=turn.ind.feats, outfile="fs.turn.ind.all")

## only F0 and Intensity features
#pcontext <- turn.ind.feats[grep("(F0|I0)",turn.ind.feats)]
#turn.ind.pred.pcontext <- pred.tune(xturn.ind.params.all, feats=pcontext, outfile="pred.turn.ind.pcontext")
#fs.turn.ind.pcontext <- get.fs.pred(xturn.ind.params.all, feats=pcontext, outfile="fs.turn.ind.pcontext")

## F0 and Int, no context
pros <- turn.ind.feats[grep("(F0|I0)",turn.ind.feats)]
turn.ind.pred.pros <- pred.tune(xturn.ind.params.all, feats=pros, outfile="pred.turn.ind.pros")
fs.turn.ind.pros <- get.fs.pred(xturn.ind.params.all, feats=pros, outfile="fs.turn.ind.pros")

#lex <- grep("^n\\.", turn.ind.feats, value=T)
#turn.ind.pred.lex <- pred.tune(xturn.ind.params.all, feats=lex, outfile="pred.turn.ind.lex")
#fs.turn.ind.lex <- get.fs.pred(xturn.ind.params.all, feats=lex, outfile="fs.turn.ind.lex")
#
#nonlex <- grep("^n\\.", turn.ind.feats, value=T, invert=T)
#turn.ind.pred.nonlex <- pred.tune(xturn.ind.params.all, feats=nonlex, outfile="pred.turn.ind.nonlex")
#fs.turn.ind.nonlex <- get.fs.pred(xturn.ind.params.all, feats=nonlex, outfile="fs.turn.ind.nonlex")

############################################################################
### only Intensity features
#pi0 <- turn.ind.feats[grep("I0",turn.ind.feats)]
#turn.ind.pred.pi0 <- pred.tune(xturn.ind.params.all, feats=pi0, outfile="pred.turn.ind.pi0")
#
### only F0
#pf0 <- turn.ind.feats[grep("F0",turn.ind.feats)]
#turn.ind.pred.pf0 <- pred.tune(xturn.ind.params.all, feats=pf0, outfile="pred.turn.ind.pf0")
#fs.turn.ind.pf0 <- get.fs.pred(xturn.ind.params.all, feats=pf0, outfile="fs.turn.ind.pf0")
#
### only Intensity features
#ti0 <- pros[grep("I0",pros)]
#turn.ind.pred.ti0 <- pred.tune(xturn.ind.params.all, feats=ti0, outfile="pred.turn.ind.ti0")
#
### only F0
#tf0 <- pros[grep("F0",pros)]
#turn.ind.pred.tf0 <- pred.tune(xturn.ind.params.all, feats=tf0, outfile="pred.turn.ind.tf0")
#fs.turn.ind.tf0 <- get.fs.pred(xturn.ind.params.all, feats=tf0, outfile="fs.turn.ind.tf0")
#
###########################################################################
# Models
###########################################################################

m.turn.ind <- glmer(is.rs ~  (1 | spk)
		+ to.zscore(mean.normF0) + to.zscore(mean.normI0)
		+ to.zscore(range.normF0) + to.zscore(range.normI0)
		+ to.zscore(slope.normF0) + to.zscore(slope.normI0)
		+ to.zscore(intern.pause)
		+ to.zscore(abs(dur))
		, data=xturn.ind,  family = binomial(link = "logit"))

xtable(get.fixef(m.turn.ind, roundval=2))

sigpros <- c("range.normF0","slope.normF0","range.normI0","slope.normI0","intern.pause")
turn.ind.pred.sigpros <- pred.tune(xturn.ind.params.all, feats=sigpros, outfile="pred.turn.ind.sigpros")


best <- function(state, outcome) {

  ## turn off potential NA warnings
  oldw<-getOption("warn")
  options(warn=-1)

  ##Adding simpleCap function for letter capitaliztion
      simpleCap <- function(x) {
            s <- strsplit(x, " ")[[1]]
            paste(toupper(substring(s, 1,1)), substring(s, 2),
                  sep="", collapse=" ")
      }

  ## Read outcome data
  file<-read.csv("outcome-of-care-measures.csv")

  ## Check that state and outcome are valid

      ## Checking invalid state
      state.list<-file[,"State"]
      if (!state %in% state.list)
          {result<-"invalid state"
           return (result)}

      ## Checking invalid outcome
      outcome.list<-c("heart attack","heart failure","pneumonia")
      if (!outcome %in% outcome.list)
          {result<- "invalid outcome"
           return (result)}

  ## Return hospital name in that state with lowest 30-day death
  ## rate
  hosp.name<-file[,"Hospital.Name"]    ## set vector for hospitals
  outcome.values.init<-file[,paste("Hospital.30.Day.Death..Mortality..Rates.from", sub(" ",".",simpleCap(outcome)),sep=".")]  ## set vector for outcomeswrite.csv(result.table,"test.csv")
  outcome.values<- as.numeric(as.character(outcome.values.init))

    ##combine columns together
  new.table<-cbind.data.frame(state.list,hosp.name,outcome.values)

  ##filter on state match
  result.table=new.table[state.list==state,]

  options(warn=oldw)## turn back on warnings

  ##sort by outcome value and then by hospital name
  sort.table = with(result.table,order(outcome.values, hosp.name))
  final.table<-result.table[sort.table,]

  ##return top row from table
  as.vector(final.table[1,2])

}


\name{circos.initialize}
\alias{circos.initialize}
\title{
Initialize the circular layout
}
\description{
Initialize the circular layout
}
\usage{
circos.initialize(factors, x = NULL, xlim = NULL, sector.width = NULL)
}
\arguments{

  \item{factors}{A \code{\link{factor}} variable or a character vector which represent data categories
}
  \item{x}{Data on x-axes, a vector
}
  \item{xlim}{Ranges for values on x-axes, see "details" section for explanation of the format
}
  \item{sector.width}{Width for each sector. The length of the vector should be either 1 which means
 all sectors have same width or as same as the number of sectors. Values for
 the vector are relative, and they will be scaled by dividing their summation.
 By default, it is \code{NULL} which means the width of sectors correspond to the data
 range in sectors.
}

}
\details{
The function allocates the sectors according to the values on x-axis.
The number of sectors are determined by the \code{factors} and the order
of sectors are determined by the levels of factors. In this function,
the start and end position for each sector on the circle (measured by degree)
are calculated according to the values on x-axis or by \code{xlim}.

If \code{x} is set, the length of \code{x} must be equal to the length of \code{factors}.
Then the data range for each sector are calculated from \code{x} by splitting \code{factors}.

If \code{xlim} is set, it should be a vector containing two numbers or a matrix with 2 columns.
If \code{xlim} is a 2-element vector, it means all sector share the same \code{xlim}.
If \code{xlim} is a 2-column matrix, the number of rows should be equal to the number of categories
identified by \code{factors}, then each row of \code{xlim} corresponds to the data range for each sector
and the order of rows is corresponding to the order of levels of \code{factors}. If \code{xlim} is a matrix
for which row names cover all sector names, \code{xlim} is automatically adjusted.

Normally, width of sectors will be calculated internally according to the data range in sectors. But you can
still set the width manually. However, it is not always a good idea to change the default sector width since
the width can reflect the range of data in sectors. However, in some cases, it is useful to manually set
the width such as you want to zoom some part of the sectors.

The function finally calls \code{\link[graphics]{plot}} with enforing aspect ratio to be 1 and be ready for adding graphics.
}
\seealso{
\url{http://jokergoo.github.io/circlize_book/book/circular-layout.html}
}
\references{
Gu, Z. (2014) circlize implements and enhances circular visualization in R. Bioinformatics.

}
\examples{
circos.initialize(factors = sample(letters[1:4], 20, replace = TRUE), xlim = c(0, 1))
circos.info()
circos.clear()

circos.initialize(factors = sample(letters[1:4], 20, replace = TRUE), xlim = cbind(1:4, 1:4*2))
circos.info()
circos.clear()

circos.initialize(factors = sample(letters[1:4], 20, replace = TRUE), x = rnorm(20))
circos.info()
circos.clear()

}


#!/usr/bin/env Rscript

args <- commandArgs(trailingOnly = TRUE)
filename=as.character(args[1])
annotationfile=as.character(args[2])

computeRegionLengths <- function(data){
  #process
  names(data)=c("chr","start","end","label","type","strand")
  #compute lengths
  singleLengths=apply(data,1,function(x){return(as.numeric(x[3])-as.numeric(x[2])+1)})
  dummyDF=data.frame(label=data$label,lens=singleLengths)
  res=by(dummyDF,dummyDF$label,function(x){sum(x$lens)})
  return(data.frame(region=as.character(names(res)),lens=as.numeric(res)))
}

addLengthColumnToStats <- function(dfStats,lens){
  Lengths=computeRegionLengths(lens)
  df2=dfStats
  dfStats = merge(df2,Lengths,by="region")
  return(dfStats)
}

#Calculates TPM
calcTPM <- function(df, annot) {
  colnames(df) = df[1, ]
  df=df[-c(1),]
  if(class(df)=="character"){
    df=t(as.matrix(df))
  }
  df = addLengthColumnToStats(df, annot)
  df$reads=as.integer(as.character(df$reads))
  df$lens=as.integer(as.character(df$lens))
  df$RPK=(df$reads/df$lens)*1000
  df$TPM=df$RPK/(sum(df$RPK)/1e+06)
  df$RPK=NULL
  df$lens=NULL
  df$reads=as.character(df$reads)
  df$TPM=as.character(df$TPM)
  return(df)
}

annotations=read.table(annotationfile,header=F,stringsAsFactors=FALSE)
names(annotations)=c("chr","start","end","label","type","strand")
outStats=paste(filename,"Statistics.dat",sep="")
tt=read.table(paste(filename,"alignedReads.sub.compact",sep=""),stringsAsFactors=FALSE)
tt$ID=paste(tt$V1,tt$V2,tt$V3,tt$V4,sep="")
tt$LM=paste(tt$V2,tt$V3,sep="")
tt$LS=paste(tt$V2,tt$V4,sep="")
nomodtt=subset(tt,V5 != "-")
nomodtt$LSEQ=paste(nomodtt$V2,nomodtt$V5,sep="")
tt$MS=paste(tt$V4,tt$V3,sep="")
stt=subset(tt,V5 != "-")
tab=table(stt$V5)
rmin=range(tt$V2)[1]-1
rmax=range(tt$V2)[2]+1

##create datastructure that counts reads per length per region and strand
allNames=annotations$label[!duplicated(annotations$label)]
names=paste(c((rmin+1):(rmax-1), (rmin+1):(rmax-1)), c(rep("+", rmax-rmin-1), rep("-", rmax-rmin-1)), sep = "")
allCounts=rep(0,length(names)+1)
for(name in allNames){
  counts=rep(0,length(names))
  subb=subset(tt,V1 == name)
  idx=which(annotations$label==name)
  strandInfo=annotations$strand[idx][1]
  if(strandInfo=="-") {
    subb$LS=sub('\\+$','t',subb$LS)
    subb$LS=sub('\\-$','+',subb$LS)
    subb$LS=sub('t$','-',subb$LS)
  }
  for (i in 1:length(names)){
    counts[i]=nrow(subset(subb,LS == names[i]))
  }
  allCounts=rbind(allCounts,c(name,counts))
}
#remove first dummy row
allCounts=allCounts[-1,]

#stats function returns line of stats for each matrix of alignments
computeStats <- function(subMatrix,header){
  reads=nrow(subMatrix)
  mod=nrow(subset(subMatrix,V3 == "Y"))
  stranded=nrow(subset(subMatrix,V4 == "-"))
  Aplus=nrow(subset(subMatrix,V4 == "+" & V5 == "A"))
  Cplus=nrow(subset(subMatrix,V4 == "+" & V5 == "C"))
  Gplus=nrow(subset(subMatrix,V4 == "+" & V5 == "G"))
  Tplus=nrow(subset(subMatrix,V4 == "+" & V5 == "T"))
  Aminus=nrow(subset(subMatrix,V4 == "-" & V5 == "A"))
  Cminus=nrow(subset(subMatrix,V4 == "-" & V5 == "C"))
  Gminus=nrow(subset(subMatrix,V4 == "-" & V5 == "G"))
  Tminus=nrow(subset(subMatrix,V4 == "-" & V5 == "T"))
  if(reads==0){
    ASratio=0
    MODratio=0
    Aratio=0
    Cratio=0
    Gratio=0
    Tratio=0
  }
  else {
    ASratio=round(stranded/reads,2)
    MODratio=round(mod/reads,2)
    Aratio=round(Aminus/(Aplus+Aminus),2)
    Cratio=round(Cminus/(Cplus+Cminus),2)
    Gratio=round(Gminus/(Gplus+Gminus),2)
    Tratio=round(Tminus/(Tplus+Tminus),2)
  }
  return(as.character(c(header,reads,mod,MODratio,stranded,ASratio,Aplus,Cplus,Gplus,Tplus,Aminus,Cminus,Gminus,Tminus,Aratio,Cratio,Gratio,Tratio)))
}

computeStatsNeg <- function(subMatrix,header){
  reads=nrow(subMatrix)
  mod=nrow(subset(subMatrix,V3 == "Y"))
  stranded=nrow(subset(subMatrix,V4 == "+"))
  Aminus=nrow(subset(subMatrix,V4 == "+" & V5 == "A"))
  Cminus=nrow(subset(subMatrix,V4 == "+" & V5 == "C"))
  Gminus=nrow(subset(subMatrix,V4 == "+" & V5 == "G"))
  Tminus=nrow(subset(subMatrix,V4 == "+" & V5 == "T"))
  Aplus=nrow(subset(subMatrix,V4 == "-" & V5 == "A"))
  Cplus=nrow(subset(subMatrix,V4 == "-" & V5 == "C"))
  Gplus=nrow(subset(subMatrix,V4 == "-" & V5 == "G"))
  Tplus=nrow(subset(subMatrix,V4 == "-" & V5 == "T"))
  if(reads==0){
    ASratio=0
    MODratio=0
    Aratio=0
    Cratio=0
    Gratio=0
    Tratio=0
  }
  else {
    ASratio=round(stranded/reads,2)
    MODratio=round(mod/reads,2)
    Aratio=round(Aminus/(Aplus+Aminus),2)
    Cratio=round(Cminus/(Cplus+Cminus),2)
    Gratio=round(Gminus/(Gplus+Gminus),2)
    Tratio=round(Tminus/(Tplus+Tminus),2)
  }
  return(as.character(c(header,reads,mod,MODratio,stranded,ASratio,Aplus,Cplus,Gplus,Tplus,Aminus,Cminus,Gminus,Tminus,Aratio,Cratio,Gratio,Tratio)))
}

#create table for stats results
Stats=c("region","reads","modified","MODratio","antisenseReads","ASratio","A+","C+","G+","T+","A-","C-","G-","T-","Aratio","Cratio","Gratio","Tratio")
for(name in allNames){
subtt=subset(tt,V1==name)
subtt=subset(subtt, V2 > rmin & V2 < rmax)
#subtt=subset(subtt, V2 > 16 & V2 <27)
#add statistics for this subset
idx=which(annotations$label==name)
strandInfo=annotations$strand[idx][1]
if(strandInfo=="+") {
  Stats=rbind(Stats,computeStats(subtt,name))
} else {
  #For -ve gene direction
  Stats=rbind(Stats,computeStatsNeg(subtt,name))
}
}
Stats2=calcTPM(Stats, annotations)
names(Stats2)=NULL
Stats2=data.frame(lapply(Stats2, as.character), stringsAsFactors=FALSE)
thead=c("region","reads","modified","MODratio","antisenseReads","ASratio","A+","C+","G+","T+","A-","C-","G-","T-","Aratio","Cratio","Gratio","Tratio","TPM")
Stats=rbind(thead,as.data.frame(Stats2))

#add the header line of allCounts to the matrix to have the same nrow then Stats
#allCounts = rbind(names,allCounts)
allCounts=rbind(c("region",names),allCounts)

dfLenCounts=as.data.frame(allCounts)
colnames(dfLenCounts)=allCounts[1,]
dfLenCounts=dfLenCounts[-1,]

colnames(Stats)=thead
Stats=Stats[-1,]

mergedStats=merge(Stats,dfLenCounts,by="region")

#Stats=cbind(Stats,allCounts)
write.table(mergedStats,outStats,quote=F,col.names=T,row.names=F,sep=" ")


rm(list=ls())
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)

# set dataset

dataset <- "Streicher"

# AI
#h1 <- "AIvSA"
#h2 <- "AIvSI"
#h3 <- "AIvAvg"
## SA
#h <- "SAdGLS"
#h1 <- "SAvSI"
#h2 <- "SAvSI"
#h3 <- "SAvAvg"
## SI
#h <- "SIdGLS"
#h1 <- "SIvAI"
#h2 <- "SIvSA"
#h3 <- "SIvAvg"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

V <- function(df.g,xval.g,yval.g,ylablab.g,ytic.g,hline.g,cc.g,title.g){
  GL_violin <- ggplot(df.g, aes(x=xval.g, y=yval.g, fill=xval.g)) +
    geom_violin(trim=TRUE) +
    geom_point(shape = 18,size=0.5, position = position_jitterdodge(), color='black',alpha=1)+
    scale_color_manual(values=cc.g) + scale_fill_manual(values=cc.g) +
    theme_classic() +
    theme(plot.title = element_text(hjust = 0.5, size=16),
          axis.text = element_text(size=10, color="black"),
          text = element_text(size=14),
          legend.position = "none") +
    labs(y=ylablab.g,x="")  +
    ggtitle(title.g) +
    coord_cartesian(ylim=ytic.g) +
    scale_y_continuous(breaks = ytic.g) +
    geom_hline(yintercept=hline.g,color=c("black"), linetype="dashed", size=0.5)
  return(GL_violin)
}

# Colors
color_S <- "orange"
color_TP <- "springgreen4"
color_AI <- "#2BB07FFF"
color_SA <- "#38598CFF"
color_SI <- "#C2DF23FF"

# Add column to name type of support
mLGL <- mutate(mLGL, supportType = case_when(TvS != 'a' ~ "dGLS"))
mLBF <- mutate(mLBF, supportType = case_when(TvS != 'a' ~ "BF"))

df.1 <- mLGL
xval.1 <- mLGL$supportType
ylablab.1 <- "dGLS value"
hline.1 <- c(-0.5,0.5)

support <- "dGLS"

h1 <- "AI"
yval.1 <- mLGL$AIvSA
yval.2 <- mLGL$AIvSI
cc.1 <- c(color_AI)

h2 <- "SA"
yval.3 <- mLGL$AIvSA*(-1) # reversing values
yval.4 <- mLGL$SAvSI
cc.2 <- c(color_SA)

h3 <- "SI"
yval.5 <- mLGL$AIvSI*(-1) # reversing values
yval.6 <- mLGL$SAvSI*(-1) # reversing
cc.3 <- c(color_SI)

max(c(abs(yval.1),abs(yval.2),abs(yval.3),abs(yval.4),abs(yval.5),abs(yval.6)))
limit.1 <- 45
ytic.1 <- c(seq(-limit.1,limit.1,5))

title.1 <- paste(h1,h2,sep="v")
title.2 <- paste(h1,h3,sep="v")
title.3 <- paste(h2,h1,sep="v")
title.4 <- paste(h2,h3,sep="v")
title.5 <- paste(h3,h1,sep="v")
title.6 <- paste(h3,h2,sep="v")

GL.1 <- V(df.1,xval.1,yval.1,ylablab.1,ytic.1,hline.1,cc.1,title.1)
GL.2 <- V(df.1,xval.1,yval.2,ylablab.1,ytic.1,hline.1,cc.1,title.2)
GL.3 <- V(df.1,xval.1,yval.3,ylablab.1,ytic.1,hline.1,cc.2,title.3)
GL.4 <- V(df.1,xval.1,yval.4,ylablab.1,ytic.1,hline.1,cc.2,title.4)
GL.5 <- V(df.1,xval.1,yval.5,ylablab.1,ytic.1,hline.1,cc.3,title.5)
GL.6 <- V(df.1,xval.1,yval.6,ylablab.1,ytic.1,hline.1,cc.3,title.6)

GL <- ggarrange(GL.1, GL.2, GL.3, GL.4, GL.5, GL.6, ncol=6, nrow=1, align="h")
GL

#ggsave(paste(dataset,"_violin_scaled_",h,".pdf",sep=""), plot=GL,width = 6, height = 7, units = "in", device = 'pdf',bg = "transparent")
ggsave(paste(dataset,"_violin_wide_","all",".pdf",sep=""), plot=GL,width = 9, height = 7, units = "in", device = 'pdf',bg = "transparent")

# Remove variables im gonna duplicate for BF
rm(h, df.1,xval.1,yval.1,yval.2,yval.3,ylablab.1,ytic.1,hline.1,title.1,title.2,title.3)

df.1 <- mLBF
xval.1 <- mLBF$supportType
ylablab.1 <- "2ln(BF) value"
hline.1 <- c(-10,10)

support <- "BF"

h1 <- "AI"
yval.1 <- mLBF$AIvSA
yval.2 <- mLBF$AIvSI
cc.1 <- c(color_AI)

h2 <- "SA"
yval.3 <- mLBF$AIvSA*(-1) # reversing values
yval.4 <- mLBF$SAvSI
cc.2 <- c(color_SA)

h3 <- "SI"
yval.5 <- mLBF$AIvSI*(-1) # reversing values
yval.6 <- mLBF$SAvSI*(-1) # reversing
cc.3 <- c(color_SI)

max(c(abs(yval.1),abs(yval.2),abs(yval.3),abs(yval.4),abs(yval.5),abs(yval.6)))
limit.1 <- 120
ytic.1 <- c(seq(-limit.1,limit.1,10))

title.1 <- paste(h1,h2,sep="v")
title.2 <- paste(h1,h3,sep="v")
title.3 <- paste(h2,h1,sep="v")
title.4 <- paste(h2,h3,sep="v")
title.5 <- paste(h3,h1,sep="v")
title.6 <- paste(h3,h2,sep="v")

BF.1 <- V(df.1,xval.1,yval.1,ylablab.1,ytic.1,hline.1,cc.1,title.1)
BF.2 <- V(df.1,xval.1,yval.2,ylablab.1,ytic.1,hline.1,cc.1,title.2)
BF.3 <- V(df.1,xval.1,yval.3,ylablab.1,ytic.1,hline.1,cc.2,title.3)
BF.4 <- V(df.1,xval.1,yval.4,ylablab.1,ytic.1,hline.1,cc.2,title.4)
BF.5 <- V(df.1,xval.1,yval.5,ylablab.1,ytic.1,hline.1,cc.3,title.5)
BF.6 <- V(df.1,xval.1,yval.6,ylablab.1,ytic.1,hline.1,cc.3,title.6)

BF <- ggarrange(BF.1, BF.2, BF.3, BF.4, BF.5, BF.6, ncol=6, nrow=1, align="h")
BF

ggsave(paste(dataset,"_violin_wide_allBF",".pdf",sep=""), plot=BF,width = 9, height = 7, units = "in", device = 'pdf',bg = "transparent")

both <- ggarrange(GL.1,BF.1,GL.2,BF.2, ncol=4,nrow=1,align="h")
both
ggsave(paste(dataset,"_violin_scaled_",h3,"_BFdGLS.pdf",sep=""), plot=BF,width = 6, height = 7, units = "in", device = 'pdf',bg = "transparent")


#install.packages("arules")
library(arules)

numcols <- 3;
clabels <- c(1, 2, 3)

x <- read.csv("../data/wine.csv", header=FALSE)
for (i in 1:13) { x[,i] = discretize(x[,i], categories=numcols, labels=clabels) }
write.table(x, file="../data/wineDiscrete.csv", row.names=FALSE, quote=FALSE, na="", col.names=FALSE, sep=",")

x <- read.csv("../data/iris.csv", header=FALSE)
for (i in 1:4) { x[,i] = discretize(x[,i], categories=numcols, labels=clabels) }
write.table(x, file="../data/irisDiscrete.csv", row.names=FALSE, quote=FALSE, na="", col.names=FALSE, sep=",")

x <- read.csv("../data/heartDisease.csv", header=FALSE)
for (i in c(1,4,5,8,10)) { x[,i] = discretize(x[,i], categories=numcols, labels=clabels) }
write.table(x, file="../data/heartDiseaseDiscrete.csv", row.names=FALSE, quote=FALSE, na="", col.names=FALSE, sep=",")


Display "Colored Mirrors" "Screen" "rgbobject"

Format 960 480

CameraAt  0 0 10
CameraEye -30 -40 15
CameraUp  0 0 1
CameraFOV 30.0

Background 0.28 0.56 0.71

WorldBegin
AmbientLight 1.0 1.0 1.0 0.39
PointLight 0 0 100 1.0 1.0 1.0 3900
PointLight -10 10 20 1.0 0.0 0.0 177
PointLight  10 10 20 0.0 1.0 0.0 177
PointLight  10 -10 20 0.0 0.0 1.0 177

Surface "plastic"
Specular 1.0 1.0 1.0 20

#semi-glossy white plastic ground plane

Ka 0.7
Kd 0.7
Ks 0.3

PolySet "P"
4 1
-100.0 -100.0 0.0
 100.0 -100.0 0.0
 100.0  100.0 0.0
-100.0  100.0 0.0

0 1 2 3 -1

XformPush
Translate 0 0 5
Sphere 5 -5 5 360
XformPop

# A red mirror

Color 1.0 0.1 0.1
Specular 1.0 0.1 0.1 50
Ka 0.2
Kd 0.2
Ks 0.8

PolySet "P"
4 1
-10 20  0
 15 20  0
 15 20 20
-10 20 20

0 1 2 3 -1

# A blue mirror

Color 0.1 0.1 1.0
Specular 0.1 0.1 1.0 50
Ka 0.2
Kd 0.2
Ks 0.8

PolySet "P"
4 1
 20  15  0
 20 -10  0
 20 -10 20
 20  15 20

0 1 2 3 -1

# A green mirror

Color 0.1 1.0 0.1
Specular 0.1 1.0 0.1 50
Ka 0.2
Kd 0.2
Ks 0.8

PolySet "P"
4 1
 14 20  0
 20 14  0
 20 14 20
 14 20 20

0 1 2 3 -1

WorldEnd