library(tidyverse)
library(USAboundaries)
library(tigris)
library(htmltab)
library(viridisLite)
library(scales)
library(data.table)
library(cowplot)
library(treemapify)
library(ggrepel)

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

us_nation = nation()

us_states_current = us_states()

us_cities_1790 = us_cities(map_date = '1790-01-01', states = NULL)

# treemap and packcircles

setwd("~/Public_Policy/Projects/History - union, polarization, power/data/historical census/historical population stats/nhgis0012_csv")
state_pop_series = read_csv('nhgis0012_ts_nominal_state.csv') %>%
  pivot_longer(
    cols = starts_with('A00AA'),
    values_to = 'population'
  ) %>%
  mutate(
    year = str_extract(name, '([0-9]{4})$') %>% as.numeric()
  ) %>%
  select(-name)

pop_by_year = group_by(state_pop_series, year) %>%
  summarize(
    total_pop = sum(population, na.rm = T)
  ) %>%
  ungroup()

state_pop_series = left_join(
  state_pop_series,
  pop_by_year
) %>%
  mutate(
    pct_of_total_pop = population / total_pop
  )

race_stats_table = htmltab('https://faculty.weber.edu/kmackay/statistics_on_slavery.htm')

setwd("~/Public_Policy/Projects/History - union, polarization, power/data/historical census/historical race stats/nhgis0018_csv")

file_list = list.files()
stat_files = list.files(pattern = '.csv')
codebook_files = list.files(pattern = '.txt')
file_years = str_extract(file_list, '_[0-9]{4}_state') %>% str_extract('[0-9]{4}') %>% unique()

sorted_file_years = file_years %>% sort() %>% as.character()
race_stat_files = map(sorted_file_years , function(the_year){
  # the_year = 1790 %>% as.character()
  # head(race_stats)
  total_pop_year = filter(state_pop_series, year == as.numeric(the_year))
  the_stat_file = stat_files[str_detect(stat_files, the_year)]
  the_codebook_file = codebook_files[str_detect(codebook_files, the_year)]

  race_stats = read_csv(the_stat_file) %>% left_join(total_pop_year)
  val_cols = names(race_stats)[str_detect(names(race_stats), '[A-Z0-9]{2,3}[0-9]+')]

  code_mappings = read_file(the_codebook_file) %>% str_split('\r\n') %>% unlist() %>% str_trim()
  # race_stats$total = rowSums(race_stats[,val_cols])

  for(the_col in val_cols) {
    col_mapping = code_mappings[str_detect(code_mappings, the_col)] %>% str_remove(the_col) %>% str_remove(':') %>% str_trim() %>%
      str_replace(':', ',')
    names(race_stats)[names(race_stats) == the_col] = col_mapping
  }
  white_col = names(race_stats)[names(race_stats) %>% tolower() == 'white']

  # if (length(white_col) > 0) {
  #   race_stats$white_total = race_stats[,white_col]
  #   race_stats$nonwhite_total = race_stats$population  - race_stats$white_total
  # } else {
  #   cat('no white col', the_year, '\n')
  # }
  race_stats$STATEA = NULL

  return(race_stats)

})
names(race_stat_files) = sorted_file_years

# race_stat_files[['1800']]
# race_stat_files[['1820']] %>% names()

race_stat_files[['1790']]$black_pop = race_stat_files[['1790']]$`Non-White, Free` + race_stat_files[['1790']]$`Non-White, Slave`
race_stat_files[['1800']]$black_pop = race_stat_files[['1800']]$`Nonwhite`
race_stat_files[['1810']]$black_pop = race_stat_files[['1810']]$`Nonwhite`
race_stat_files[['1820']]$black_pop = race_stat_files[['1820']]$`Slaves and free colored`
race_stat_files[['1830']]$black_pop = race_stat_files[['1830']]$`Non-white`
race_stat_files[['1840']]$black_pop = race_stat_files[['1840']]$`Nonwhite, Free` + race_stat_files[['1840']]$`Nonwhite, Slave`
race_stat_files[['1850']]$black_pop = race_stat_files[['1850']]$`Nonwhite, Free` + race_stat_files[['1850']]$`Nonwhite, Slave`

race_stat_files[['1860']]$black_pop = race_stat_files[['1860']]$`Free colored` + race_stat_files[['1860']]$Slave
race_stat_files[['1870']]$black_pop = race_stat_files[['1870']]$Colored
race_stat_files[['1880']]$black_pop = race_stat_files[['1880']]$Colored
race_stat_files[['1890']]$black_pop = race_stat_files[['1890']]$`Colored >> Male` + race_stat_files[['1890']]$`Colored >> Female`
race_stat_files[['1900']]$black_pop = race_stat_files[['1900']]$`Negro >> Male` + race_stat_files[['1900']]$`Negro >> Female`
race_stat_files[['1910']]$black_pop = race_stat_files[['1910']]$`Negro >> Male` + race_stat_files[['1910']]$`Negro >> Female`
race_stat_files[['1920']]$black_pop = race_stat_files[['1920']]$`Negro >> Male` + race_stat_files[['1920']]$`Negro >> Female`
race_stat_files[['1930']]$black_pop = race_stat_files[['1930']]$`Negro >> Male` + race_stat_files[['1930']]$`Negro >> Female`
race_stat_files[['1940']]$black_pop = race_stat_files[['1940']]$Negro
race_stat_files[['1950']]$black_pop = race_stat_files[['1950']]$`Male >> Negro` + race_stat_files[['1950']]$`Female >> Negro`
race_stat_files[['1960']]$black_pop = race_stat_files[['1960']]$`Male >> Negro` + race_stat_files[['1960']]$`Female >> Negro`

stats_since_1970 = read_csv('nhgis0018_ts_nominal_state.csv') %>%
  mutate(
    black_pop = B18AB
  )
stats_since_1970$population = rowSums(
  select(stats_since_1970, starts_with('B1')),
  na.rm = T
)

stacked_pops_since_1790_dt = race_stat_files %>%
  bind_rows() %>%
  select(GISJOIN, YEAR, STATE, black_pop, population) %>%
  bind_rows(
    stats_since_1970 %>%
      select(GISJOIN, YEAR, STATE, black_pop, population)
  ) %>%
  mutate(
    black_pct = black_pop / population
  ) %>%
  arrange(STATE, YEAR) %>%
  data.table()

stacked_pops_since_1790 = stacked_pops_since_1790_dt[, {

  list(
    YEAR = YEAR,
    black_pct_change = black_pct - lag(black_pct, 1),
    black_pop_change = black_pop - lag(black_pop, 1),
    black_pct = black_pct,
    population = population,
    black_pop = black_pop
  )
}, by = list(STATE, GISJOIN)] %>% as.data.frame()

filter(stacked_pops_since_1790, STATE == 'Louisiana', YEAR %in% c(1860, 1870, 1880))

ggplot(stacked_pops_since_1790 %>% filter(YEAR == 1790), aes(area = population, fill = black_pct, label = STATE)) +
  geom_treemap() +
  geom_treemap_text(fontface = "italic", colour = "gray", place = "centre",
                    grow = TRUE) +
  scale_fill_viridis_c(option = 'A', labels = percent)

ggplot(stacked_pops_since_1790 %>% filter(YEAR == 1870), aes(area = population, fill = black_pct, label = STATE)) +
  geom_treemap() +
  geom_treemap_text(fontface = "italic", colour = "gray", place = "centre",
                    grow = TRUE) +
  scale_fill_viridis_c(option = 'A', labels = percent)

stacked_pops_since_1790 %>% filter(YEAR == 1870) %>% arrange(-black_pct)

state_shapefiles = seq(1790, 2000, by = 10) %>% paste0('-01-01') %>% as.Date() %>% map(function(the_date){
  us_states(map_date = the_date) %>% mutate(map_date = the_date)
}) %>%
  bind_rows() %>%
  bind_rows(
    us_states(map_date = '2000-01-01') %>% mutate(map_date = '2010-01-01' %>% as.Date())
  ) %>%
  mutate(
    map_year = year(map_date)
  ) %>%
  filter(!str_detect(name, 'Alaska|Hawaii'))

joined_shapefiles = left_join(state_shapefiles, stacked_pops_since_1790, by = c('name' = 'STATE', 'map_year'='YEAR'))

ggplot(joined_shapefiles) +
  facet_wrap(~map_year) +
  theme_map() +
  geom_sf(aes(fill = black_pct)) +
  scale_fill_viridis_c(option = 'A', name = 'Black % of Population', labels = percent)

ggplot(joined_shapefiles) +
  facet_wrap(~map_year) +
  theme_map() +
  geom_sf(aes(fill = black_pct_change < -0.02))
  # scale_fill_gradient2(midpoint = 0, mid = '#ffffbf', high = '#fc8d59', low = '#91bfdb')
  # scale_fill_viridis_c(option = 'A', name = 'Black % of Population', labels = percent)

setwd("~/Public_Policy/Projects/History - union, polarization, power/output")
ggsave('black_pct_change_pop_map_hist.png', height = 14, width = 18, units = 'in', dpi = 600)

filter(stacked_pops_since_1790, YEAR %in% c(1880), black_pct >= .40) %>%
  ggplot(aes(STATE, black_pct, fill = factor(YEAR))) +
  geom_bar(stat = 'identity', position = 'dodge') +
  geom_hline(aes(yintercept = 0.5))

national_black_pop_total = group_by(stacked_pops_since_1790, YEAR) %>%
  summarize(
    total_black_pop = sum(black_pop, na.rm = T),
    total_pop = sum(population, na.rm = T)
  ) %>%
  bind_rows(
    # add in 1 year ACS estimates
    tibble(
      YEAR = 2019,
      total_pop = 328239523,
      total_black_pop = 41989671
    )
  ) %>%
  mutate(
    total_black_pct = total_black_pop / total_pop
  )

ggplot(national_black_pop_total %>% filter(between(YEAR, 1790, 2019)), aes(YEAR, (total_pop - lag(total_pop))/lag(total_pop))) +
  geom_bar(stat = 'identity') +
  scale_y_continuous(labels = percent) +
  scale_x_continuous(breaks = seq(1800, 2019, by = 10))

ggplot(national_black_pop_total , aes(YEAR, (total_black_pop - lag(total_black_pop))/lag(total_black_pop))) +
  geom_bar(stat = 'identity') +
  scale_y_continuous(labels = percent) +
  scale_x_continuous(breaks = seq(1800, 2019, by = 10))

# subset code_mappings to

us_states_1790 = us_states(map_date = '1790-01-01') %>%
  mutate(
    name = recode(name, `Vermont Republic` = 'Vermont')
  ) %>%
  left_join(race_stat_files[['1790']], by = c('name' = 'STATE')) %>%
  mutate(
    slave_pct = `Non-White, Slave` / population,
    slave_state = ifelse(slave_pct >= 0.1, 'Slave State', 'Non-Slave State')
  ) %>%
  arrange(
    -population
  ) %>%
  mutate(
    state_name_pop = factor(name, levels = rev(name))
  )

us_states_1790 = us_states(map_date = '1810-01-01') %>%
  mutate(
    name = recode(name, `Vermont Republic` = 'Vermont')
  ) %>%
  left_join(race_stat_files[['1790']], by = c('name' = 'STATE')) %>%
  mutate(
    slave_pct = `Non-White, Slave` / population,
    slave_state = ifelse(slave_pct >= 0.1, 'Slave State', 'Non-Slave State')
  ) %>%
  arrange(
    -population
  ) %>%
  mutate(
    state_name_pop = factor(name, levels = rev(name))
  )

ggplot() +
  geom_sf(data = us_states_current %>% filter(state_name %in% state.name[!state.name %in% c('Hawaii', 'Alaska')]), colour = NA, fill = 'gray60') +
  geom_sf(data = us_states_1790 %>% filter(), aes(fill = population)) +
  # geom_sf_label(data = us_states_1790, aes(label = state_name )) +
  # geom_sf(data = us_cities_1790, aes(size = population)) +
  scale_fill_viridis_c()

ggplot() +
  geom_sf(data = us_states_current %>% filter(state_name %in% state.name[!state.name %in% c('Hawaii', 'Alaska')]), colour = NA, fill = 'gray60') +
  geom_sf(data = us_states_1790 %>% filter(), aes(fill = slave_pct)) +
  scale_fill_viridis_c(labels = percent, option = 'A')

ggplot(us_states_1790 %>% filter(!is.na(population)), aes(state_name_pop, population, fill = slave_pct)) +
  labs(y = 'Population, 1790 Census', x = '') +
  theme_bw() +
  theme(legend.position = 'right') +
  geom_bar(stat = 'identity', colour = 'black') +
  scale_y_continuous(labels = comma) +
  coord_flip() +
  geom_text(aes(label = paste0(round(population/1000, 0), 'k (', percent(pct_of_total_pop, accuracy = 1), ')')), hjust = -0.1) +
  scale_fill_viridis_c(option = 'A', labels = percent, name = 'Percent of Pop.\nEnslaved')

group_by(us_states_1790, slave_state) %>%
  summarize(
    tot_population  = sum(population )
  )

setwd("~/Public_Policy/Projects/History - union, polarization, power/output")
ggsave('state_pop_1790_slavery.png', height = 9, width = 15, units = 'in', dpi = 600)

setwd("~/Public_Policy/Projects/History - union, polarization, power/data")
list.files(pattern = '.csv')
total_congressional_membership = read_csv("congress by party historical.csv") %>%
  mutate(
    Year = str_extract(Years, '[0-9]{4}') %>% as.numeric()
  ) %>%
  filter(PartyStatus == 'All')

african_americans_in_congress = read_csv("african americans in congress brookings.csv", na = c("", "NA", ".")) %>%
  group_by(Congress, Year, Chamber) %>%
  summarize(
    total_black_members = sum(Members, na.rm = T),
    dem_members = Members[Party == 'D']
  ) %>%
  ungroup() %>%
  bind_rows(
    tibble(
      Year = seq(1789, 1867, by = 2),
      Congress = 1:length(Year),
      Chamber = 'House',
      total_black_members = 0,
      dem_members = 0
    )
  ) %>%
  left_join(
    total_congressional_membership
  ) %>%
  mutate(
    total_seats = as.numeric(Seats),
    black_member_pct = ifelse(is.na(total_seats), 0, total_black_members / total_seats)
  ) %>%
  arrange(Congress, Chamber)

combined_black_representation_stats = bind_rows(
  african_americans_in_congress %>% mutate(variable = '% of Congress (House)', value = black_member_pct) %>% filter(Chamber == 'House'),
  national_black_pop_total %>% mutate(variable = '% of Population', value = total_black_pct ) %>% rename(Year = YEAR)
)
filter(combined_black_representation_stats, Year == 1881)

date_df = tribble(
  ~start_year, ~end_year, ~desc, ~color,
  1787, 1865, '1619-1865: Legalized Slavery', "black",
  1865, 1877, 'Post-Civil War\nReconstruction', 'lightgray',
  1877, 1965, 'Jim Crow Era', "black",
  1965, 2020, 'Post-Voting Rights Act', "lightgray"
) %>%
  mutate(
    desc_factor = factor(desc, levels = desc)
  )
fill_colors = date_df$color
names(fill_colors) = date_df$desc

ggplot(combined_black_representation_stats) +
  theme_bw() +
  labs(
    x = '', y = '',
    title = 'Timeline of Political Rights for Black Americans',
    subtitle = 'The number of black members of Congress is a measure of political rights and participation. After the Civil War, several black Americans were elected to Congress. This progress was halted by the Compromise of 1877, which removed federal troops from the South. By 1881, blacks comprised over 40% of the population in seven states, with majorities in three, yet only had two representatives in Congress.' %>% str_wrap(130),
    caption = 'Chart: Taylor G. White\nData: NHGIS/U.S. Census/ACS, Brookings'
  ) +
  theme(
    panel.grid.minor.x = element_blank()
  ) +
  large_text_theme +
  # geom_hline(aes(yintercept = 0)) +
  geom_rect(data = date_df, aes(
    xmin = start_year, xmax = end_year, ymin = 0, ymax = 0.20,
    fill = desc_factor
  ), alpha = 0.25, show.legend = F) +
  geom_text(
    data = filter(date_df, desc == 'Post-Civil War\nReconstruction'),
    aes(x = (start_year + end_year)/2, y = 0.2, label = desc),
    angle = 90, hjust = 1.1, size = 5
  ) +
  geom_text(
    data = filter(date_df, desc != 'Post-Civil War\nReconstruction'),
    aes(x = (start_year + end_year)/2, y = 0.2, label = desc),
    vjust = -1, size = 5
  ) +
  geom_step(aes(Year, value, linetype = variable), size = 1.25) +
  scale_x_continuous(breaks = seq(1790, 2020, by = 20)) +
  scale_fill_manual(
    values = fill_colors
  ) +
  # scale_fill_brewer(palette = 'Set1', name = '') +
  scale_linetype(name = 'Black American %', guide = F) +
  # geom_vline(aes(xintercept = 1964)) +
  scale_y_continuous( labels = percent) +
  geom_text(data = tibble(variable = c('% of Congress', '% of Population'), value = c(0.075, 0.135), Year = 2010),
            aes(Year, value, label = variable), size = 5)
  # geom_text_repel(data = combined_black_representation_stats %>% filter(Year %in% c(1930, 1931)), aes(Year, value, label = variable))

setwd("~/Public_Policy/Projects/History - union, polarization, power/output")
ggsave('black_political_rights_timeline.png', height = 10, width = 14, units = 'in', dpi = 600)

Projects/History - union, polarization, power/scripts/analyze_historical_population.r


# This R code generates REGIONAL graphs
clegenda <- c("Positive, total") #Legenda
colori <- c("red", "gray0", "seagreen4", "gold", "red3", "cyan", "mediumorchid3", "deepskyblue2", "navyblue") #Colors

# Generates regional graph for a given region
func_reg_graph <- function(dataset_cache, file_name) {
  png(file_name, width = 2500, height = 1250, pointsize = 50)
  plot(dataset_cache$totale_casi,type = "l", col = colori[c(1)], xlab = "", ylab = "Cases", main = dataset_cache$denominazione_regione[[1]], xaxt='n', lwd = 3)
  lines(dataset_cache$deceduti, type = "l", lwd = 3, col = colori[c(2)])
  lines(dataset_cache$dimessi_guariti, type = "l", lwd = 3, col = colori[c(3)])
  lines(dataset_cache$nuovi_positivi, type = "l", lwd = 3, col = colori[c(4)])
  lines(dataset_cache$totale_attualmente_positivi, type = "l", lwd = 3, col = colori[c(5)])
  lines(dataset_cache$isolamento_domiciliare, type = "l", lwd = 3, col = colori[c(6)])
  lines(dataset_cache$terapia_intensiva, type = "l", lwd = 3, col = colori[c(7)])
  lines(dataset_cache$ricoverati_con_sintomi, type = "l", lwd = 3, col = colori[c(8)])
  lines(dataset_cache$totale_ospedalizzati, type = "l", lwd = 3, col = colori[c(9)])
  legend("topleft", inset = .02, legend=clegenda, col=colori, lty=1, cex=0.75, lwd = 6)
  axis(1, at=1:day_count, labels=dataset_cache$data, las = 2, cex.axis = font_y)
  dev.off()
}

# Plots regions
for (region_code in 1:20) {
  region_subset <- subset(covid19_regioni, codice_regione == region_code)

  # To fix the 'sum is not meaningful for factors' error, remove unnecessary character variables
  region_subset$casi_testati = NULL
  region_subset$note_en = NULL
  region_subset$note_it = NULL

  # Ensure that 'tamponi' is a numeric variable
  region_subset$tamponi =
    as.numeric(region_subset$tamponi)

  # Handles and merge Trento and Bolzano
  if (region_code == 4){
    # Drops non-numerical columns
    region_subset <- select(region_subset, -c(2:6))
    # Converts to numeric
    region_subset[, c(2:11)] <- sapply(region_subset[, c(2:11)], as.numeric)
    # Aggregates by date, summing every other field
    region_subset <- aggregate(. ~data, data=region_subset, sum)
    # Inserts dropped columns after date (first) columns
    region_subset <- add_column(region_subset, stato = "ITA", codice_regione = 4, denominazione_regione = "Trentino Alto Adige", lat = 46.06893511, long = 11.12123097, .after = 1)
  }

  merged_region_name <- gsub(" ", "_", region_subset$denominazione_regione[1])
  merged_region_name <- gsub("'", "_", merged_region_name)
  region_plot_dir = paste("plot/regional/", merged_region_name, ".png", sep="")
  func_reg_graph(region_subset, region_plot_dir)
}


globalVariables(c("V4", "num"))

#' Celebrating software birthdays
#'
#' Accesses all public repositories belonging to a specific Github user and prints each repository's respective name, age, creation date of initial commit (i.e., repository birthday date), and time remaining until upcoming birthday.
#'
#' @param github_username Character vector of one Github username handle (e.g., "some_username_here").
#'
#' @return Returns data frame with repository name, age, creation date, and time remaining until upcoming birthday.
#'
#'
#' @importFrom lubridate month year mday as.duration
#' @import gh
#' @importFrom data.table as.data.table
#' @import tidyr
#' @importFrom dplyr arrange
#'
#' @examples
#' \donttest{celebrate("Bohdan-Khomtchouk")}
#'
#' @export

celebrate <- function(github_username) {

  oopts = options(warn=-1)
  on.exit(options(oopts))
	allrepos <- gh::gh("/users/:username/repos", username = github_username, type = "public", .limit = Inf)
	Repo_Name <- sapply(allrepos, "[[", "name")
	dates <- sapply(allrepos, "[[", "created_at")
	cleandates <- gsub("\\T.*", "", dates)
	Repo_Birthday <- cleandates
	age <- lubridate::as.duration(Sys.Date() - as.Date(cleandates))
	Repo_Age <- gsub(".*\\((.*)\\).*", "\\1", age)
	cyear <- lubridate::year(Sys.Date())
	cmonth <- lubridate::month(cleandates)
	cday <- lubridate::mday(cleandates)
	cdate <- as.Date(paste(cyear, cmonth, cday, sep='-'))

	before_or_after <- function(x) {
		if ((Sys.Date() < x) == TRUE) {
			countdown <- lubridate::as.duration(x - Sys.Date())
		} else {
			nyear <- lubridate::year(Sys.Date()) + 1
			cmonth <- lubridate::month(x)
			cday <- lubridate::mday(x)
			ndate <- as.Date(paste(nyear, cmonth, cday, sep='-'))
			countdown <- lubridate::as.duration(ndate - Sys.Date())
		}
	}

	time_in_sec <- sapply(cdate, before_or_after)
	time_in_dur <- lubridate::as.duration(time_in_sec)
	df <- as.data.frame(cbind(Repo_Name, Repo_Age, Repo_Birthday, as.character(time_in_dur)))
	df2 <- tidyr::separate(data = df, col = V4, into = c("num", "Time_Remaining_Until_Birthday"), sep = "s")
	df2$Time_Remaining_Until_Birthday <- sub("$", "s)", df2$Time_Remaining_Until_Birthday)
	df3 <- dplyr::arrange(df2, as.numeric(num))
	data.table::as.data.table(within(df3, rm(num)))

}


#################
# functions to run k-fold cross-validation
# inspired from: https://github.com/stan-dev/stancon_talks/blob/master/2017/Contributed-Talks/07_nicenboim/kfold.Rmd

# this function fit the models to the various folds
stan_kfold <- function(file, list_of_datas, chains, cores,...){
  library(pbmcapply)
  badRhat <- 1.1 # don't know why we need this?
  n_fold <- length(list_of_datas)
  model <- stan_model(file=file)
  # First parallelize all chains:
  sflist <-
    pbmclapply(1:(n_fold*chains), mc.cores = cores,
               function(i){
                 # Fold number:
                 k <- ceiling(i / chains)
                 s <- sampling(model, data = list_of_datas[[k]],
                               chains = 1, chain_id = i,init=init_fn)
                 return(s)
               })
  # Then merge the K * chains to create K stanfits:
  stanfit <- list()
  for(k in 1:n_fold){
    inchains <- (chains*k - 2):(chains*k)
    # Merge `chains` of each fold
    stanfit[[k]] <- sflist2stanfit(sflist[inchains])
  }
  return(stanfit)
}

# this function extract the log-likelihoods
extract_log_lik_K <- function(list_of_stanfits, list_of_holdout, ...){
  require(loo)
  K <- length(list_of_stanfits)
  list_of_log_liks <- plyr::llply(1:K, function(k){
    extract_log_lik(list_of_stanfits[[k]],...)
  })
  # `log_lik_heldout` will include the loglike of all the held out data of all the folds.
  # We define `log_lik_heldout` as a (samples x N_obs) matrix
  # (similar to each log_lik matrix)
  log_lik_heldout <- list_of_log_liks[[1]] * NA
  for(k in 1:K){
    log_lik <- list_of_log_liks[[k]]
    samples <- dim(log_lik)[1]
    N_obs <- dim(log_lik)[2]
    # This is a matrix with the same size as log_lik_heldout
    # with 1 if the data was held out in the fold k
    heldout <- matrix(rep(list_of_holdout[[k]], each = samples), nrow = samples)
    # Sanity check that the previous log_lik is not being overwritten:
    if(any(!is.na(log_lik_heldout[heldout==1]))){
      warning("Heldout log_lik has been overwritten!!!!")
    }
    # We save here the log_lik of the fold k in the matrix:
    log_lik_heldout[heldout==1] <- log_lik[heldout==1]
  }
  return(log_lik_heldout)
}

# this function returns all the important metrics
# from log-likelihood matrices
kfold <- function(log_lik_heldout)  {
  library(matrixStats)
  logColMeansExp <- function(x) {
    # should be more stable than log(colMeans(exp(x)))
    S <- nrow(x)
    colLogSumExps(x) - log(S)
  }
  # See equation (20) of @VehtariEtAl2016
  pointwise <-  matrix(logColMeansExp(log_lik_heldout), ncol= 1)
  colnames(pointwise) <- "elpd"
  # See equation (21) of @VehtariEtAl2016
  elpd_kfold <- sum(pointwise)
  se_elpd_kfold <-  sqrt(ncol(log_lik_heldout) * var(pointwise))
  out <- list(
    #pointwise = pointwise,
    elpd_kfold = elpd_kfold,
    se_elpd_kfold = se_elpd_kfold)
  #structure(out, class = "loo")
}

#### function to generate positive definite matrix (covariance)
Posdef <- function (n, ev = runif(n, 0, 10))
{
  Z <- matrix(ncol=n, rnorm(n^2))
  decomp <- qr(Z)
  Q <- qr.Q(decomp)
  R <- qr.R(decomp)
  d <- diag(R)
  ph <- d / abs(d)
  O <- Q %*% diag(ph)
  Z <- t(O) %*% diag(ev) %*% O
  return(Z)
}

##### function to help initialization
init_fn <- function(){
  list(L_omega = chol(Posdef(K)))
}


#Code to make several figures that compare the changes in ccf of shared neoantigens and shared variants when going from initial to recurren tumors
#Adapted from one of Floris's previous exploratory figures
#Last part of this script makes Extended Data Figure 12A and is labelled clearly
#-----------------------------------------------------

library(DBI)
library(tidyverse)
library(ggplot2)
library(RColorBrewer)

con <- DBI::dbConnect(odbc::odbc(), "VerhaakDB")
res <- dbGetQuery(con, read_file("/projects/varnf/GLASS/GLASS/sql/neoag/neoag_ccf_shared.sql"))

############################################################################################################################################
## Plot ladder plot comparing initial and recurrence CCF
## For all genes w/ colored driver genes
## Faceted by driver gene
############################################################################################################################################

## Munge data
tmp <- res %>% filter(rank==1) %>%
  group_by(case_barcode)  %>%
  mutate(w = n()) %>%
  ungroup() %>%
  select(case_barcode, w, idh_codel_subtype, gene_symbol, variant_classification_vep, cellular_prevalence_a, cellular_prevalence_b,is_neoag) %>%
  gather(c(cellular_prevalence_a, cellular_prevalence_b), key = "sample_type", value = "ccf") %>%
  mutate(sample_type = factor(sample_type, levels = c("cellular_prevalence_a", "cellular_prevalence_b"), labels = c("P","R")),
         plot_id = paste(case_barcode,gene_symbol),
         gene_label = factor(case_when(gene_symbol == "TP53" ~ "TP53",
                                gene_symbol == "IDH1" ~ "IDH1",
                                gene_symbol == "ATRX" ~ "ATRX",
                                gene_symbol == "PTEN" ~ "PTEN",
                                gene_symbol == "PIK3CA" ~ "PIK3CA",
                                gene_symbol == "PIK3R1" ~ "PIK3R1",
                                gene_symbol == "NF1" ~ "NF1",
                                gene_symbol == "EGFR" ~ "EGFR",
                                gene_symbol == "CIC" ~ "CIC",
                                gene_symbol == "FUBP1" ~ "FUBP1",
                                gene_symbol == "TERT" ~ "TERT",
                                gene_symbol == "RB1" ~ "RB1",
                                TRUE ~ NA_character_)))

## Perform statistical testing
testWilcoxGroup <- function(df) {
  wtest = wilcox.test(df$ccf ~ df$sample_type, paired = TRUE, conf.int = TRUE)
  data.frame(n = nrow(df)/2,
             median_a = median(df$ccf[df$sample_type=="P"]),
             median_b = median(df$ccf[df$sample_type=="R"]),
             statistic = wtest$statistic,
             estimate = wtest$estimate,
             lcl = wtest$conf.int[1],
             ucl = wtest$conf.int[2],
             wilcox_p = wtest$p.value,
             test_str = sprintf("n=%s\n%s",
                                nrow(df),
                                case_when(wtest$p.value < 0.0001 ~ "P<0.0001",
                                          wtest$p.value > 0.05 ~ sprintf("P=%s", format(round(wtest$p.value, 2),scientific=F)),
                                          TRUE ~ sprintf("P=%s", format(round(wtest$p.value, 4),scientific=F)))),
             stringsAsFactors = FALSE)
}

test_case <- tmp %>%
  group_by(case_barcode,idh_codel_subtype) %>%
  do(testWilcoxGroup(.)) %>%
  ungroup()

test_neoag_case <- tmp %>%
  group_by(case_barcode,idh_codel_subtype,is_neoag) %>%
  do(testWilcoxGroup(.)) %>%
  ungroup()

test_subtype <- tmp %>%
  group_by(idh_codel_subtype) %>%
  do(testWilcoxGroup(.)) %>%
  ungroup()

test_neoag_subtype <- tmp %>%
  group_by(is_neoag,idh_codel_subtype) %>%
  do(testWilcoxGroup(.)) %>%
  ungroup()

test_gene <- tmp %>%
  filter(gene_symbol %in% tmp$gene_label) %>%
  group_by(gene_symbol) %>%
  do(testWilcoxGroup(.)) %>%
  ungroup() %>%
  mutate(gene_label = gene_symbol)

test_gene_subtype <- tmp %>%
  filter(gene_symbol %in% c("TP53","IDH1")) %>%
  group_by(gene_symbol,idh_codel_subtype) %>%
  do(testWilcoxGroup(.)) %>%
  ungroup()

## Plot for all genes
pdf("/projects/varnf/GLASS/Figures/resubmission/CCF_neoag_ladder.pdf")
g1 <- ggplot(tmp %>% filter(complete.cases(gene_label)), aes(x=sample_type, y=ccf, group=plot_id, color = gene_label)) +
  geom_point(data = tmp %>% filter(!complete.cases(gene_label))) +
  geom_line(data = tmp %>% filter(!complete.cases(gene_label))) +
  geom_point() +
  geom_line(na.rm = TRUE) +
  geom_text(data = test_neoag_subtype, aes(x=1.5, y=0.05, label = test_str), group = NA, color = "black") +
  facet_wrap(is_neoag~idh_codel_subtype) +
  scale_color_manual(values = c("#B4464B", "#B47846", "#B4AF46", "#82B446", "#4BB446", "#46B478", "#46B4AF", "#4682B4", "#464BB4", "#7846B4", "#AF46B4", "#B44682"), na.value = "gray75") +
  theme_bw(base_size = 12) +
  labs(x = "Sample Type", y = "Cancer Cell Fraction", color = "Gene Symbol")

g1
dev.off()

## Plot CCF wilcoxon results for each patient
test_neoag_case<- test_neoag_case %>%
  mutate(direction = case_when(wilcox_p < 0.05 & median_b > median_a ~ "CCF increase",
                               wilcox_p < 0.05 & median_b < median_a ~ "CCF decrease",
                               wilcox_p > 0.05 ~ "CCF stable",
                               TRUE ~ "???"))

test_neoag_case_counts <- test_neoag_case %>% count(idh_codel_subtype,is_neoag,direction) %>%
  group_by(idh_codel_subtype,is_neoag) %>%
  mutate(n_total=sum(nn),
         prop = nn/sum(nn),
         prop_txt = sprintf("%s%%", round(100*nn/sum(nn),1))) %>%
  ungroup()

pdf("/projects/varnf/GLASS/Figures/resubmission/CCF_neoag_barplot.pdf",width=6,height=6)
g2d <- ggplot(test_neoag_case, aes(x = idh_codel_subtype, fill = direction)) +
  geom_bar(position = position_dodge(width = 1)) +
  geom_text(data = test_neoag_case_counts, aes(label = prop_txt, y = nn + 2), position = position_dodge(width = 1)) +
  facet_grid(is_neoag~.) +
  theme_bw(base_size = 10) +
  labs(x = "Subtype", y = "Number of Patients", fill = "CCF Change") +
  scale_fill_manual(values = c( "#00A3FF", "#5C00FF", "#FFDC00")) +
  scale_y_continuous(expand = c(0,0)) +
  scale_x_discrete(expand = c(0,0)) +
  coord_cartesian(ylim=c(0,65)) +
  theme(axis.title = element_text(size = 10),
        axis.text = element_text(size=10),
        panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        panel.background = element_rect(fill = "transparent"),
        axis.line = element_blank()) #+
  #facet_wrap(~idh_codel_subtype)

g2d
dev.off()

## Plot bar plots counting clonality

## Munge data
tmp2 <- res %>% filter(rank==1) %>%
  select(case_barcode, idh_codel_subtype, variant_classification_vep, gene_symbol, cellular_prevalence_a, cellular_prevalence_b,is_neoag) %>%
  mutate(plot_id = paste(case_barcode,gene_symbol),
         gene_label = factor(case_when(gene_symbol == "TP53" ~ "TP53",
                                       gene_symbol == "IDH1" ~ "IDH1",
                                       gene_symbol == "ATRX" ~ "ATRX",
                                       gene_symbol == "PTEN" ~ "PTEN",
                                       gene_symbol == "PIK3CA" ~ "PIK3CA",
                                       gene_symbol == "PIK3R1" ~ "PIK3R1",
                                       gene_symbol == "NF1" ~ "NF1",
                                       gene_symbol == "EGFR" ~ "EGFR",
                                       gene_symbol == "CIC" ~ "CIC",
                                       gene_symbol == "FUBP1" ~ "FUBP1",
                                       gene_symbol == "TERT" ~ "TERT",
                                       gene_symbol == "RB1" ~ "RB1",
                                       TRUE ~ NA_character_)))

#Check to see if frameshift indels are enriched in CCF changes
wilcox_tab <- tmp2[which(tmp2[,"is_neoag"]==1),]
g1 <- nrow(wilcox_tab[which(wilcox_tab[,"cellular_prevalence_b"]<wilcox_tab[,"cellular_prevalence_a"] &
		   wilcox_tab[,"variant_classification_vep"]=="Frame_Shift_Del" | wilcox_tab[,"variant_classification_vep"]=="Frame_Shift_Ins"),])
g2 <- nrow(wilcox_tab[which(wilcox_tab[,"cellular_prevalence_b"]<wilcox_tab[,"cellular_prevalence_a"] &
		   wilcox_tab[,"variant_classification_vep"]!="Frame_Shift_Del" & wilcox_tab[,"variant_classification_vep"]!="Frame_Shift_Ins"),])
g3 <- nrow(wilcox_tab[which(wilcox_tab[,"cellular_prevalence_b"]>wilcox_tab[,"cellular_prevalence_a"] &
		   wilcox_tab[,"variant_classification_vep"]=="Frame_Shift_Del" | wilcox_tab[,"variant_classification_vep"]=="Frame_Shift_Ins"),])
g4 <- nrow(wilcox_tab[which(wilcox_tab[,"cellular_prevalence_b"]>wilcox_tab[,"cellular_prevalence_a"] &
		   wilcox_tab[,"variant_classification_vep"]!="Frame_Shift_Del" & wilcox_tab[,"variant_classification_vep"]!="Frame_Shift_Ins"),])
fish <- matrix(c(g1,g2,g3,g4),nrow=2,ncol=2)
fisher.test(fish)

## Plot scatter plot facetted per gene
pdf("/projects/varnf/GLASS/Figures/resubmission/CCF_gene_neoag_scatter.pdf",width=6,height=6)
g3 <- tmp2 %>% filter(complete.cases(gene_label)) %>%
  ggplot(aes(x=cellular_prevalence_a, y=cellular_prevalence_b, color = variant_classification_vep)) +
  geom_point() +
  facet_wrap(is_neoag~gene_label) +
  theme_bw(base_size = 12) +
  geom_abline(slope=1, alpha=0.2, linetype=2) +
  labs(x="Initial CCF", y="Recurrence CCF", color = "Variant Classification") +
  coord_cartesian(xlim = c(0,1), ylim = c(0,1)) +
  scale_color_manual(values=c("5'Flank" = brewer.pal(9, "Paired")[9],
                              "Frame_Shift_Del" = brewer.pal(7, "Paired")[1],
                              "Frame_Shift_Ins" = brewer.pal(7, "Paired")[2],
                              "In_Frame_Del" = brewer.pal(7, "Paired")[3],
                              "In_Frame_Ins" = brewer.pal(7, "Paired")[4],
                              "Missense_Mutation" = brewer.pal(7, "Paired")[5],
                              "Nonsense_Mutation" = brewer.pal(7, "Paired")[6],
                              "Splice_Site" = brewer.pal(9, "Paired")[7],
                              "Translation_Start_Site" = brewer.pal(9, "Paired")[8]))

g3
dev.off()

############################################################################################################################################
## Plot bar plots counting clonality
## For all genes w/ colored driver genes
## Faceted by driver gene
############################################################################################################################################

tmp3 <- res %>% filter(rank==1) %>%
  select(case_barcode, idh_codel_subtype, gene_symbol, clonality_a, clonality_b, is_neoag) %>%
  gather(c(clonality_a, clonality_b), key = "sample_type", value = "clonality") %>%
  mutate(sample_type = factor(sample_type, levels = c("clonality_a", "clonality_b"), labels = c("P","R")),
         plot_id = paste(case_barcode,gene_symbol),
         gene_label = factor(case_when(gene_symbol == "TP53" ~ "TP53",
                                       gene_symbol == "IDH1" ~ "IDH1",
                                       gene_symbol == "ATRX" ~ "ATRX",
                                       gene_symbol == "PTEN" ~ "PTEN",
                                       gene_symbol == "PIK3CA" ~ "PIK3CA",
                                       gene_symbol == "NF1" ~ "NF1",
                                       gene_symbol == "EGFR" ~ "EGFR",
                                       TRUE ~ NA_character_))) %>%
  filter(complete.cases(clonality))

pdf("/projects/varnf/GLASS/Figures/resubmission/CCF_clonality_bar_bad.pdf",width=6,height=6)
g5 <- ggplot(tmp3, aes(x=clonality, fill = sample_type)) +
  geom_bar(position = "dodge") +
  facet_wrap(is_neoag~idh_codel_subtype, scales = "free_y") +
  labs(x = "Clonality", y = "Number of Mutations", fill = "Sample Type") +
  theme_bw(base_size = 12) +
  scale_fill_manual(values = c("#B47846", "#4682B4"))

g5
dev.off()

tmp4 <- res %>%
  filter(rank==1, clonality_a != "ND", clonality_b != "ND") %>%
  select(case_barcode, idh_codel_subtype, gene_symbol, clonality_a, clonality_b,is_neoag) %>%
  mutate(clonality = sprintf("%s-%s", clonality_a, clonality_b)) %>%
  filter(complete.cases(clonality_a, clonality_b))

tmp4[,"is_neoag"] <- as.character(tmp4[,"is_neoag"])
tmp4[which(tmp4[,"is_neoag"]=="0"),"is_neoag"] <- "Non-immunogenic"
tmp4[which(tmp4[,"is_neoag"]=="1"),"is_neoag"] <- "Immunogenic"

tmp4_counts <- tmp4 %>%
  count(idh_codel_subtype, is_neoag, clonality) %>%
  group_by(is_neoag,idh_codel_subtype) %>%
  mutate(n_total=sum(n),
         prop = n/sum(n),
         prop_txt = sprintf("%s%%", round(100*n/sum(n),1))) %>%
  ungroup() %>%
  add_row(idh_codel_subtype="IDHmut-codel",
  		 is_neoag="Immunogenic",
  		 clonality="S-S",
  		 n = 0,
  		 n_total=76,
  		 prop=0,
  		 prop_txt="0%",
  		 .after=7)

subtypes <- (unique(as.data.frame(tmp4_counts[,"idh_codel_subtype"])))[,1]
pval <- rep(0,3)
for(i in 1:length(subtypes))
{
	tmp_test <- as.data.frame(tmp4_counts[which(tmp4_counts[,"idh_codel_subtype"]==subtypes[i]),])
	cc <- unique(tmp_test[,"clonality"])
	imm <- c("Immunogenic","Non-immunogenic")
	test <- matrix(0,nrow=length(cc),ncol=length(imm))
	rownames(test) <- cc
	colnames(test) <- imm
	test[,1] <- tmp_test[which(tmp_test[,"is_neoag"]==colnames(test)[1]),"n"]
	test[,2] <- tmp_test[which(tmp_test[,"is_neoag"]==colnames(test)[2]),"n"]

	pval[i] <- chisq.test(test)$p.value
}

#**********************************************************
#Extended Data Figure 12A: CCF clonality bar
#**********************************************************
gtsize = 6/(14/5)
pdf("/projects/varnf/GLASS/Figures/resubmission/final/EDF_CCF_clonality_bar.pdf", width=6, height = 4)
g6 <- ggplot(tmp4, aes(x=1, fill=clonality)) +
  geom_bar(position = position_dodge(width = 1,preserve="single")) +
  geom_text(data = tmp4_counts, aes(label = prop_txt, y = n + 0.02 * n_total), position = position_dodge(width = 1),size=gtsize) +
  facet_wrap(is_neoag~idh_codel_subtype, scales = "free") +
  labs(x = "Subtype", y = "Number of Mutations", fill = "Clonality") +
  theme_bw(base_size = 7)  +
  scale_fill_manual(values = c("#CA6720", "#2ECA20", "#2083CA", "#BC20CA")) +
  theme(axis.title.x=element_blank(),
        axis.text.x=element_blank(),
        axis.ticks.x=element_blank()) +
  scale_x_discrete(expand = c(0,0)) +
  theme(axis.title = element_text(size = 7),
        axis.text = element_text(size=7),
        panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        panel.background = element_rect(fill = "transparent"),
        axis.line = element_blank()) #+
g6
dev.off()


##' Generate quantile regression ensembles and an equal-weighted ensemble
##'
##' Produces variants of QRA where the weights are optimised per quantile or
##' not, with or without intercept, and normalised to sum up to 1 or not.
##' @param forecasts data frame of forecasts
##' @param data data from of validation data
##' @param all_dates whether ensembles are to be generated for all creation
##' dates; otherwise will just do the latest
##' @param max_history maximum history to consider in QRA
##' @param exclude any data to exclude
##' @param ... any options to pass to the \link{qra} function.
##' @importFrom tidyr pivot_wider pivot_longer nest unnest expand_grid
##' @importFrom dplyr mutate select
##' @importFrom furrr future_map
##' @importFrom purrr map
##' @importFrom future plan multisession
##' @return a data frame with the ensembles
##' @author Sebastian Funk
generate_ensembles <- function(forecasts, data, all_dates = TRUE, max_history = 5, exclude = NULL, ...) {

  data_present <- data %>%
    select(value_date, geography, value_type)

  ## fill quantiles
  complete_forecasts <- forecasts %>%
    pivot_wider(names_from = "quantile", values_from = "value") %>%
    nest(data = matches("^[0-9]")) %>%
    mutate(extrapolated = purrr::map(data, estimate_quantiles)) %>%
    unnest(extrapolated) %>%
    select(-data) %>%
    pivot_longer(names_to = "quantile", values_to = "value", matches("^[0-9]")) %>%
    mutate(quantile = as.numeric(quantile)) %>%
    inner_join(data_present, by = c("value_date", "geography", "value_type"))

  estimate_weights <- function(x, ...) {
    creation_date <- x$creation_date
    norm <- x$norm
    per_quantile_weights <- x$per_quantile_weights
    history_weeks <- x$history_weeks

    name <- paste("QRA",
                  if_else(norm == 1, "Norm", "NoNorm"),
                  if_else(per_quantile_weights == 1, "PQ", "NoPQ"),
                  if_else(per_quantile_weights == 2, "Int", "NoInt"),
                  history_weeks)

    message(date(), " ", creation_date, " ", name)
    pool <- "horizon" ## integrate over all horizons

    qe <-
      qra(complete_forecasts,
          data, target_date = as.Date(creation_date),
          pool = pool,
          enforce_normalisation = (norm == 1),
          per_quantile_weights = (per_quantile_weights == 1),
          intercept = (per_quantile_weights == 2),
          history = history_weeks, ...)

    if (!is.null(qe$weights)) {
      qe$ensemble <- qe$ensemble %>%
        mutate(model = name)
      qe$weights <- qe$weights %>%
        mutate(qra_model = name,
               creation_date = as.Date(creation_date))
    }

    x$weights <- list(qe$weights)
    x$ensemble <- list(qe$ensemble)

    return(x)
  }

  creation_dates <- unique(forecasts$creation_date)
  if (!all_dates) creation_dates <- last(creation_dates)

  future::plan(future::multisession)

  ## check all combinations of: normalise, intercept, per quantile wieghts,
  ## number of weeks of history to consider
  qra_weights <-
    expand_grid(creation_date = creation_dates,
                norm = c(0, 1),
                per_quantile_weights = c(0, 1, 2), ## 2: intercept
                history_weeks = 1:max_history) %>%
    mutate(id = 1:n()) %>%
    nest(data = c(-id)) %>%
    mutate(qra = furrr::future_map(data, estimate_weights, .progress = TRUE)) %>%
    select(-id, -data) %>%
    unnest(qra)

  ewq_weights_mean <-
    tibble(ensemble =
             list(complete_forecasts %>%
                  group_by_at(vars(-model, -value)) %>%
                  summarise(value = mean(value), nmodels = n(), .groups = "drop") %>%
                  ungroup() %>%
                  mutate(model = "EWQmean")))

  ewq_weights_median <-
    tibble(ensemble =
             list(complete_forecasts %>%
                  group_by_at(vars(-model, -value)) %>%
                  summarise(value = median(value), nmodels = n(), .groups = "drop") %>%
                  ungroup() %>%
                  mutate(model = "EWQmedian")))

  ensembles <- qra_weights %>%
    select(ensemble) %>%
    bind_rows(ewq_weights_mean) %>%
    bind_rows(ewq_weights_median) %>%
    unnest(ensemble)

  weights <- qra_weights %>%
    select(weights) %>%
    unnest(weights)

  return(list(ensembles = ensembles, qra_weights = weights))
}


# Data Wrangling in R
# Coal Consumption Case Study

# Load the tidyverse
library(tidyverse)

# Read in the coal dataset
coal <- read_csv("http://594442.youcanlearnit.net/coal.csv")
glimpse(coal)

# Skip the first two lines
coal <- read_csv("http://594442.youcanlearnit.net/coal.csv", skip=2)
glimpse (coal)

# Rename the first column as region
colnames(coal)[1] <- "region"
summary(coal)


\name{hc_png-HilbertCurve-method}
\alias{hc_png,HilbertCurve-method}
\alias{hc_png}
\title{
Save Hilbert curve as a PNG figure
}
\description{
Save Hilbert curve as a PNG figure
}
\usage{
\S4method{hc_png}{HilbertCurve}(object, file = "HilbertCurve.png")
}
\arguments{

  \item{object}{A \code{\link{HilbertCurve-class}} object.}
  \item{file}{file name. If the suffix of the file name is not \code{.png},  it will be added automatically no matter you like it or not.}

}
\details{
A PNG figure with resolution of \code{2^level x 2^level} is generated.

Only the body of the Hilbert curve will be written to PNG file.

This function only works under 'pixel' mode.
}
\value{
No value is returned.
}
\author{
Zuguang Gu <z.gu@dkfz.de>
}
\examples{
hc = HilbertCurve(1, 100, level = 9, mode = "pixel")

x = sort(sample(100, 20))
s = x[1:10*2 - 1]
e = x[1:10*2]
require(IRanges)
ir = IRanges(s, e)

hc_layer(hc, ir)
hc_png(hc, file = "test.png")
}


# GetAuditAnnuallyData.r

source("../common/DataUtil.r")

# G E T   D A T A
rm(results)
results <- fndfGetGiantData("./")
# Get fewer columns to work with, easier to see.
dat.auditannually <- fndfGetAuditData(results)

# T A B U L A T E   D A T A
# Tabulate columns by copies and sector lifetime.
tbl.auditannually <- data.frame(with(dat.auditannually,
            tapply(mdmlosspct, list(copies, lifem), FUN=identity)))
# Re-form the data into a table for printing.
foo<-(with(dat.auditannually,
       tapply(mdmlosspct, list(copies, lifem), FUN=identity)))
foo2<-cbind(as.numeric(levels(factor(results$copies))), foo)
tbl2<-data.frame(foo2)
colnames(tbl2)<-c("copies",as.numeric(colnames(foo2[,2:ncol(foo2)])))
# Pretty-print this to a file with explanatory headings.
sOutputFilename <- "./Data_AuditAnnually.txt"
sTitle <- "Document losses with multiple copies and annual total auditing"
sSubtitle <- "Table of percentage loss of collection tabulated\n" %+%
    "by number of copies and sector half-lifetime"
sink(sOutputFilename)
cat("MIT Preservation Simulation Project", "\n\n")
cat(sOutputFilename, format(Sys.time(),"%Y%m%d_%H%M%S%Z"), "\n\n")
cat(sTitle, "\n\n")
cat(sSubtitle, "\n\n")
cat("\n")
print(tbl2)
sink()

# Micah succeeded in bending dcast to his will, thanks; see email.
library(reshape2)
bar.small <- dat.auditannually[,c("copies", "lifem", "mdmlosspct")]
bar.melted <- melt(bar.small, id=c("copies", "lifem"))
bar.recast <- dcast(bar.melted, copies~lifem)

# P L O T   D A T A
library(ggplot2)

# Show lines for 3, 4, 5 copies, with annual total auditing, over wiiiide range.
nCopies <- 3
trows <- fnSelectCopies(dat.auditannually, nCopies)
gp <- ggplot(data=trows,aes(x=lifem,y=safe(mdmlosspct)))
gp <- gp +
        scale_x_log10() + scale_y_log10() +
        annotation_logticks()

gp <- gp +
        aes(trows, x=(lifem), y=(safe(mdmlosspct))) +
        geom_point(data=trows,
            color="red", size=5, shape=(48+nCopies)) +
        geom_line(data=trows,
            linetype="dashed", color="blue", size=1)

nCopies <- 4; trows <- fnSelectCopies(dat.auditannually, nCopies)
gp <- gp +
        aes(trows, x=(lifem), y=(safe(mdmlosspct))) +
        geom_point(data=trows,
            color="red", size=5, shape=(48+nCopies)) +
        geom_line(data=trows, linetype="dashed", color="blue", size=1)

nCopies <- 5; trows <- fnSelectCopies(dat.auditannually, nCopies)
gp <- gp +
        aes(trows, x=(lifem), y=(safe(mdmlosspct))) +
        geom_point(data=trows,
            color="red", size=5, shape=(48+nCopies)) +
        geom_line(data=trows, linetype="dashed", color="black", size=1)

gp <- gp + ggtitle("With annual auditing, we need only a few copies\nto minimize permanent losses over a wide range")
gp <- gp + xlab("sector half-life (megahours)")
gp <- gp + ylab("percent permanent document losses")
gp <- gp + theme(
            axis.text=element_text(size=12),
            axis.title=element_text(size=18),
            plot.title=element_text(size=20,face="bold"),
            panel.border = element_rect(color = "black", fill=NA, size=1)
            )

plot(gp)
fnPlotMakeFile(gp, "baseline-auditannually.png")

# Unwind any remaining sink()s to close output files.
while (sink.number() > 0) {sink()}


#' Composition analysis
#'
#' Calculates nucleotide composition of a list of DNA sequenses
#'
#' @export

comp_ly <- function(x){
  if(!is.list(x)){
    cat("Just one perhap very long sequence?\n")
    x = list(x)
  }
  return(cbind(base_freq(x), n3_freq(x), augc_freq(x), gcx(x,1), gcx(x,2), gcx(x,3)))
}


#!/usr/bin/Rscript
ListPackNeed=c("ggpubr", "optparse", "gridExtra")
ListPackNeedIn<-ListPackNeed[!ListPackNeed %in% rownames(installed.packages())]
for(pack in ListPackNeedIn)if(pack %in% rownames(installed.packages()) == FALSE) {install.packages(pack, lib=.libPaths()[2], repos='http://cran.us.r-project.org')}
library("ggpubr")
library("optparse")
require(gridExtra)

#!/usr/bin/Rscript
as.characterspe<-function(x,round=2){
y<-rep(NA, length(x))
bal=!is.na(x) & x>10**-round
y[bal]<-as.character(format(round(x[bal],round), scientific=F))
y[!bal]<-as.character(format(x[!bal], scientific=T,digits=round))
y
}

GetGPlotBox<-function(datamerg, pheno, title){
UnRes<-unique(datamerg$GENO)
if(length(UnRes)==3){
my_comparisons <- list(c(UnRes[1], UnRes[3]), c(UnRes[2], UnRes[3]), c(UnRes[1], UnRes[2]) )
reskr<-kruskal.test(as.formula(paste(pheno,"~ GENO")), data = datamerg)
p <- ggboxplot(datamerg, x = "GENO", y = pheno, color = "GENO", palette = "jco", title=title,subtitle=paste("Kruskal-Wallis test, p = ", as.characterspe(reskr$p.value),sep="")) + stat_compare_means(comparisons=my_comparisons)
}else{
my_comparisons <- list(c(UnRes[1], UnRes[2]))
p <- ggboxplot(datamerg, x = "GENO", y = pheno, color = "GENO", palette = "jco") + stat_compare_means(comparisons=my_comparisons)
}
p
}
getresidual<-function(datamerge, pheno, cov){
datamerg$FIDIID<-paste(datamerg[,1], datamerg[,2])
rownames(datamerg)<-datamerg$FIDIID
Res<-glm(as.formula(paste(pheno,"~", paste(cov, collapse="+"))), data=datamerg)$residuals
datamergres=merge(datamerg, data.frame(FIDIID=names(Res), residuals=Res), by="FIDIID")
return(datamergres)
}

option_list = list(
  make_option(c("-d", "--data"), type="character",
              help="data files with phenotype and FID", metavar="character"),
  make_option(c("-p", "--ped"), type="character",
              help="ped file contains genotype for each ", metavar="character"),
  make_option(c("-e", "--pheno"), type="character",
              help="ped file contains genotype for each ", metavar="character"),
  make_option(c("-c", "--cov"), type="character",
              help="ped file contains genotype for each ", metavar="character"),
  make_option(c("-t", "--type_out"), type="character", default="pdf",
              help="type output file name [default= %default]", metavar="character"),
  make_option(c("-g", "--gxe"), type="character",
              help="type output file name [default= %default]", metavar="character"),
  make_option(c("-o", "--out"), type="character", default="out",
              help="output file name [default= %default]", metavar="character")
);

args = commandArgs(trailingOnly=TRUE)
if(length(args)<2){
opt=list(ped="test/plk_rs190712692.ped",data="test/All.pheno",out="test_rs1.pdf", pheno="cholesterol_1_qc", cov="sex,age")
}else{
opt = OptionParser(option_list=option_list);
opt = parse_args(opt);
}
data_ped=read.table(opt[["ped"]], sep="\t")
data_pheno=read.table(opt[["data"]], header=T)
data_ped<-data_ped[, c(1,2,ncol(data_ped))]
names(data_ped)<-c("FID","IID","GENO")
pheno<-opt[['pheno']]
cov<-c()
gxe<-c()
if(!is.null(opt[['gxe']]))gxe=opt[['gxe']]
if(!is.null(opt[['cov']]))cov=gsub(" ","",strsplit(opt[['cov']],split=",")[[1]])

datamerg<-merge(data_pheno[,c(names(data_pheno)[1:2],pheno,cov, gxe)], data_ped)
datamerg<-na.omit(datamerg)

if(length(cov)>0)datamergres<-getresidual(datamerge, pheno, cov)

if(length(gxe)==0){
p<-GetGPlotBox(datamerg,pheno, pheno)
if(length(cov)>0){
p2<-GetGPlotBox(datamergres,pheno, paste("res ",paste(pheno,"~", paste(cov, collapse="+"))))
gg<-arrangeGrob(p, p2, ncol=2)
}else{
gg<-p
}
}else{
stat1=unique(datamerg[,gxe])[1]
stat2=unique(datamerg[,gxe])[2]
p<-GetGPlotBox(datamerg[datamerg[, gxe]==stat1,],pheno, paste(pheno,", ", gxe, ": ", stat1,sep=""))
p2<-GetGPlotBox(datamerg[datamerg[, gxe]==stat2,],pheno, paste(pheno,", ", gxe, ": ", stat2,sep=""))
if(length(cov)>0){
p3<-GetGPlotBox(datamergres[datamergres[, gxe]==stat1,],pheno, paste("res ",pheno,", ", gxe, ": ", stat1,sep=""))
p4<-GetGPlotBox(datamergres[datamergres[, gxe]==stat2,],pheno, paste("res ",pheno,", ", gxe, ": ", stat2,sep=""))
gg<-arrangeGrob(p, p2, p3,p4, ncol=2, nrow=2)
}else{
gg<-arrangeGrob(p, p2, ncol=2)
}
}
ggsave(opt[['out']],gg,width=7, height=7)


library(shiny)
library(data.table)
library(ggplot2)

# ====================== #
#### GLOBAL VARIABLES ####
# ====================== #

# Datasets to create the same plots that we have in the CreatePlotsArticle.r
dataset_1 <- fread("main_data_aggregatedByCountry_preferencePCA_genderIndexPCA.csv")
dataset_2 <- fread("main_data_for_histograms.csv")

not_sel <- "Not Selected"

# =================== #
#### DEFINE THE UI ####
# =================== #

ui <- fluidPage(
  # Main title of the panel
  titlePanel("Descriptive Analysis"),
  # Create a side layout that will stay fixed for the whole time
  sidebarLayout(
    # What to show in the side panel
    sidebarPanel(
      # Short text for descriptive purposes
      helpText("Create plots for descriptive analysis"),
      # Interactive selection of input dataset
      selectInput("dataset",
                  label = "Choose a Dataset to display",
                  choices = c("Dataset 1",
                              "Dataset 2"
                  ),
                  selected = "Dataset 1"),
      # Interactive selection of the inputs: Select the type of plot to display
      # among the options listed, the selected by default being a scatter plot
      selectInput("plotType",
                  label = "Choose a plot to display",
                  choices = c("Scatter",
                              "Column",
                              "Histogram",
                              "Violin",
                              "Barplot"
                  ),
                  selected = "Scatter"),
      # According to the input selected above, set the variable names, their
      # labels and the choices among which to select.
      # IMPORTANT: Each condition MUST have different variable names because
      # in Java each element must be named in a unique way.
      conditionalPanel(
        condition = "input.plotType == 'Scatter'",
        selectInput("scatter_var_1", "Numeric Variable", choices = c(not_sel)),
        selectInput("scatter_var_2", "Numeric Variable", choices = c(not_sel)),
        selectInput("scatter_group_var", "Grouping Variable", choices = c(not_sel)),
        selectInput("scatter_facet_var", "Faceting Variable", choices = c(not_sel)),
        actionButton("scatter_run_button", "Run Analysis", icon = icon("play"))
      ),
      conditionalPanel(
        condition = "input.plotType == 'Histogram'",
        selectInput("hist_var_1", "Numeric Variable", choices = c(not_sel)),
        selectInput("hist_group_var", "Grouping Variable", choices = c(not_sel)),
        selectInput("hist_facet_var", "Faceting Variable", choices = c(not_sel)),
        actionButton("hist_run_button", "Run Analysis", icon = icon("play"))
      ),
      conditionalPanel(
        condition = "input.plotType == 'Violin'",
        selectInput("violin_var_1", "Numeric Variable", choices = c(not_sel)),
        selectInput("violin_group_var", "Grouping Variable", choices = c(not_sel)),
        selectInput("violin_facet_var", "Faceting Variable", choices = c(not_sel)),
        actionButton("violin_run_button", "Run Analysis", icon = icon("play"))
      ),
      conditionalPanel(
        condition = "input.plotType == 'Column'",
        selectInput("col_var_1", "Numeric Variable", choices = c(not_sel)),
        selectInput("col_var_2", "Numeric Variable", choices = c(not_sel)),
        selectInput("col_group_var", "Grouping Variable", choices = c(not_sel)),
        selectInput("col_facet_var", "Faceting Variable", choices = c(not_sel)),
        actionButton("col_run_button", "Run Analysis", icon = icon("play"))
      ),
      conditionalPanel(
        condition = "input.plotType == 'Barplot'",
        selectInput("bar_var_1", "Categorical Variable", choices = c(not_sel)),
        selectInput("bar_group_var", "Grouping Variable", choices = c(not_sel)),
        selectInput("bar_facet_var", "Faceting Variable", choices = c(not_sel)),
        actionButton("bar_run_button", "Run Analysis", icon = icon("play"))
      )
    ),

    # What to display in the main panel
    mainPanel(
      tabsetPanel(
        # Plot
        tabPanel(title = "Plot",
                 plotOutput("plot")
        ),
        # Instructions for the main plots of the article
        tabPanel(title = "Instructions to recreate the plots",
                 fluidRow(p(h5("Fig. 1A: Dataset 2 - Column Plot"),
                            "Numeric Variable (x) = GDPquant", br(),
                            "Numeric Variable (y) = meanGenderGDP", br(),
                            "Faceting Variable = preference",
                            style = "font-family: 'arial'; font-si16pt"),
                          br(),
                          p(h5("Fig. 1B: Dataset 1 - Scatter Plot"),
                            "Numeric Variable (x) = logAvgGDPpc", br(),
                            "Numeric Variable (y) = avgGenderDiffRescaled",
                            style = "font-family: 'arial'; font-si16pt"),
                          br(),
                          p(h5("Fig. 1C: Dataset 2 - Column Plot"),
                            "Numeric Variable (x) = GEIquant", br(),
                            "Numeric Variable (y) = meanGenderGEI", br(),
                            "Faceting Variable = preference",
                            style = "font-family: 'arial'; font-si16pt"),
                          br(),
                          p(h5("Fig. 1D: Dataset 1 - Scatter Plot"),
                            "Numeric Variable (x) = GenderIndexRescaled", br(),
                            "Numeric Variable (y) = avgGenderDiffRescaled",
                            style = "font-family: 'arial'; font-si16pt"),
                          br(),
                          p(h5("Fig. 2A: Dataset 1 - Scatter Plot"),
                            "Numeric Variable (x) = residualslogAvgGDPpc", br(),
                            "Numeric Variable (y) = residualsavgGenderDiff_GEI",
                            style = "font-family: 'arial'; font-si16pt"),
                          br(),
                          p(h5("Fig. 2B: Dataset 1 - Scatter Plot"),
                            "Numeric Variable (x) = residualsGenderIndexStd", br(),
                            "Numeric Variable (y) = residualsavgGenderDiff_GDP",
                            style = "font-family: 'arial'; font-si16pt"),
                          br(),
                          p(h5("Fig. 2C: Dataset 1 - Scatter Plot"),
                            "Numeric Variable (x) = residualsScoreWEFStd", br(),
                            "Numeric Variable (y) = residualsavgGenderDiff_GDP",
                            style = "font-family: 'arial'; font-si16pt"),
                          br(),
                          p(h5("Fig. 2D: Dataset 1 - Scatter Plot"),
                            "Numeric Variable (x) = residualsValueUNStd", br(),
                            "Numeric Variable (y) = residualsavgGenderDiff_GDP",
                            style = "font-family: 'arial'; font-si16pt"),
                          br(),
                          p(h5("Fig. 2E: Dataset 1 - Scatter Plot"),
                            "Numeric Variable (x) = residualsavgRatioLaborStd", br(),
                            "Numeric Variable (y) = residualsavgGenderDiff_GDP",
                            style = "font-family: 'arial'; font-si16pt"),
                          br(),
                          p(h5("Fig. 2F: Dataset 1 - Scatter Plot"),
                            "Numeric Variable (x) = residualsDateStd", br(),
                            "Numeric Variable (y) = residualsavgGenderDiff_GDP",
                            style = "font-family: 'arial'; font-si16pt"),
                          br(),
                 ))
      )
    )
  )
)

# =============================== #
#### DEFINE THE PLOT FUNCTIONS ####
# =============================== #
# Note: This is an extra to avoid having a lot of code in the server function

# Scatter Plot
draw_scatter <- function(data_input, scatter_var_1, scatter_var_2,
                         scatter_group_var, scatter_facet_var) {
  if (scatter_group_var != not_sel) {
    data_input[, (scatter_group_var) := as.factor(data_input[, get(scatter_group_var)])]
  }

  plot <- ggplot(data = data_input, aes_string(x = scatter_var_1,
                                               y = scatter_var_2))
  # Grouping variable
  if (scatter_group_var != not_sel) {
    plot <- plot + geom_point(aes_string(color = scatter_group_var))
  } else {
    plot <- plot + geom_point()
  }
  # Faceting variable
  if (scatter_facet_var != not_sel) {
    plot <- plot + facet_wrap(~ as.factor(get(scatter_facet_var)))
  }

  return(plot)
}

# Column Plot
draw_col <- function(data_input, col_var_1, col_var_2,
                     col_group_var, col_facet_var) {
  if (col_group_var != not_sel) {
    data_input[, (col_group_var) := as.factor(data_input[, get(col_group_var)])]
  }

  plot <- ggplot(data = data_input, aes_string(x = col_var_1,
                                               y = col_var_2))
  # Grouping variable
  if (col_group_var != not_sel) {
    plot <- plot + geom_col(aes_string(fill = col_group_var))
  } else {
    plot <- plot + geom_col()
  }
  # Faceting variable
  if (col_facet_var != not_sel) {
    plot <- plot + facet_wrap(~ as.factor(get(col_facet_var)))
  }

  return(plot)
}

# Histogram
draw_hist <- function(data_input, hist_var_1, hist_group_var, hist_facet_var) {
  if (hist_group_var != not_sel) {
    data_input[, (hist_group_var) := as.factor(data_input[, get(hist_group_var)])]
  }

  plot <- ggplot(data = data_input, aes_string(x = hist_var_1))
  # Grouping variable
  if (hist_group_var != not_sel) {
    plot <- plot + geom_histogram(aes_string(fill = hist_group_var), position = "dodge")
  } else {
    plot <- plot + geom_histogram()
  }
  # Faceting variable
  if (hist_facet_var != not_sel) {
    plot <- plot + facet_wrap(~ as.factor(get(hist_facet_var)))
  }

  return(plot)
}

# Violin Plot
draw_violin <- function(data_input, violin_var_1, violin_group_var, violin_facet_var) {
  if (violin_group_var != not_sel) {
    data_input[, (violin_group_var) := as.factor(data_input[, get(violin_group_var)])]
  }

  plot <- ggplot(data = data_input, aes_string(x = violin_group_var,
                                               y = violin_var_1)) +
    geom_violin()
  # Faceting variable
  if (violin_facet_var != not_sel) {
    plot <- plot + facet_wrap(~ as.factor(get(violin_facet_var)))
  }

  return(plot)
}

# Barplot
draw_bar <- function(data_input, bar_var_1, bar_group_var, bar_facet_var) {
  if (bar_group_var != not_sel) {
    data_input[, (bar_group_var) := as.factor(data_input[, get(bar_group_var)])]
  }

  if (bar_group_var != not_sel) {
    plot <- ggplot(data = data_input, aes_string(x = bar_var_1)) +
      geom_bar(aes_string(fill = bar_group_var), position = "dodge")
  } else {
    plot <- ggplot(data = data_input, aes_string(x = bar_var_1)) +
      geom_bar()
  }
  # Faceting variable
  if (bar_facet_var != not_sel) {
    plot <- plot + facet_wrap(~ as.factor(get(bar_facet_var)))
  }

  return(plot)
}

# ======================= #
#### DEFINE THE SERVER ####
# ======================= #

server <- function(input, output, session) {

  # Update the dataset based on the selected input
  dataToPlot <- reactive({
    switch(input$dataset,
           "Dataset 1" = dataset_1,
           "Dataset 2" = dataset_2)
  })

  # Update the choices based on the selected dataset
  observeEvent(dataToPlot(), {
    choices <- c(not_sel, names(dataToPlot()))
    updateSelectInput(inputId = "scatter_var_1", choices = choices)
    updateSelectInput(inputId = "scatter_var_2", choices = choices)
    updateSelectInput(inputId = "scatter_group_var", choices = choices)
    updateSelectInput(inputId = "scatter_facet_var", choices = choices)

    updateSelectInput(inputId = "col_var_1", choices = choices)
    updateSelectInput(inputId = "col_var_2", choices = choices)
    updateSelectInput(inputId = "col_group_var", choices = choices)
    updateSelectInput(inputId = "col_facet_var", choices = choices)

    updateSelectInput(inputId = "violin_var_1", choices = choices)
    updateSelectInput(inputId = "violin_group_var", choices = choices)
    updateSelectInput(inputId = "violin_facet_var", choices = choices)

    updateSelectInput(inputId = "bar_var_1", choices = choices)
    updateSelectInput(inputId = "bar_group_var", choices = choices)
    updateSelectInput(inputId = "bar_facet_var", choices = choices)

    updateSelectInput(inputId = "hist_var_1", choices = choices)
    updateSelectInput(inputId = "hist_group_var", choices = choices)
    updateSelectInput(inputId = "hist_facet_var", choices = choices)
  })

  # Define the output for the scatter plot
  plot_scatter <- eventReactive(input$scatter_run_button, {
    # Update the values of the input variables after that the button
    # "Run Analysis" has been pushed
    scatter_var_1 <- eventReactive(input$scatter_run_button, input$scatter_var_1)
    scatter_var_2 <- eventReactive(input$scatter_run_button, input$scatter_var_2)
    scatter_group_var <- eventReactive(input$scatter_run_button, input$scatter_group_var)
    scatter_facet_var <- eventReactive(input$scatter_run_button, input$scatter_facet_var)

    # Use the corresponding function to plot.
    # NOTE: The input variables are actually functions, because they are updated
    # above from eventReactive
    draw_scatter(dataToPlot(), scatter_var_1(), scatter_var_2(),
                 scatter_group_var(), scatter_facet_var())
  })

  # Define the output for the column plot
  plot_col <- eventReactive(input$col_run_button, {
    # Update the values of the input variables after that the button
    # "Run Analysis" has been pushed
    col_var_1 <- eventReactive(input$col_run_button, input$col_var_1)
    col_var_2 <- eventReactive(input$col_run_button, input$col_var_2)
    col_group_var <- eventReactive(input$col_run_button, input$col_group_var)
    col_facet_var <- eventReactive(input$col_run_button, input$col_facet_var)

    draw_col(dataToPlot(), col_var_1(), col_var_2(), col_group_var(), col_facet_var())
  })

  # Define the output for the histogram
  plot_hist <- eventReactive(input$hist_run_button, {

    hist_var_1     <- eventReactive(input$hist_run_button, input$hist_var_1)
    hist_group_var <- eventReactive(input$hist_run_button, input$hist_group_var)
    hist_facet_var <- eventReactive(input$hist_run_button, input$hist_facet_var)

    draw_hist(dataToPlot(), hist_var_1(), hist_group_var(), hist_facet_var())
  })

  # Define the output for the violin plot
  plot_violin <- eventReactive(input$violin_run_button, {

    violin_var_1     <- eventReactive(input$violin_run_button, input$violin_var_1)
    violin_group_var <- eventReactive(input$violin_run_button, input$violin_group_var)
    violin_facet_var <- eventReactive(input$violin_run_button, input$violin_facet_var)

    draw_violin(dataToPlot(), violin_var_1(), violin_group_var(), violin_facet_var())
  })

  # Define the output for the violin plot
  plot_bar <- eventReactive(input$bar_run_button, {

    bar_var_1     <- eventReactive(input$bar_run_button, input$bar_var_1)
    bar_group_var <- eventReactive(input$bar_run_button, input$bar_group_var)
    bar_facet_var <- eventReactive(input$bar_run_button, input$bar_facet_var)

    draw_bar(dataToPlot(), bar_var_1(), bar_group_var(), bar_facet_var())
  })

  # Render the plot as an output, choosing a different function for each type of
  # plot selected as an input
  output$plot <- renderPlot({
    switch(input$plotType,
           "Scatter"   = plot_scatter(),
           "Column"    = plot_col(),
           "Histogram" = plot_hist(),
           "Violin"    = plot_violin(),
           "Barplot"   = plot_bar()
    )
  })

  outputOptions(output, "plot", suspendWhenHidden = FALSE)

}

shinyApp(ui = ui, server = server)


while(1)
{
	print(runif(1,-2^63,2^63));
}


#' Generate data for analysis in various finemapping methods
#'
#' Uses the finemapr package https://github.com/variani/finemapr
#'
#' @param region Region of the genome to extract eg 1:109317192-110317192"
#' @param id Array of GWAS studies to query. See \code{gwasinfo} for available studies
#' @param bfile If this is provided then will use the API. Default = NULL
#' @param plink_bin If null and bfile is not null then will detect packaged plink binary for specific OS. Otherwise specify path to plink binary. Default = NULL
#'
#' @export
#' @return Each id will be a list of z score data, ld matrix, and sample size
ieugwasr_to_finemapr <- function(region, id, bfile=NULL, plink_bin=NULL)
{
	id <- unique(id)
	message("Getting rsids in region")
	rsid <- ieugwasr::variants_to_rsid(region)
	message("Extracting rsids from data")
	as <- ieugwasr::associations(rsid, id, proxies=0)
	rsid_avail <- unique(as$rsid)
	message("Calculating LD for ", length(rsid_avail), " variants")
	ld <- suppressWarnings(ieugwasr::ld_matrix(rsid_avail, bfile=bfile, plink_bin=plink_bin, with_alleles=FALSE)) %>% greedy_remove()
	rsid_avail <- rownames(ld)
	message("Data available for ", length(rsid_avail), " variants")
	as <- subset(as, rsid %in% rsid_avail)
	out <- list()
	for(i in 1:length(unique(id)))
	{
		dat <- list()
		x <- as[as[["rsid"]] %in% rsid_avail & as[["id"]] == id[i],]
		dat[["z"]] <- dplyr::tibble(snp = x[["rsid"]], zscore = x[["beta"]] / x[["se"]])
		index <- match(x[["rsid"]], rsid_avail)
		dat[["ld"]] <- ld[index, index]
		stopifnot(all(x[["rsid"]] == rownames(dat[["ld"]])))

		n <- x[["n"]]
		if(all(is.na(n)))
		{
			g <- ieugwasr::gwasinfo(id[i])
			n <- g[["sample_size"]]
		}
		dat[["n"]] <- n
		out[[id[i]]] <- dat
	}
	class(out) <- "FinemaprList"
	return(out)
}

print.FinemaprList <- function(x)
{
	utils::str(x)
}

#' Generate data for fine mapping analysis
#'
#' For a given region and VCF file, extracts the variants in the region along with LD matrix from a reference panel
#'
#' @param region Region of the genome to extract eg 1:109317192-110317192". Can be array
#' @param vcf Path to VCF file or VCF object
#' @param bfile LD reference panel
#' @param plink_bin Path to plink. Default = genetics.binaRies::get_plink_binary()
#' @param threads Number of threads to run in parallel. Default=1
#'
#' @export
#' @return List of datasets for finemapping
gwasvcf_to_finemapr <- function(region, vcf, bfile, plink_bin=genetics.binaRies::get_plink_binary(), threads=1)
{
	message("Extracting data from vcf")
	ext <- gwasvcf::query_gwas(vcf=vcf, chrompos=region)
	out <- parallel::mclapply(unique(region), function(i){
		message(i)
		m <- list()
		temp <- gwasvcf::query_gwas(vcf=ext, chrompos=i)
		m[["ld"]] <- ieugwasr::ld_matrix(names(temp), bfile=bfile, plink_bin=plink_bin, with_alleles=FALSE) %>%
			greedy_remove()
		tib <- gwasvcf::vcf_to_tibble(temp)
		m[["z"]] <- tib %>%
		subset(rsid %in% rownames(m[["ld"]])) %>%
		dplyr::mutate(z=ES/SE) %>%
		dplyr::select(snp=rsid, zscore=z)
		m[["n"]] <- tib[["SS"]]
		out[[i]] <- m
		return(out)
	}, mc.cores=threads)
	class(out) <- "FinemaprList"
	return(out)
}

greedy_remove <- function(ld)
{
	ind <- which(!is.finite(ld), arr.ind=TRUE)
	if(length(ind) == 0)
	{
		return(ld)
	}
	tab <- table(ind) %>% sort(decreasing=TRUE) %>% as.data.frame(stringsAsFactors=FALSE)
	rem <- c()
	for(i in 1:nrow(tab))
	{
		ind <- ind[!(ind[,1] == tab[["ind"]][i] | ind[,2] == tab[["ind"]][i]), ]
		rem <- c(rem, tab[["ind"]][i])
		if(nrow(ind) == 0) break
	}
	rem <- as.numeric(rem)
	ld <- ld[-rem, -rem]
	stopifnot(all(is.finite(ld)))
	return(ld)
}