library(tidyverse)
library(data.table)
library(scales)
library(ggforce)
library(htmltab)
library(gganimate)
library(extrafont)
library(ggrepel)
library(gridExtra)
library(packcircles)
library(cowplot)

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

setwd("~/Public_Policy_Upd/Projects/COVID-19 Mismanagement/output")

##### get comparative flu stats #####
flu_links = c('https://www.cdc.gov/flu/about/burden/2019-2020.html',
              'https://www.cdc.gov/flu/about/burden/2018-2019.html', 'https://www.cdc.gov/flu/about/burden/2017-2018.htm',
              'https://www.cdc.gov/flu/about/burden/2016-2017.html', 'https://www.cdc.gov/flu/about/burden/2015-2016.html',
              'https://www.cdc.gov/flu/about/burden/2014-2015.html', 'https://www.cdc.gov/flu/about/burden/2013-2014.html',
              'https://www.cdc.gov/flu/about/burden/2012-2013.html', 'https://www.cdc.gov/flu/about/burden/2011-2012.html',
              'https://www.cdc.gov/flu/about/burden/2010-2011.html')

flu_burden_tables = lapply(flu_links, function(the_link){
  the_season = str_extract(the_link, '[0-9]{4}-[0-9]{4}')
  the_df = htmltab(the_link) %>%
    mutate(
      season = the_season
    )
  names(the_df) = c('age_group', 'syptomatic_illnesses', 'syptomatic_illnesses_ci',
                    'medical_visits', 'medical_visits_ci', 'hosptitalizations', 'hosptitalizations_ci',
                    'deaths', 'deaths_ci', 'season')
  the_df
}) %>%
  bind_rows() %>%
  mutate(
    deaths = str_remove(deaths, ',') %>% as.numeric()
  )

##### get JH data #####

johns_hopkins_deaths = read_csv('https://raw.githubusercontent.com/CSSEGISandData/COVID-19/master/csse_covid_19_data/csse_covid_19_time_series/time_series_covid19_deaths_global.csv') %>%
  pivot_longer(cols = matches('^([0-9])'), names_to = 'date', values_to = 'deaths') %>%
  mutate(
    date_upd = as.Date(date, format = '%m/%d/%y')
  ) %>%
  select(-date) %>%
  rename(
    date = date_upd,
    country = `Country/Region`
  ) %>%
  filter(country == 'US') %>%
  arrange(date) %>%
  mutate(
    new_deaths = deaths - lag(deaths, 1)
  )

##### create circle plots #####

flu_season_total_deaths = filter(flu_burden_tables, age_group == 'All ages') %>% select(age_group, season, deaths) %>% mutate(illness = 'Influenza') %>%
  head(9)

covid_deaths = filter(johns_hopkins_deaths, date == as.Date('2020-12-31')) %>% mutate(illness = 'COVID-19', season = '2020')
stacked_flu_covid_total_deaths = bind_rows(covid_deaths, flu_season_total_deaths) %>% select(season, illness, deaths) %>% mutate(id = 1:length(deaths))

packing <- circleProgressiveLayout(stacked_flu_covid_total_deaths, sizecol = 'deaths') %>% bind_cols(stacked_flu_covid_total_deaths)
# dat.gg <- circleLayoutVertices(packing) %>% left_join(stacked_flu_covid_total_deaths)

ggplot(data = packing) +
geom_circle(aes(x0 = x, y0 = y, r = radius, fill = illness), colour = 'black') +
    # geom_polygon(aes(x, y, group = id, fill = illness),
  #              colour = "black",
  #              show.legend = T) +
  theme_minimal() +
  theme(
    text = element_text(family = font_family),
    legend.position = 'bottom',
    legend.text = element_text(size = 16),
    axis.text = element_blank(),
    axis.title = element_blank(),
    panel.grid = element_blank(),
    plot.title = element_text(size = 28),
    plot.subtitle = element_text(size = 15, face = 'italic'),
    plot.caption = element_text(size = 13, face = 'italic', hjust = 0)
    # plot.margin = unit(c(1.5, 0, 1.5, 0), 'cm')
  ) +
  labs(
    x = '\n\n',
    title = 'COVID-19 vs. Influenza Mortality in the U.S.',
    caption = 'Chart: Taylor G. White (@t_g_white)\nData: CDC Flu Disease Burden, Johns Hopkins CSSE',
    subtitle = sprintf('COVID-19 killed more Americans in one year (%s) than did the flu over the last nine seasons (%s).',
                       covid_deaths$deaths %>% comma(), sum(flu_season_total_deaths$deaths) %>% comma()) %>%
      str_wrap(110)
  ) +
  geom_text(data = packing, aes(x, y, label = paste0(season %>% str_extract('[0-9]{4}'), ':\n',comma(deaths)), size = radius), family = font_family) +
  scale_size(range = c(3, 8), guide = F) +
  scale_fill_manual(name = '', values = c('COVID-19' = 'orange', 'Influenza' = 'steelblue')) +
  coord_equal()
ggsave('deaths_by_influenza_covid.png', height = 10, width = 10, units = 'in', dpi = 600)

##### get ssa life table data #####
ssa_life_table = htmltab('https://www.ssa.gov/oact/STATS/table4c6.html')
names(ssa_life_table) = c('age', 'male_death_probability', 'males_alive', 'male_life_expectancy',
                          'female_death_probability', 'females_alive', 'female_life_expectancy')

ssa_life_table =
  mutate_all(ssa_life_table,
             function(.){
               str_remove_all(., '[,\\+]') %>%
                 as.numeric()
             }) %>%
  filter(!is.na(age)) %>%
  mutate(
    male_expected_age = age + male_life_expectancy,
    female_expected_age = age + female_life_expectancy,
    row_total_denom = males_alive + females_alive,
    prop_alive = row_total_denom / max(row_total_denom, na.rm = T),
    overall_life_expectancy = (males_alive / row_total_denom) * male_life_expectancy + (females_alive / row_total_denom) * female_life_expectancy,
    overall_expected_age = age + overall_life_expectancy
  )

selected_expectancies = filter(ssa_life_table, age %in% c(0, 65, 75, 85)) %>% select(age, overall_life_expectancy, overall_expected_age) %>%
  mutate(
    label = sprintf('Life Exp. at %s:\n%s Years', ifelse(age == 0, 'Birth', age), round(overall_life_expectancy))
  )
selected_expectancies_vec = selected_expectancies$overall_life_expectancy
names(selected_expectancies_vec) = selected_expectancies$age

life_table_plot_dat =
ssa_life_table %>%
  mutate(
    age_x = age
  ) %>%
  pivot_longer(cols = c('age', 'overall_life_expectancy')) %>%
  mutate(
    name_factor = factor(name, levels = c('age', 'overall_life_expectancy') %>% rev()),
    bar_labels = ifelse(name == 'overall_life_expectancy' & age_x %in% selected_expectancies$age,
                        paste('Life Expectancy of', selected_expectancies_vec[as.character(age_x)] %>% round(), 'Years at Age', age_x), NA)
  )

ggplot(life_table_plot_dat, aes(age_x, value)) +
  theme_bw() +
  theme(
    legend.position = 'bottom',
    text = element_text(family = font_family),
    axis.title = element_text(size = 15),
    legend.text = element_text(size = 14),
    panel.grid.major.x = element_blank(),
    axis.text = element_text(size = 14),
    plot.title = element_text(size = 26),
    plot.subtitle = element_text(size = 15, face = 'italic'),
    plot.caption = element_text(size = 11, hjust = 0, face = 'italic'),
    strip.background = element_rect(fill = 'black'),
    strip.text = element_text(colour = 'white', face = 'bold', size = 16)
  ) +
  scale_alpha(range = c(0.3, 1), guide = F) +
  scale_y_continuous(breaks = seq(0, 120, by = 10)) +
  scale_x_continuous(breaks = seq(0, 120, by = 10)) +
  labs(
    x = '', y = 'Life Expectancy',
    title = 'U.S. Life Expectancy by Age',
    caption = 'Chart: Taylor G. White (@t_g_white)\nData: Social Security Administration Life Tables',
    subtitle = 'Bars are shaded according to the probability of reaching that age. While life expectancy is 78 years at birth, the expected age someone will reach increases given that they already survived to old age.' %>%
      str_wrap(130)
  ) +
  geom_label_repel(data = selected_expectancies, aes(x = age, y = overall_expected_age, label = label), nudge_y = 20) +
  # annotate('text', x = 65, y = 120, label = sprintf('Life Expectancy of %s Years at 65', round(selected_expectancies_vec['65']))) +
  # geom_segment(data = selected_expectancies, aes(x = age, xend = age, y = 120, yend = overall_expected_age)) +
  geom_bar(aes(alpha = prop_alive, fill = name_factor), stat = 'identity') +
  geom_hline(aes(yintercept = filter(selected_expectancies, age == 0)$overall_life_expectancy),  colour = 'black', linetype = 'dashed') +
  # geom_text(aes(label = bar_labels), size = 3, position = position_stack(vjust = 0.5), angle = 90, family = font_family, hjust = 0.25) +
  scale_fill_manual(name = '', labels = c('age' = 'Current Age', 'overall_life_expectancy' = 'Years Remaining'), values = c('age' = 'steelblue', 'overall_life_expectancy' = 'orange'))
ggsave('life_expectancy_by_age.png', height = 9, width = 12, units = 'in', dpi = 600)

##### get covid deaths by age and week #####
# https://www.cdc.gov/nchs/nvss/vsrr/covid19/excess_deaths.htm

covid_deaths_by_age_week = read_csv('https://data.cdc.gov/resource/vsak-wrfu.csv') %>%
  mutate(
    week_end = as.Date(week_ending_date),
    as_of_date = as.Date(data_as_of)
  )

total_covid_deaths_by_week = filter(covid_deaths_by_age_week, age_group != 'All Ages') %>% group_by(week_end) %>%
  summarize(
    sum_all_cause_deaths = sum(total_deaths, na.rm = T),
    all_covid_deaths = sum(covid_19_deaths, na.rm = T)
  )
ggplot(total_covid_deaths_by_week, aes(week_end, all_covid_deaths)) + geom_line()

age_midpoint_85p = filter(ssa_life_table, age >= 85)$age %>% mean()

age_groups_df = tibble(
  age_group = unique(covid_deaths_by_age_week$age_group),
) %>%
  filter(age_group != 'All Ages') %>%
  mutate(
    age_group_start = str_extract(age_group, '[0-9]{1,2}') %>% as.numeric(),
    age_group_end = str_extract(age_group, '-[0-9]{1,2}') %>% str_remove('-') %>% as.numeric(),
    age_group_midpoint = (age_group_end + age_group_start) / 2,
    age_group_midpoint = ifelse(is.na(age_group_end) & age_group_start == 1, 0, age_group_midpoint),
    age_group_midpoint = ifelse(is.na(age_group_end) & age_group_start == 85, age_midpoint_85p, age_group_midpoint),
    age_group_end = ifelse(age_group_start == 85 & is.na(age_group_end), max(ssa_life_table$age), age_group_end),
    age_group_end = ifelse(age_group_start == 1 & is.na(age_group_end), 0, age_group_end),
    age_group_start = ifelse(age_group_start == 1 & age_group_end == 0, 0, age_group_start),
  )

# covid_deaths_by_age_week %>%
#   inner_join(age_groups_df %>%
#                mutate(age_group_factor = factor(age_group, levels = age_group))) %>%
#   left_join(total_covid_deaths_by_week) %>%
# ggplot(aes(week_end, covid_19_deaths/all_covid_deaths, colour = age_group_factor)) +
#   geom_line() +
#   scale_colour_viridis_d()

for (it in 1:nrow(age_groups_df)) {
  # it = 11
  the_row = age_groups_df[it,]
  ssa_sub = filter(ssa_life_table, between(age, the_row$age_group_start, the_row$age_group_end)) %>%
    filter(
      row_total_denom > 0
    )

  overall_total_denom = sum(ssa_sub$row_total_denom)
  group_avg_expectancy = sum(
    (ssa_sub$row_total_denom / overall_total_denom) * ssa_sub$overall_life_expectancy
  )
  age_groups_df[it,'group_avg_expectancy'] = group_avg_expectancy
  # get rowwise weighted means and then get columnwise weighted means

}

total_deaths_by_age_group = group_by(covid_deaths_by_age_week, age_group) %>%
  summarize(
    total_deaths = sum(covid_19_deaths)
  ) %>%
  inner_join(
    age_groups_df
  ) %>%
  arrange(age_group_start) %>%
  mutate(
    age_group_pretty = age_group %>% str_replace("85 years and over", ">85") %>% str_replace("Under 1 year", "<1") %>% str_remove(' years'),
    age_group_factor = factor(age_group_pretty, levels = age_group_pretty),
    person_years_lost = total_deaths * group_avg_expectancy
  )

long_dat =   total_deaths_by_age_group %>% pivot_longer(cols = c('total_deaths', 'person_years_lost')) %>%
  mutate(
    name = factor(name, levels = c('total_deaths', 'person_years_lost')),
    desc = str_replace_all(name, '_', ' ') %>% str_to_title()
  )

labels_df = group_by(long_dat, name, desc) %>%
  summarize(
    max_val = max(value, na.rm = T),
    age_group_factor = levels(age_group_factor)[1],
    total_val = sum(value, na.rm = T)
  ) %>%
  arrange(
    total_val
  ) %>%
  mutate(
    num_label = sprintf(paste(desc, '(%s)'), comma(total_val)),
    num_label = factor(num_label, levels = num_label)
  )

long_dat = left_join(long_dat, labels_df %>% select(name, num_label), by = c('name'))

years_lost_anim = ggplot(long_dat, aes()) +
  transition_states(
    name,
    transition_length = 2,
    state_length = 5
  ) +
  labs(
    x = '', y = '',
    title = 'Comparing U.S. COVID Mortality and Person-Years Lost by Age Group',
    caption = sprintf('Chart: Taylor G. White (@t_g_white)\nData: CDC COVID Data (as of %s), SSA Life Tables', covid_deaths_by_age_week$as_of_date[1] %>% format('%b %d, %Y')),
    subtitle = sprintf('If someone was expected to live another 10 years based on their age but died early due to COVID, they lost 10 person-years. On average, someone in the 65-74 age group is expected to live another 16 years.') %>% str_wrap(120)
  ) +
  theme_bw() +
  theme(
    text = element_text(family = font_family),
    axis.text.x = element_text(),
    panel.grid.major.x = element_blank(),
    axis.text = element_text(size = 14),
    plot.title = element_text(size = 26),
    plot.subtitle = element_text(size = 15, face = 'italic'),
    plot.caption = element_text(size = 11, hjust = 0, face = 'italic')
  ) +
  # enter_fade() +
  # exit_shrink() +
  # ease_aes('sine-in-out') +
  geom_bar(aes(age_group_factor, value), stat = 'identity', fill = 'steelblue') +
  geom_text(aes(x = age_group_factor, y = value, label = comma(value)), family = font_family, size = 3, vjust = -1) +
  geom_text(data = labels_df, aes(x = age_group_factor, y = max_val, label = desc, group = name), family = font_family, size = 6) +
  # shadow_mark(past = TRUE, future = TRUE, colour = 'grey') +
  scale_y_continuous(labels = comma) +
  # view_step(pause_length = 3, step_length = 2, nsteps = 2, ease = 'linear')
  view_zoom(pause_length = 25, step_length = 8, nsteps = 2, ease = 'sine-in-out')

# animate(years_lost_anim,
#          renderer = gifski_renderer("deaths_years_lost.gif"),
#         nframes = 100,
#          height = 9, width = 12, units = 'in',  type = 'cairo-png', res = 150)

ggplot(long_dat, aes(age_group_factor, value)) +
  facet_wrap(~num_label, scales = 'free_y', ncol = 1) +
  labs(
    x = '', y = '',
    title = 'Comparing U.S. COVID Mortality and Person-Years Lost by Age Group',
    caption = sprintf('Chart: Taylor G. White (@t_g_white)\nData: CDC COVID Data (as of %s), SSA Life Tables', covid_deaths_by_age_week$as_of_date[1] %>% format('%b %d, %Y')),
    subtitle = sprintf('If someone was expected to live another 10 years based on their age but died early due to COVID, they lost 10 person-years. On average, someone in the 65-74 age group is expected to live another 16 years.') %>% str_wrap(120)
  ) +
  theme_bw() +
  theme(
    text = element_text(family = font_family),
    axis.text.x = element_text(),
    panel.grid.major.x = element_blank(),
    axis.text = element_text(size = 14),
    plot.title = element_text(size = 26),
    plot.subtitle = element_text(size = 15, face = 'italic'),
    plot.caption = element_text(size = 11, hjust = 0, face = 'italic'),
    strip.background = element_rect(fill = 'black'),
    strip.text = element_text(colour = 'white', face = 'bold', size = 16)
  ) +
  geom_bar(aes(), stat = 'identity', fill = 'firebrick', width = 0.75) +
  geom_text(aes(x = age_group_factor, y = value, label = comma(value)), family = font_family, size = 4, vjust = -1) +
  scale_y_continuous(labels = comma)
ggsave('total_deaths_years_lost_age_group.png', height = 14, width = 12, units = 'in', dpi = 600)
shell('explorer .')

##### deaths by age group #####
flu_stats_by_age_group = group_by(flu_burden_tables, age_group) %>%
  summarize(
    `Total Flu Deaths\nLast 9 Seasons` = sum(deaths, na.rm = T) %>% comma(),
    `Avg. Flu Deaths\nPer Season` = mean(deaths, na.rm = T) %>% comma()
  ) %>%
  mutate(
    `Age Group` = factor(age_group, levels = c('0-4 yrs', '5-17 yrs', '18-49 yrs','50-64 yrs', '65+ yrs', 'All ages'))
  ) %>%
  arrange(`Age Group`) %>%
  select(`Age Group`, `Total Flu Deaths\nLast 9 Seasons`, `Avg. Flu Deaths\nPer Season`)

flu_stats_by_age_group_pretty = select(flu_stats_by_age_group, contains('Flu')) %>% as.data.frame()
row.names(flu_stats_by_age_group_pretty) = flu_stats_by_age_group$`Age Group`

tt2 = ttheme_default(
  core=list(bg_params = list(fill = c('white', 'lightgray')))
)

deaths_55_64 = filter(total_deaths_by_age_group, between(age_group_start, 55, 64)) %>% pull(total_deaths) %>% sum()
deaths_65plus = filter(total_deaths_by_age_group, age_group_start >= 65) %>% pull(total_deaths) %>% sum()
total_covid_cdc = sum(total_deaths_by_age_group$total_deaths) %>% comma()

ggplot(total_deaths_by_age_group, aes(age_group_factor, total_deaths)) +
  labs(
    x = '', y = '',
    title = 'COVID vs. Flu Mortality in the U.S., by Age Group',
    caption = sprintf('Chart: Taylor G. White (@t_g_white)\nData: CDC COVID Data (as of %s)', covid_deaths_by_age_week$as_of_date[1] %>% format('%b %d, %Y'))
  ) +
  theme_bw() +
  annotation_custom(tableGrob(flu_stats_by_age_group_pretty, theme=tt2),
                    xmin = levels(total_deaths_by_age_group$age_group_factor)[1], xmax = levels(total_deaths_by_age_group$age_group_factor)[4],
                    ymin = 75e3, ymax = 100e3
  )  +
  theme(
    text = element_text(family = font_family),
    axis.text.x = element_text(),
    panel.grid.major.x = element_blank(),
    axis.text = element_text(size = 14),
    plot.title = element_text(size = 26),
    plot.subtitle = element_text(size = 15, face = 'italic'),
    plot.caption = element_text(size = 11, hjust = 0, face = 'italic'),
    strip.background = element_rect(fill = 'black'),
    strip.text = element_text(colour = 'white', face = 'bold', size = 16)
  ) +
  geom_bar(aes(), stat = 'identity', fill = 'firebrick', width = 0.75) +
  geom_text(aes(x = age_group_factor, y = total_deaths, label = comma(total_deaths)), family = font_family, size = 4, vjust = -1) +
  scale_y_continuous(labels = comma)
ggsave('covid_flu_mortality_by_age.png', height = 9, width = 12, units = 'in', dpi = 600)

ggplot(total_deaths_by_age_group, aes(age_group_factor, total_deaths)) +
  labs(
    x = '', y = 'Total Deaths',
    title = 'U.S. COVID Mortality by Age Group',
    caption = sprintf('Chart: Taylor G. White (@t_g_white)\nData: CDC COVID Data (as of %s)', covid_deaths_by_age_week$as_of_date[1] %>% format('%b %d, %Y'))
  ) +
  theme_bw() +
  # annotation_custom(tableGrob(flu_stats_by_age_group_pretty, theme=tt2),
  #                   xmin = levels(total_deaths_by_age_group$age_group_factor)[1], xmax = levels(total_deaths_by_age_group$age_group_factor)[4],
  #                   ymin = 75e3, ymax = 100e3
  #                   )  +
  theme(
    text = element_text(family = font_family),
    axis.text.x = element_text(),
    panel.grid.major.x = element_blank(),
    axis.text = element_text(size = 14),
    plot.title = element_text(size = 26),
    plot.subtitle = element_text(size = 15, face = 'italic'),
    plot.caption = element_text(size = 11, hjust = 0, face = 'italic'),
    strip.background = element_rect(fill = 'black'),
    strip.text = element_text(colour = 'white', face = 'bold', size = 16)
  ) +
  geom_bar(aes(), stat = 'identity', fill = 'firebrick', width = 0.75) +
  geom_text(aes(x = age_group_factor, y = total_deaths, label = comma(total_deaths)), family = font_family, size = 4, vjust = -1) +
  scale_y_continuous(labels = comma)
ggsave('covid_mortality_by_age.png', height = 9, width = 12, units = 'in', dpi = 600)

filter(total_deaths_by_age_group, age_group_start  <= 64) %>% pull(total_deaths ) %>% sum()

ggplot(total_deaths_by_age_group, aes(age_group_factor, person_years_lost)) +
  labs(
    x = '', y = 'Person-Years Lost',
    title = 'Life Lost to COVID in the U.S. by Age Group',
    caption = sprintf('Chart: Taylor G. White (@t_g_white)\nData: CDC COVID Data (as of %s), SSA Life Tables', covid_deaths_by_age_week$as_of_date[1] %>% format('%b %d, %Y'))
  ) +
  theme_bw() +
  # annotation_custom(tableGrob(flu_stats_by_age_group_pretty, theme=tt2),
  #                   xmin = levels(total_deaths_by_age_group$age_group_factor)[1], xmax = levels(total_deaths_by_age_group$age_group_factor)[4],
  #                   ymin = 75e3, ymax = 100e3
  #                   )  +
  theme(
    text = element_text(family = font_family),
    axis.text.x = element_text(),
    panel.grid.major.x = element_blank(),
    axis.text = element_text(size = 14),
    plot.title = element_text(size = 26),
    plot.subtitle = element_text(size = 15, face = 'italic'),
    plot.caption = element_text(size = 11, hjust = 0, face = 'italic'),
    strip.background = element_rect(fill = 'black'),
    strip.text = element_text(colour = 'white', face = 'bold', size = 16)
  ) +
  geom_bar(aes(), stat = 'identity', fill = 'firebrick', width = 0.75) +
  geom_text(aes(x = age_group_factor, y = person_years_lost, label = comma(person_years_lost)), family = font_family, size = 4, vjust = -1) +
  scale_y_continuous(labels = comma)
ggsave('covid_life_lost_age_group.png', height = 9, width = 12, units = 'in', dpi = 600)

##### analyze covid excess deaths #####

us_excess_death_data = read_csv('https://data.cdc.gov/api/views/xkkf-xrst/rows.csv?accessType=DOWNLOAD&bom=true&format=true%20target') %>%
  mutate(
    weeknum = week(`Week Ending Date`)
  ) %>%
  arrange(`Week Ending Date`, Type, Outcome) %>%
  filter(State == 'United States', Year < 2020 | (Year == 2020 & weeknum <= 50)) %>%
  mutate(
    label = ifelse(Year < 2020 & weeknum == 53, Year, ifelse(Year == 2020 & weeknum == 50, Year, NA))
  )

names(us_excess_death_data) = str_to_lower(names(us_excess_death_data)) %>% str_replace_all(' ', '_')

us_excess_death_data = mutate(us_excess_death_data,
                              excess_deaths_over_threshold = pmax(0, observed_number - upper_bound_threshold),
                              excess_over_average = pmax(0, observed_number - average_expected_count),
                              average_expected_ribbon_min = ifelse(average_expected_count > observed_number, observed_number, average_expected_count)
                              )
johns_hopkins_deaths_weekly = mutate(johns_hopkins_deaths, weeknum = week(date), year = year(date)) %>%
  group_by(year, weeknum) %>%
  summarize(
    weekly_deaths = sum(new_deaths, na.rm = T)
  )

stats_by_year = group_by(us_excess_death_data, year, type, outcome) %>%
  summarize(
    excess_higher_estimate = sum(excess_higher_estimate, na.rm = T),
    excess_lower_estimate = sum(excess_lower_estimate, na.rm = T),
    last_weeknum = max(weeknum, na.rm = T),
    last_observed_number = tail(observed_number, 1),
   tot_excess_deaths_over_threshold = sum(excess_deaths_over_threshold, na.rm = T),
   tot_excess_over_average = sum(excess_over_average, na.rm = T)
  )

type_to_use = 'Predicted (weighted)'

johns_hopkins_deaths_with_excess = inner_join(
  us_excess_death_data %>% filter(outcome == 'All causes', type == type_to_use),
  johns_hopkins_deaths_weekly
)

excess_2020 = filter(stats_by_year, type == type_to_use, outcome == 'All causes', year == 2020) %>% pull(tot_excess_over_average)

selected_excess_death_data = filter(us_excess_death_data, outcome == 'All causes', type == type_to_use)

full_excess_deaths_plot = ggplot(selected_excess_death_data, aes(weeknum, observed_number, colour = year < 2020)) +

  theme_bw() +
  theme(
    text = element_text(family = font_family),
    axis.text.x = element_text(),
    panel.grid.major.x = element_blank(),
    axis.text = element_text(size = 14),
    plot.title = element_text(size = 26),
    plot.subtitle = element_text(size = 14.5, face = 'italic'),
    plot.caption = element_text(size = 11, hjust = 0, face = 'italic'),
    strip.background = element_rect(fill = 'black'),
    strip.text = element_text(colour = 'white', face = 'bold', size = 16)
  ) +
  labs(
    x = 'Week of the Year',
    y = 'Total Deaths (All Causes, Weighted)',
    title = 'All Cause Mortality in the U.S., 2017-2020',
    subtitle = sprintf("There were %s deaths above average (excess deaths) in 2020, which is %s greater than the Johns Hopkins COVID death count.", comma(excess_2020), percent(excess_2020 / covid_deaths$deaths - 1)),
    caption = 'Chart: Taylor G. White (@t_g_white)\nData: CDC -- 2020 data is through week 50 due to reporting lags.'
  ) +
  # geom_line(data = johns_hopkins_deaths_with_excess, aes(y = weekly_deaths + average_expected_ribbon_min), colour = 'black', linetype = 'dashed') +
  geom_label_repel(data = data.frame(x = 30, y = 57e3, label = 'Shaded region shows excess mortality for 2020'), aes(x, y, label = label, colour = NULL), nudge_y = 20e3, family = font_family) +
  geom_ribbon(data = filter(selected_excess_death_data, year == 2020), aes(x = weeknum, ymin = average_expected_ribbon_min, ymax = observed_number), fill = 'red', alpha = 0.25, size = 0, colour = NA) +
  scale_x_continuous(breaks = seq(0, 50, by = 10)) +
    scale_y_continuous(labels = comma) +
  scale_colour_manual(guide = F, values = c('FALSE' = 'red', 'TRUE' = 'steelblue')) +
  # geom_line(aes(y = average_expected_count)) +
  geom_line(aes(group = year), size = 0.75) +
  geom_label_repel(data = stats_by_year %>% filter(outcome == 'All causes', type == type_to_use),
                   aes(last_weeknum, last_observed_number, label = year), nudge_x = 0.75, segment.color = 'gray', family = font_family)

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

cor(johns_hopkins_deaths_with_excess$weekly_deaths, johns_hopkins_deaths_with_excess$excess_over_average)
cor(johns_hopkins_deaths_with_excess$weekly_deaths, johns_hopkins_deaths_with_excess$excess_over_average)^2
johns_hopkins_deaths_with_excess$week_ending_date
johns_hopkins_deaths_with_excess$weekly_deaths
johns_hopkins_deaths_with_excess %>% pivot_longer(cols = c('weekly_deaths', 'excess_over_average'), names_to = 'metric') %>%
ggplot(aes(week_ending_date, value, colour = metric)) +
  geom_line(size = 1) +
  scale_y_continuous(labels = comma) +
  scale_x_date(date_labels = '%b %d', breaks = '4 weeks') +
  theme_bw() +
  theme(
    text = element_text(family = font_family),
    legend.text = element_text(size = 15),
    axis.text = element_text(size = 14),
    axis.title = element_text(size = 16),
    plot.title = element_text(size = 26),
    plot.subtitle = element_text(size = 14.5, face = 'italic'),
    plot.caption = element_text(size = 11, hjust = 0, face = 'italic'),
    legend.position = 'bottom'
  ) +
  labs(
    x = '', y = 'Weekly COVID Deaths',
    title = 'U.S. Excess Deaths for 2020 vs. Johns Hopkins Counted COVID Deaths',
    subtitle = 'Excess deaths are computed by comparing observed deaths from all causes to prior year averages. Counted COVID deaths are obtained by counting each death linked to COVID.' %>% str_wrap(120),
    caption = 'Chart: Taylor G. White (@t_g_white)\nData: CDC, Johns Hopkins CSSE'
  ) +
  scale_colour_manual(
    name = '',
    values = c('weekly_deaths' = 'steelblue', 'excess_over_average' = 'orange'),
                      labels = c('weekly_deaths' = 'Weekly counted COVID Deaths\nvia Johns Hopkins', 'excess_over_average' = 'CDC Excess Deaths'))

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

# geom_label_repel(aes(label = label), na.rm = T) +
  # # transition_states(
  # #   year, transition_length = 5, state_length = 10
  # # ) +
  # # transition_reveal(along = year) +
  # shadow_trail() +
  # ease_aes('linear')

# animate(anim, nframes = 200,
#         renderer = gifski_renderer("annual_excess_deaths_by_week.gif"),
#         height = 9, width = 12, units = 'in',  type = 'cairo-png', res = 100, start_pause = 10, end_pause = 50)
#


## Plot figure 2

# For each sampling method - random or targeted
# For each fire regime (e1, e2, e3, e4)
# For NFR, MFIall, MFI10% MFI25%
# For sample size 10,25,50,100,250,500,census,real

# function to make a mini data frame of our chosen variables
make_plot_frame=function(this_data,x,names){
  this_of=subset(this_data,select=x)
  this_of=unlist(this_of)
  this_names=factor(rep(names,each=100),levels=names)
  this_of=data.frame(value=this_of,var=this_names)
  this_of
}

## Random Figure

data_l1=read.csv("e1_l1/sim_list_stats1.csv")
data_l2=read.csv("e1_l2/sim_list_stats1.csv")
data_l3=read.csv("e1_l3/sim_list_stats1.csv")
data_l4=read.csv("e1_l4/sim_list_stats1.csv")

# Select annual small fires
names=c("10","25","50","100","250","500","All","Actual")

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

pdf(file="Fig2.pdf",width=14,height=10)

par(mfrow=c(4,4),mai=c(0.8,.8,.010,.05),mar=c(4,4,0,0),oma=c(3,3,3,3),cex=1)

# MFI 1
vars=c("MFI_10","MFI_25","MFI_50","MFI_100","MFI_250","MFI_500","MFI_census","GridRealMFI")
this_frame=make_plot_frame(data_l1,vars,names)
aa=boxplot(value~var,data=this_frame,ylab=expression(MFI[all]),xlab="",las=2,xaxt="n")
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")
# MFI 2
this_frame=make_plot_frame(data_l2,vars,names)
aa=boxplot(value~var,data=this_frame,xlab="",ylab="",las=2,xaxt="n")
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")
# MFI 3
vars=c("MFI_10_T","MFI_25_T","MFI_50_T","MFI_100_T","MFI_250_T","MFI_500_T","MFI_census","GridRealMFI")
this_frame=make_plot_frame(data_l3,vars,names)
aa=boxplot(value~var,data=this_frame,xlab="",ylab="",las=2,xaxt="n")
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")
# MFI 4
vars=c("MFI_10_T","MFI_25_T","MFI_50_T","MFI_100_T","MFI_250_T","MFI_500_T","MFI_census","GridRealMFI")
this_frame=make_plot_frame(data_l4,vars,names)
aa=boxplot(value~var,data=this_frame,xlab="",ylab="",las=2,xaxt="n")
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")

# MFI 2-trees

# MFI 1
vars=c("MFI_10_2o","MFI_25_2o","MFI_50_2o","MFI_100_2o","MFI_250_2o","MFI_500_2o","MFI_census_2o","MFI_grid_2o")
this_frame=make_plot_frame(data_l1,vars,names)
aa=boxplot(value~var,data=this_frame,ylab=expression(MFI['>2']),xlab="",las=2,xaxt="n")
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")
# MFI 2
this_frame=make_plot_frame(data_l2,vars,names)
aa=boxplot(value~var,data=this_frame,xlab="",ylab="",las=2,xaxt="n")
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")
# MFI 3
this_frame=make_plot_frame(data_l3,vars,names)
aa=boxplot(value~var,data=this_frame,xlab="",ylab="",las=2,xaxt="n")
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")
# MFI 4
this_frame=make_plot_frame(data_l4,vars,names)
aa=boxplot(value~var,data=this_frame,xlab="",ylab="",las=2,xaxt="n")
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")

#################### MFI 10

# MFI 1
vars=c("MFI_10_10","MFI_25_10","MFI_50_10","MFI_100_10","MFI_250_10","MFI_500_10","MFI_census_10","MFI_grid_10")
this_frame=make_plot_frame(data_l1,vars,names)
aa=boxplot(value~var,data=this_frame,ylab=expression(MFI['10%']),xlab="",las=2,xaxt="n")
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")
# MFI 2
this_frame=make_plot_frame(data_l2,vars,names)
aa=boxplot(value~var,data=this_frame,xlab="",ylab="",las=2,xaxt="n")
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")
# MFI 3
this_frame=make_plot_frame(data_l3,vars,names)
aa=boxplot(value~var,data=this_frame,xlab="",ylab="",las=2,xaxt="n")
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")
# MFI 4
this_frame=make_plot_frame(data_l4,vars,names)
aa=boxplot(value~var,data=this_frame,xlab="",ylab="",las=2,xaxt="n")
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")

### MFI 25

# MFI 1
vars=c("MFI_10_25","MFI_25_25","MFI_50_25","MFI_100_25","MFI_250_25","MFI_500_25","MFI_census_25","MFI_grid_25")
this_frame=make_plot_frame(data_l1,vars,names)
aa=boxplot(value~var,data=this_frame,ylab=expression(MFI['25%']),xlab="Annual Small",las=2)
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")
# MFI 2
this_frame=make_plot_frame(data_l2,vars,names)
aa=boxplot(value~var,data=this_frame,xlab="Intermediate 1",ylab="",las=2)
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")
# MFI 3
this_frame=make_plot_frame(data_l3,vars,names)
aa=boxplot(value~var,data=this_frame,xlab="Intermediate 2",ylab="",las=2)
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")
# MFI 4
this_frame=make_plot_frame(data_l4,vars,names)
aa=boxplot(value~var,data=this_frame,xlab="Bidecadal Large",ylab="",las=2)
rect(-1,aa$stats[2,8],9,aa$stats[4,8],col="#9999FF88",border=NA)
abline(h=aa$stats[3,8],col="#9999FF88")

dev.off()
#


# This is a test/example rd file
# Two diffuse spheres, three colored directional lights
# One point light between the spheres.

Display "Point Light Test"  "Screen" "rgbdouble"
Format 640 480
CameraFOV 5
CameraEye 0 0 50

WorldBegin

#FarLight 0 0 -1  1.0  1.0  1.0  1.0

FarLight  1  1 -0.5  1.0 0.0 0.0  0.5  #Red Light    -- Lower Left
FarLight  0 -1 -0.5  0.0 1.0 0.0  0.5  #Green Light  -- Up
FarLight -1  1 -0.5  0.0 0.0 1.0  0.5  #Blue Light   -- Lower Right

PointLight 0 0 0  1.0 1.0 1.0 1.0  # White light -- centered

Ka 0.0
Kd 1.0
Ks 1.0

Surface "plastic"

Specular 1.0 1.0 1.0  1

Translate -1.25 0 0

Sphere 1.0 -1.0 1.0 360.0

Translate 2.5 0 0

OptionBool "Interpolate" off

Sphere 1.0 -1.0 1.0 360.0

WorldEnd


#' Model Comparison via LOO-CV, WAIC and Raw LPPD
#'
#' Applies log-likelihood based model comparison to any number of stanfit objects and extracts LOO-CV,
#' WAIC and Raw LPPD measures and plots the models on a absolute scale ranging from 0 (best models) to
#' 1 (worst models). WAIC and LOO-CV code has been adapted directly from the "LOO" package. Because
#' most methods to prevent log-exp calculation-underflow failed, this function imputes underflow values
#' with the mean of sampled values. When this happens, the function will report the amount of imputed values
#' to inform the user. More than 5% of imputed values should not be accepted.
#' Mind how Stan saves log-likelihood values! Consult the Stan manual to check how they are saved correctly!
#' Because all models need to be loaded into memory, be wary if loading to big stanfits. Lighten the Stanfit
#' objects by discarding unnecesary iterations is advised.
#'
#' @export
#' @param stanfits At least 2 stanfit objects.
#' @param lik_name Name under which the log likelihoods have been saved in the models. Needs to be identical
#' across all Stanfit objects.
#' @param impute_inf A boolean which regulates if underflow values should be automatically imputed or not. If
#' \code{FALSE}, the models with such values will just be ignored. If \code{TRUE}, a report will be generated
#' on how many values were imputed and for which models.
#' @examples
#'
#' load(fit1.Rdata)
#' load(fit2.Rdata)
#'
#' model_judgement(fit1, fit2, impute_inf = TRUE)
#' @return Prints a table and generates a plot with the model ranked according to LOO-CV, WAIC and Raw LPPD.
model_judgement <- function(..., lik_name = "log_lik", impute_inf = TRUE) {
    #compare all models in environment: compare <- ls(pattern = 'StanDDM')
    if (!require("data.table")) {install.packages("data.table", dependencies = TRUE); library(data.table)}
    if (!require("rstan")) {install.packages("rstan", dependencies = TRUE); library(rstan)}

    arg <- list(...)
    nms <- substitute(list(...))[-1]
    names(arg) <- as.list(nms)

    if(impute_inf){
        imps <- arg}
    else{
        pre <- precheck(arg, lik_name)
        if(pre[[1]]==1){
            cat('\nAll models are OK to go.\n')
        }
        else{
            cat('\nWarning: The following models feature Log Exp underflow NaNs:\n\n')
            print(pre$troublemakers)
            cat('___________________________________\n\n')
        }
    }

    for(.. in 1:length(arg)){

        current_model <- nms[..]

        judgement <- (waic(arg[[..]], current_model, lik_name, impute_inf))

        ic <- judgement['ic']
        arg[[..]] <- list("lppd" = as.numeric(ic$ic$total['lpd']),
                          "PSIS-LOO" = as.numeric(ic$ic$total['elpd_loo']),
                          "WAIC" = as.numeric(ic$ic$total['waic']))

        if(impute_inf){
            imp <- judgement['imps']
            imps[[..]] <- list('Model Name' = as.character(current_model),
                               "%Likelihood imp." = imp$imps$lik_imp,
                               "% LOO CV imp." = imp$imps$loo_imp)
        }

    }
    if(impute_inf){
        cat('\n\n___________________________________')
        cat('\n Warning: The following models had -Inf values imputed (shows % of data imputed):\n\n')
        print(rbindlist(imps, fill=TRUE))
        cat('___________________________________\n\n')
    }

    #plotting:
    gc()
    df <- rbindlist(arg, fill=TRUE)

    madmax <- apply(abs(df), 2, FUN = max, na.rm=TRUE)

    df <- sweep(abs(df), 2, madmax, "/")
    df <- cbind(Model = names(arg), df)

    molten_df <- df %>% tidyr::pivot_longer(cols= -Model, names_to = 'variable', values_to = 'value')
    # pd <- position_dodge(0.05)  #The errorbars overlapped, so use position_dodge to move them horizontally
    plot <- ggplot(molten_df, aes(x=variable, y=value, colour=Model,group=Model)) +
        # geom_errorbar(aes(ymin=value-se, ymax=mean+se), width=.1,position=pd) +
        geom_line() +
        geom_point()+
        geom_text(aes(label=Model),hjust=0, vjust=0,
                  position = position_dodge(width=0.3),  size=2.5) +
        ylab("Absolute ranking of model fit") +
        xlab("IC")+
        scale_colour_hue(name="Models:") +
        # ylim(0, 1) +
        theme(legend.position="bottom")

    gc()
    return(list(df, plot))

}


#setwd('F:/IJE/code/shiny/')
library(shiny)
library(dplyr)
library(leaflet)
library(scales)
library(ggplot2)
#library(highcharter)
options(scipen = 999)

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

  #####
  ## NATIONAL TAB - MAP OF IJE EMPLOYMENT/INCOME
  #####

  ## disables income source selection when type input is equal to resident (null values)
  observeEvent(input$TypeInput,{
    if(input$TypeInput=='Resident'){
      updateRadioButtons(session=session,inputId='IncomeSource',selected='Inside the Jurisdiction')
      shinyjs::disable('IncomeSource')
    } else {
      shinyjs::enable('IncomeSource')
    }
  })

  ## reactive filtered table
  mapfilter <- eventReactive(input$NationalGen,{
    table_1_2 %>%
      filter(year%in% input$YearInput,
             source %in% input$SourceInput,
             gender %in% input$GenderInput,
             type %in% input$TypeInput,
             income_source %in% input$IncomeSource) %>%
      mutate(inp=input$SeriesInput,
             dispvar=ifelse(inp=='Employee Count',
                            format(count,big.mark=','), # if employees, format here, income below
                            paste0('$',format(round(income/1000000,1),big.mark=','),' M')),
             prec=ifelse(inp=='Employee Count','Count of','Total income of'))
  },
  ignoreNULL=F)

  output$mainmap <- renderPlotly({

    mapdat <- simple_pr_shapefile %>%
      inner_join(mapfilter(), by='PRUID') %>%

      mutate(mapformat=sf::st_transform(
        simple_pr_shapefile$geometry,
        crs= "+proj=laea +lat_0=56.1304 +lon_0=-86.3468 +ellps=WGS84 +units=m +no_defs "))

    ## set color scheme for concept (employees in blue, income in red)
    if(first(mapfilter()$prec) == "Count of"){
      seriesvar <- mapdat$count
      lowgrad <- '#f1eef6'
      highgrad <- '#045a8d'
      seriestitle <- 'Number of Inter-Jurisdictional Employees by Province'
      legtitle <- 'Count (log 10 scale)'
      leglabfn <- function(s){format(s,big.mark=',')}

      # seriestitle <- 'Number of Inter-Jurisdictional Employees'
      #
      pal_count_PR <- createClasses(mapdat$count , "Blues", "transparent", 5)
      #
      # geo_labels_PR <- sprintf(
      #   "%s (Employees):  %s ",
      #   mapdat$province, format(mapdat$count, big.mark = ",")) %>%
      #   lapply(htmltools::HTML) # add labels

    } else if(first(mapfilter()$prec) == "Total income of"){
      seriesvar <- mapdat$income
      lowgrad <- '#fef0d9'
      highgrad <- '#b30000'
      seriestitle <- 'Total Income of Inter-Jurisdictional Employees by Province'
      legtitle <- 'Income (log 10 scale)'
      leglabfn <- function(s){paste0('$',format(round(s/1000000,1),big.mark=','),'M')}
      # seriestitle <- 'Income of Inter-Jurisdictional Employees'
      #
      pal_count_PR <- createClasses(mapdat$income, "Reds", "transparent", 5)
      #
      # geo_labels_PR <- sprintf(
      #   "%s (Income): %s ",
      #   mapdat$province, format(mapdat$income, big.mark = ",")) %>%
      #   lapply(htmltools::HTML) # add labels
    }

    mapdat <- mapdat %>%
      mutate(pcol=pal_count_PR$pal(seriesvar))

    ggplotly(
      ggplot(mapdat %>% mutate(geometry=mapformat)) +
        geom_sf(aes(fill=seriesvar,
                    text=sprintf("%s, %s
%s %s %s IJE: %s",
                                 province,year,
                                 prec,tolower(gender),tolower(type),dispvar)),

                color="#444444",
                alpha=0.75) + theme_bw() +

        labs(title=seriestitle) +
        # scale_fill_manual(values=pcol) +

        scale_fill_gradient(name=legtitle,
          low=lowgrad,high=highgrad,na.value='grey.50',
                            breaks=c(min(seriesvar),
                                     median(seriesvar),
                                     max(seriesvar)),
                            labels=c(paste0('Min: ',leglabfn(min(seriesvar)),'\n(',
                                            first(filter(mapdat,seriesvar==min(seriesvar))$province),')\n\n'),
                                     paste0('Med: ',leglabfn(median(seriesvar)),'\n(',
                                            first(filter(mapdat,seriesvar==median(seriesvar))$province),')'),
                                     paste0('\n\nMax: ',leglabfn(max(seriesvar)),'\n(',
                                            first(filter(mapdat,seriesvar==max(seriesvar))$province),')')),
                            trans='log') +

        theme(plot.title = element_text(vjust=1, hjust=0.5, size=14, face = "bold"),
              panel.grid.major=element_blank(),panel.grid.minor=element_blank(),
              axis.title.x=element_blank(),axis.text.x=element_blank(),axis.ticks.x=element_blank(),
              axis.title.y=element_blank(),axis.text.y=element_blank(),axis.ticks.y=element_blank()),

      tooltip='text') %>%
      style(hoveron='all')

  })

  #####
  ## DEPRECATED - LEAFLET STYLE TABLE
  #####

  # output$PRcount <- renderLeaflet({
  #
  #   #####
  #   PRcount <- leaflet(table_1_2)#%>%
  #   # addProviderTiles(providers$OpenStreetMap.BlackAndWhite)
  #
  #   #filter;
  #   IJE_table1_filted <-
  #     inner_join(simple_pr_shapefile, table_1_2 %>%filter(year%in% input$YearInput,
  #                                                         source %in% input$SourceInput,
  #                                                         gender %in% input$GenderInput,
  #                                                         type %in% input$TypeInput,
  #                                                         income_source %in% input$IncomeSource
  #     ),by = c("PRUID" = "PRUID"))
  #
  #   #color;
  #   if(input$SeriesInput == "Employees"){
  #     seriesvar <- IJE_table1_filted$count
  #     seriestitle <- 'Number of Inter-Jurisdictional Employees'
  #
  #     pal_count_PR <- createClasses(IJE_table1_filted$count , "Blues", "transparent", 5)
  #
  #     geo_labels_PR <- sprintf(
  #       "%s (Employees):  %s ",
  #       IJE_table1_filted$province, format(IJE_table1_filted$count, big.mark = ",")) %>%
  #       lapply(htmltools::HTML) # add labels
  #
  #   } else if(input$SeriesInput == "Income"){
  #
  #     seriesvar <- IJE_table1_filted$income
  #     seriestitle <- 'Income of Inter-Jurisdictional Employees'
  #
  #     pal_count_PR <- createClasses(IJE_table1_filted$income, "Reds", "transparent", 5)
  #
  #     geo_labels_PR <- sprintf(
  #       "%s (Income): %s ",
  #       IJE_table1_filted$province, format(IJE_table1_filted$income, big.mark = ",")) %>%
  #       lapply(htmltools::HTML) # add labels
  #   }
  #
  #   # geo_labels_PR <- sprintf(
  #   #   "%s (Employees):  %s ",
  #   #   IJE_table1_filted$province, format(IJE_table1_filted$count, big.mark = ",")) %>%
  #   #   lapply(htmltools::HTML) # add labels
  #   #
  #   # labels_inc <- sprintf(
  #   #   "%s (Income): %s ",
  #   #   IJE_table1_filted$province, format(IJE_table1_filted$income, big.mark = ",")) %>%
  #   #   lapply(htmltools::HTML) # add labels
  #
  #   #####
  #   PRcount %>%
  #     addPolygons( data = IJE_table1_filted,stroke = TRUE, color = "#444444", weight = 1, smoothFactor = 0.5,
  #                  opacity = 1.0, fillOpacity = 0.5,fillColor = pal_count_PR$pal(seriesvar),group = "count",
  #                  highlightOptions = highlightOptions(color = "white", weight = 2,
  #                                                      bringToFront = FALSE),
  #                  label = geo_labels_PR,
  #                  labelOptions = labelOptions(
  #                    style = list(padding = "3px 8px"),
  #                    textsize = "13px",
  #                    direction = "auto"),
  #                  popup =paste( '', IJE_table1_filted$province, '', "
",
  #                                "Number of Employees: ", format(IJE_table1_filted$count, big.mark = ","), "
",
  #                                "Income: ", format(IJE_table1_filted$income, big.mark = "," ), "
")
  #     )%>%
  #     # addCircles(lng = IJE_table1_filted$lon, lat  = IJE_table1_filted$lat, weight = 2, radius = sqrt(IJE_table1_filted$income)*5,opacity = 1.0, fillOpacity = 0.5, fillColor = "transparent",
  #     #            color="red", label = labels_inc, highlightOptions = highlightOptions(color = "white", weight = 3,
  #     #                                                                                bringToFront = TRUE), group="Income")%>%
  #     addLegend(position ="topright", pal = pal_count_PR$pal, values = seriesvar,
  #               opacity = 1, title = seriestitle, na.label = "No Data")%>%
  #     # addLayersControl( overlayGroups = c("Income"),
  #     #                   options = layersControlOptions(collapsed = TRUE, autoZIndex=TRUE)) %>%
  #     addScaleBar(position = "bottomleft", options = scaleBarOptions(imperial = FALSE))
  #
  # })

  #National Level download

  National_filted<- reactive({ ## this is a repetition of an earlier table - does it need to be duplicated?
    table_1_2 %>%
      filter(year%in% input$YearInput,
             source %in% input$SourceInput,
             gender %in% input$GenderInput,
             type %in% input$TypeInput,
             income_source %in% input$IncomeSource
      )})

  ## verify that this code works
  tableN_down <- reactive ({
    switch( input$tableN,
            "Filtered National Table" = National_filted(),
            "Full National Table" = table_1_2
    )
  })

  # Downloadable excel file of selected table
  output$downloadNtable <- downloadHandler(
    filename = function(){
      paste(input$tableN, ".csv", sep = "")
      #paste(input$table)
    },
    content = function(file){
      write.csv(tableN_down(), file, row.names = FALSE)

    },
    contentType = "csv"
  )

  #####
  ## JURISDICTION TAB - INCOMING/OUTGOING EMPLOYEES/INCOME BY PROVINCE
  #####

  ## Jurisdiction Trendplot

  ## if the province is changed here, it will update the selected province in all other tabs
  observeEvent(input$ProvinceInput,
               {
                 lapply(c('ProIndInput','ProOPInput','ProAgeInput'),
                        function(x) updateSelectInput(session=session, inputId=x, selected=input$ProvinceInput))
               })

  trend_filted <- eventReactive(input$JurisdGen,{
    table_1_2 %>%
      filter(province %in% input$ProvinceInput,
             year>= input$YRInput[1],
             year<= input$YRInput[2],
             source %in% input$DSInput,
             gender %in% input$GDInput,
             type != "Resident",
             case_when(type == "Incoming" ~ income_source == "Inside the Jurisdiction", T ~ income_source == "Outside the Jurisdiction")
      )},
    ignoreNULL=F)

  #count trend
  output$PRtrend <-renderPlotly({
    ggplotly(
      ggplot(trend_filted(), aes(x=year, y = count/1000, group=type, color=type,
                                 text=sprintf('%s, %s
%s %s employees: %s',
                                              province,year,
                                              gender,tolower(type),
                                              format(count,big.mark=',')))) +
        geom_line() + geom_point() +

        labs(title=paste0("Incoming vs. Outgoing Inter-Jurisdicitonal Employees
for ",first(trend_filted()$province))) +
        xlab("Year") + ylab("Employees (x1,000)") +

        scale_x_continuous(breaks=seq(2002,2017,2),
                           minor_breaks=seq(2002,2017,1))+
        scale_y_continuous(labels = function(c){paste0(format(c, big.mark = ","),'k')}) +
        scale_colour_manual(name='',values = c("aquamarine4", "yellow3")) +

        theme(plot.title = element_text(hjust=0.5,size=14, face = "bold")),

      tooltip='text'
    ) %>% layout(margin=list(l=60,r=50,t=75,b=65),
                 legend=list(x=100,y=0.5))
  })

  #Income trend
  output$PRInctrend <-renderPlotly({
    ggplotly(
      ggplot(trend_filted(), aes(x=year, y = income/1000000, group=type, color=type,
                                 text=sprintf('%s, %s
Income of %s %s employees
%sside the jurisdiction: $%sM',
                                              province,year,
                                              tolower(gender),tolower(type),
                                              str_extract(tolower(type),'.*(?=coming|going)'),
                                              format(round(income/1000000,1),big.mark=',')))) +
        geom_line() + geom_point() +

        labs(title=paste0("Incoming vs. Outgoing Employee Aggregate T4 Earnings
for ",first(trend_filted()$province))) +
        xlab("Year") + ylab("Aggregate T4 Earnings (Million $)") +

        scale_x_continuous(breaks=seq(2002,2017,2)) +
        scale_y_continuous(labels = function(c){paste0('$',format(c, big.mark = ","),'M')}) +
        scale_colour_manual(name='',values = c("cyan3", "darkorange2")) +

        theme(plot.title = element_text(hjust=0.5,size=14, face = "bold"),
              axis.title = element_text(size=11)),

      tooltip='text'
    ) %>% layout(margin=list(l=60,r=50,t=75,b=65),
                 legend=list(x=100,y=0.5))
  })

  ## DEPRECATED GRAPHS

  #Income receiver and Income Sender trend
  # output$Income_receiver <-renderPlot({
  #   IJE_table1_receive <-
  #     table_1_2 %>%
  #     filter(province %in% input$ProvinceInput,
  #            year>= input$YRInput[1],
  #            year<= input$YRInput[2],
  #            source %in% input$DSInput,
  #            gender %in% input$GDInput,
  #            type == "Incoming",
  #            income_source %in% "Inside the Jurisdiction"
  #     )
  #
  #   ggplot(IJE_table1_receive,aes(x = year )) +
  #     geom_bar(mapping = aes(y = count, colour = "Employee"),stat = 'identity', fill= "aquamarine4")+
  #     #add second dimension
  #     geom_line(mapping = aes( y = income/35000),group = 1, size = 2,  colour = "cyan3")+
  #     scale_x_continuous(breaks=seq(2002,2017,2))+
  #
  #     #add second y axis
  #     scale_y_continuous(name = "Incoming IJE",
  #                        labels = function(c){paste0(format(c, big.mark = ","))} ,
  #                        sec.axis = sec_axis(~.*35000, name="Aggregate T4 Earnings",
  #                                            labels = function(b){paste0(format(b, big.mark = ","))}))+
  #     xlab('Year') +
  #     #define colour
  #     scale_colour_manual(values = c("aquamarine4", "cyan3")) +
  #     #label location
  #     theme(legend.position = "none",
  #           axis.title.y= element_text(color = "aquamarine4", size=12),
  #           axis.title.y.right = element_text(color = "cyan3", size=12),
  #           plot.title = element_text(hjust=0.5, size=16, face="bold"),
  #           axis.title = element_text(size=12))+
  #     ggtitle('Incoming Inter-Jurisdictional Employees and Aggregate T4 Earnings')
  #
  # })
  #
  #
  # output$Income_sender <-renderPlot({
  #   IJE_table1_receive <-
  #     table_1_2 %>%
  #     filter(province %in% input$ProvinceInput,
  #            year>= input$YRInput[1],
  #            year<= input$YRInput[2],
  #            source %in% input$DSInput,
  #            gender %in% input$GDInput,
  #            type == "Outgoing",
  #            income_source %in% "Outside the Jurisdiction"
  #     )
  #
  #   ggplot(IJE_table1_receive,aes(x = year )) +
  #     geom_bar(mapping = aes(y = count, colour = "Employee"),stat = 'identity', fill = "yellow3")+
  #     #add second dimension
  #     geom_line(mapping = aes( y = income/35000),group = 1, size = 2,  colour = "darkorange2")+
  #     scale_x_continuous(breaks=seq(2002,2017,2))+
  #
  #     #add second y axis
  #     scale_y_continuous(name = "Outgoing IJE",
  #                        labels = function(c){paste0(format(c, big.mark = ","))} ,
  #                        sec.axis = sec_axis(~.*35000, name="Aggregate T4 Earnings",
  #                                            labels = function(b){paste0(format(b, big.mark = ","))}))+
  #     xlab('Year') +
  #     scale_colour_manual(values = c("yellow3", "darkorange2")) +
  #     #label location
  #     theme( legend.position = "none",
  #            axis.title.y= element_text(color = "yellow3", size=12),
  #            axis.title.y.right = element_text(color = "darkorange2"),
  #            plot.title = element_text(hjust=0.5, size=16, face="bold"),
  #            axis.title = element_text(size=12))+
  #     ggtitle('Outgoing Inter-Jurisdictional Employees and Aggregate T4 Earnings')
  #
  # })
  #

  #PR Trend download tables

  ## duplicate??
  tableP_down <- reactive ({
    switch( input$tableIn,
            "Filtered Table" = trend_filted(),
            "Full Table" = table_1_2
    )
  })

  # Downloadable excel file of selected table
  output$downloadPtable <- downloadHandler(
    filename = function(){
      paste(input$tableIn, ".csv", sep = "")
      #paste(input$table)
    },
    content = function(file){
      write.csv(tableP_down(), file, row.names = FALSE)

    },
    contentType = "csv"
  )

  #####
  ## TARGET PROVINCE - Income, employment for province pairs by target jurisdiction
  #####

  observeEvent(input$ProOPInput,
               {
                 lapply(c('ProvinceInput','ProIndInput','ProAgeInput'),
                        function(x) updateSelectInput(session=session, inputId=x, selected=input$ProOPInput))
               })

  ## select/deselect all button - observes if the selectAllInd option is selected or not and fills, clears selection accordingly
  observeEvent(
    eventExpr=input$selectAllProv,
    handlerExpr=if(input$selectAllProv){
      updateCheckboxGroupInput(session=session,inputId='ProTPInput',choices=provList,selected=provList)
    } else {
      updateCheckboxGroupInput(session=session,inputId='ProTPInput',choices=provList,selected=c())
    },

    ignoreInit=T
  )

  table56910_filtered <- eventReactive(input$TgtJurisdGen,{
    table_56910 %>%
      filter(province %in% input$ProOPInput,
             target_prov %in% input$ProTPInput,
             type %in% input$IncOutTgtJuris,
             year>= input$YRTP[1],
             year<= input$YRTP[2]) %>%
      mutate(target_prov=factor(target_prov,levels=c("Newfoundland and Labrador","Prince Edward Island","Nova Scotia","New Brunswick",
                                                     "Quebec", "Ontario", "Manitoba","Saskatchewan","Alberta","British Columbia",
                                                     "Yukon", "Northwest Territories","Nunavut")),
             direction=ifelse(type=='Incoming','from','in'))
  },
  ignoreNULL=F)

  ## count
  output$TPcount <- renderPlotly({
    ggplotly(
      ggplot(table56910_filtered(), aes(x=year, y= count/1000, group=target_prov, color=target_prov,
                                        text=sprintf("%s, %s
%s employees %s %s: %s",
                                                     province,year,
                                                     type,direction,target_prov,
                                                     format(count,big.mark=',')))) +
        geom_line() + geom_point()+

        labs(title=paste("Inter-Jurisdictional Employment for
", first(table56910_filtered()$province))) +
        xlab('Year') + ylab('Employees (x1,000)') +

        scale_x_continuous(breaks=seq(2002,2017,2))+
        scale_y_continuous(labels = function(c){paste0(format(c, big.mark = ","),'k')})+
        scale_color_brewer(name='Province',palette='Paired') +

        theme(plot.title = element_text(hjust = 0.5, size = 14, face = "bold"),
              axis.title = element_text(size=11)),

      tooltip='text'
    ) %>% layout(margin=list(l=60,r=50,t=75,b=65),
                 legend=list(x=100,y=0.5))
  })

  ## income
  output$TPincome <- renderPlotly({
    ggplotly(
      ggplot(table56910_filtered(), aes(x=year, y= income/1000000, group=target_prov, color=target_prov,
                                        text=sprintf("%s, %s
Income of %s employees %s %s: %s",
                                                     province,year,
                                                     tolower(type),direction,target_prov,
                                                     paste0('$',format(round(income/1000000,1),big.mark=','),'M')))) +
        geom_line() + geom_point()+

        labs(title=paste("Inter-Jurisdictional Employment Income for
", first(table56910_filtered()$province))) +
        xlab('Year') + ylab('Aggregate T4 Earnings (Million $)') +

        scale_x_continuous(breaks=seq(2002,2017,2))+
        scale_y_continuous(labels = function(c){paste0('$',format(c, big.mark = ","),'M')})+
        scale_color_brewer(name='Province',palette='Paired') +

        theme(plot.title = element_text(hjust = 0.5, size = 14, face = "bold"),
              axis.title = element_text(size=11)),

      tooltip='text'
    ) %>% layout(margin=list(l=60,r=50,t=75,b=65),
                 legend=list(x=100,y=0.5))
  })

  ## Download target province table
  tableTP_down <- reactive ({
    switch( input$tableTP,
            "Filtered Industry Table" = table56910_filtered(),
            "Full Table" = table_56910
    )
  })

  # Downloadable excel file of selected table
  output$downloadTPtable <- downloadHandler(
    filename = function(){
      paste(input$tableTP, ".csv", sep = "")
      #paste(input$table)
    },
    content = function(file){
      write.csv(tableTP_down(), file, row.names = FALSE)

    },
    contentType = "csv"
  )

  #####
  ## INDUSTRY TAB - Graphs by industry for target jurisdiction
  #####

  observeEvent(input$ProIndInput,
               {
                 lapply(c('ProvinceInput','ProOPInput','ProAgeInput'),
                        function(x) updateSelectInput(session=session, inputId=x, selected=input$ProIndInput))
               })

  ## select/deselect all button - observes if the selectAllInd option is selected or not and fills, clears selection accordingly
  observeEvent(
    eventExpr=input$selectAllInd,
    handlerExpr=if(input$selectAllInd){
      updateCheckboxGroupInput(session=session,inputId="IndustryInput",choices=indList,selected=indList)
    } else {
      updateCheckboxGroupInput(session=session,inputId="IndustryInput",choices=indList,selected=c())
    },

    ignoreInit=T
  )

  ##
  ind_filtered <- eventReactive(input$IndustryGen,{
    table_3478 %>%
      filter(province %in% input$ProIndInput,
             industry %in% input$IndustryInput,
             type %in% input$IncOutIndustry,
             year>= input$YRInd[1],
             year<= input$YRInd[2]) %>%
      mutate(industry=factor(industry,levels=indList))
  },
  ignoreNULL=F)

  getPalette = colorRampPalette(brewer.pal(9, "Set1"))

  ## count trend
  output$IndCount <- renderPlotly({
    ggplotly(
      ggplot(ind_filtered(), aes(x=year, y=count/1000, group=industry, color=industry,
                                 text=sprintf("%s, %s
Industry: %s
%s employees: %s",
                                              province,year,
                                              industry,
                                              type,format(count,big.mark=',')))) +
        geom_line() + geom_point() +

        labs(title=paste0("Inter-Jurisdictional Employment for
",first(ind_filtered()$province)," by Industry")) +
        xlab("Year") + ylab("Employees (x1,000)") +

        scale_x_continuous(breaks=seq(2002,2017,2)) +
        scale_y_continuous(labels = function(c){paste0(format(c, big.mark = ","),'k')}) +
        scale_colour_manual(name='Industry',values=getPalette(length(unique(ind_filtered()$industry)))) +

        theme(plot.title = element_text(hjust=0.5,size=14, face = "bold"),
              axis.title = element_text(size=11)),

      tooltip='text'
    ) %>% layout(margin=list(l=60,r=50,t=75,b=65),
                 legend=list(x=100,y=0.5))
  })

  ## income trend
  output$IndIncome <- renderPlotly({
    ggplotly(
      ggplot(ind_filtered(), aes(x=year, y=income/1000000, group=industry, color=industry,
                                 text=sprintf("%s, %s
Industry: %s
Income of %s employees %sside the jurisdiction: %s",
                                              province,year,
                                              industry,tolower(type),
                                              str_extract(tolower(type),'.*(?=coming|going)'),
                                              paste0('$',format(round(income/1000000,1),big.mark=','),'M')))) +
        geom_line() + geom_point() +

        labs(title=paste0("Inter-Jurisdictional Employment Income for
",first(ind_filtered()$province)," by Industry")) +
        xlab("Year") + ylab("Aggregate T4 Earnings (Million $)") +

        scale_x_continuous(breaks=seq(2002,2017,2)) +
        scale_y_continuous(labels = function(c){paste0('$',format(c, big.mark = ","),'M')}) +
        scale_colour_manual(name='Industry',values=getPalette(length(unique(ind_filtered()$industry)))) +

        theme(plot.title = element_text(hjust=0.5,size=14, face = "bold"),
              axis.title = element_text(size=11)),

      tooltip='text'
    ) %>% layout(margin=list(l=60,r=50,t=75,b=65),
                 legend=list(x=100,y=0.5))
  })

  #Industry Trend download tables

  tableI_down <- reactive ({
    switch( input$tableInd,
            "Filtered Industry Table" = ind_filtered(),
            "Full Table" = table_3478
    )
  })

  # Downloadable excel file of selected table
  output$downloadItable <- downloadHandler(
    filename = function(){
      paste(input$tableInd, ".csv", sep = "")
      #paste(input$table)
    },
    content = function(file){
      write.csv(tableI_down(), file, row.names = FALSE)
    },
    contentType = "csv"
  )

  #####
  ## AGE GROUP - Age of IJE over time, relative changes
  #####

  observeEvent(input$ProAgeInput,
               {
                 lapply(c('ProvinceInput','ProIndInput','ProOPInput'),
                        function(x) updateSelectInput(session=session, inputId=x, selected=input$ProAgeInput))
               })

  ## select/deselect all button - observes if the selectAllAge option is selected or not and fills, clears selection accordingly
  observeEvent(
    eventExpr=input$selectAllAge,
    handlerExpr=if(input$selectAllAge){
      updateCheckboxGroupInput(session=session,inputId="AgeInput",choices=ageList,selected=ageList)
    } else {
      updateCheckboxGroupInput(session=session,inputId="AgeInput",choices=ageList,selected=c())
    },

    ignoreInit=T
  )

  agePalette <- paste0('#',c('F8766D','B79F00','00BA38','00BFC4','619CFF','F564E3'))
  names(agePalette) <- unique(table_11$age_group)

  table11_filted<- eventReactive(input$AgeGen,{
    table_11 %>%
      filter(age_group %in% input$AgeInput,
             province %in% input$ProAgeInput,
             gender %in% input$GDAgeInput,
             type %in% input$TAgeInput,
             year>= input$YRAge[1],
             year<= input$YRAge[2])
  },
  ignoreNULL=F)

  #Age Trend
  output$Agetrend <-renderPlotly({
    ggplotly(
      ggplot(table11_filted(), aes(x=year, y = count/1000, group=age_group, color=age_group,
                                   text=sprintf('%s, %s
%s %s employees aged %s: %s',
                                                province,year,
                                                gender,tolower(type),age_group,
                                                format(count,big.mark = ',')))) +
        geom_line() + geom_point() +

        labs(title=paste0("Inter-Jurisdictional Employees by Age Group
for ",first(table11_filted()$province))) +
        xlab("Year") + ylab("Number of Employees (x1,000)") +

        scale_x_continuous(breaks=seq(2002,2017,2))+
        scale_y_continuous(labels = function(c){paste0(format(c, big.mark = ","),'k')})+
        scale_color_manual(name='Age Group',values=agePalette) +

        theme(plot.title = element_text(hjust=0.5, size=14, face = "bold"),
              axis.title = element_text(size=11)),

      tooltip='text'
    ) %>% layout(margin=list(l=60,r=50,t=75,b=65),
                 legend=list(x=100,y=0.5))
  })

  #Age chanages
  table11_changes <- eventReactive(input$AgeGen,{
    table_11 %>%
      filter(age_group %in% input$AgeInput,
             province %in% input$ProAgeInput,
             gender %in% input$GDAgeInput,
             type %in% input$TAgeInput,
             year %in% c(input$YRAge[1], input$YRAge[2])) %>%
      group_by(age_group) %>%
      mutate(pct_change = (lead(count)/count-1)) %>%
      ungroup() %>%
      mutate(yearmin=min(year),yearmax=max(year)) %>%
      filter(year %in% input$YRAge[1])
  },
  ignoreNULL=F)

  output$Agechange <-renderPlotly({
    ggplotly(
      ggplot(table11_changes(), aes(x=age_group, color=age_group, fill=age_group,
                                    text=sprintf('%s
Percent change in %s %s employees
from %s to %s: %s',
                                                 province,tolower(gender),tolower(type),
                                                 yearmin,yearmax,
                                                 paste(round(100*(pct_change),1),'%')))) +
        geom_histogram(mapping = aes(y = pct_change), position = "dodge",stat = 'identity')+

        labs(title=paste("Percentage Changes of Employment by Age Group from", first(table11_changes()$yearmin), "to", first(table11_changes()$yearmax),"
for",first(table11_filted()$province))) +
        xlab('Age Group') + ylab('Change in Employment (%)') +

        scale_y_continuous(labels = scales::percent_format(accuracy = 1)) +
        scale_color_manual(name='Age Group',values=agePalette) +
        scale_fill_manual(name='Age Group',values=agePalette) +

        theme(plot.title = element_text(hjust=0.5, size=14, face = "bold"),
              axis.text.x = element_text(angle = 45, hjust = 1)),

      tooltip='text'
    ) %>% layout(margin=list(l=60,r=50,t=75,b=65),
                 legend=list(x=100,y=0.5))
  })

  #Age Group Trend download tables
  tableA_down <- reactive ({
    switch( input$tableAge,
            "Filtered Age Table" = table11_filted(),
            "Full Age Table" = table_11
    )
  })

  # Downloadable excel file of selected table
  output$downloadAtable <- downloadHandler(
    filename = function(){
      paste(input$tableAge, ".csv", sep = "")
      #paste(input$table)
    },
    content = function(file){
      write.csv(tableA_down(), file, row.names = FALSE)

    },
    contentType = "csv"
  )

  ## ADDITIONAL DOWNLOADS?

  # tableInput <- reactive ({
  #   switch( input$table,
  #           "Alberta" = table_AB,
  #           "British Columbia" = table_BC,
  #           "Manitoba" = table_MB,
  #           "New Brunswick" = table_NB,
  #           "Newfoundland and labrador" = table_NL,
  #           "Northwest Territories" = table_NT,
  #           "Nova Scotia" = table_NS,
  #           "Nunavut" = table_NU,
  #           "Ontario" = table_ON,
  #           "Prince Edward Island" = table_PE,
  #           "Quebec" = table_QC,
  #           "Saskatchewan" = table_SK,
  #           "Yukon" = table_YT
  #   )
  # })
  #
  #
  # # display the selected table
  # output$tableD <- renderTable({
  #   tableInput()
  # })
  #
  # # Downloadable excel file of selected table
  # output$downloadData <- downloadHandler(
  #   filename = function(){
  #     paste(input$table, ".csv", sep = "")
  #   },
  #   content = function(file){
  #     write.csv(tableInput(), file, row.names = FALSE)
  #
  #   }
  # )

  #####
  ## DOWNLOAD TABS
  #####

  output$downloadGuide <- downloadHandler(
    filename = 'Methodological Guide on IJEs-ENGLISH-Dec.2017.pdf',

    content = function(infile){
      file.copy('./data/downloadables/Methodological Guide on IJEs-ENGLISH-Dec.2017.pdf',infile)
      # save_object('david-wavrock/ije/Methodological Guide on IJEs-ENGLISH-Dec.2017.pdf',bucket=minio_filist,use_https=F,region='',file=infile)
    }
  )

  output$downloadVintage <- downloadHandler(
    filename = 'English_Version.zip',

    content = function(infile){
      # zip(zipfile=infile,files=list.files('./data/downloadables/English_Version'),flags='-j')
      file.copy('./data/downloadables/English_Version.zip',infile)
      # save_object('david-wavrock/ije/English_Version.zip',bucket=minio_filist,use_https=F,region='',file=infile)
    },
    contentType = 'application/zip'

  )

}


setwd(outputDrive)
shaded.mat.box.ms <- matrix(NaN,col,row)
eval(parse( text=paste("shaded.mat.ms <- replace(shaded.mat.box.ms,", remain.condition,", 1)") ))
shaded.mat.multi <- shaded.mat.ms*zz1

shaded.mat.box <- matrix(0,col,row)
eval(parse( text=paste("shaded.mat <- replace(shaded.mat.box,", remain.condition,", 1)") ))

windows(width=10,height=5)
par(mar=c(5,7,1,11))
plot(NA,xlim=range(xx1),ylim=range(yy1),frame=FALSE,axes=F,xaxs="i",yaxs="i",ylab="",xlab="")
.filled.contour(x=xx1, y=yy1, z=zz1,levels=clevels,col=red_blue(cstep))

###Shaded the domain
par(new=T,mar=c(5,7,1,11),xaxs="i", yaxs="i", las=1)
.filled.contour(x=xx1, y=yy1, z=shaded.mat.ms,levels=seq(-10,10,1),col=rgb(1,0,0,0.25))

###Countor map and labels
par(new=T,mar=c(5,7,1,11),xaxs="i", yaxs="i", las=1,mgp=c(2.0, 1, 0))
contour(xx1,yy1,matrix(0,nrow(zz1),ncol(zz1)),xlab="GC1 (min)",ylab="GC2 (sec)", yaxs="i",col.lab="blue",col.axis="blue")

####Log Kow
par(new=T,mar=c(5,7,1,11),xaxs="i", yaxs="i", las=1,mgp=c(3, 1, 0))
contour(xx1,yy1,logKo_w.contour, yaxs="i",ylab="Log Kow",axes=FALSE,col=rgb(0,0,0,1),lwd=1.2,levels=seq(-30,30,1),labcex = 1.1)

####Log Koa
par(new=T, mar=c(5,7,1,11) )
contour(xx1,yy1,logKa_w.contour,xaxs="i", yaxs="i",axes=FALSE,col=rgb(1,0.5,0.5,1),lwd=1.2,levels=seq(-30,30,1),labcex = 1.1)
axis(1, xaxt ="n")
mtext("Log Kaw", side = 4, line = 3, las=3,col=rgb(1,0.5,0.5,1))

###Log Kaw
par(new=T,mar=c(5,7,1,11),xaxs="i", yaxs="i", las=1)
contour(xx1,yy1,logKo_a.contour,xaxs="i", yaxs="i",axes=FALSE,col=rgb(0.6,0.6,0.6,1),lwd=1.2,levels=seq(-30,30,1),labcex = 1.1 )
axis(4, yaxt ="n")
mtext("Log Koa", side = 1, line = 3, las=1,col=rgb(0.6,0.6,0.6,1) )


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

install.packages("dplyr")
# library(ggplot2)
library(dplyr)

dataframe <- read.csv(file="tsa_dataset1543038419001" ,head=TRUE,sep="\t")

initial_deployment_dam_update <- tbl_df(dataframe) %>%
  group_by(bundles_count, numberOfGoals, variability) %>%
  summarise(avg_time = mean( (dam_updated_0+ deployment_change_planned_0)/1000000),  std=sd( (dam_updated_0 + deployment_change_planned_2) /1000000))

pdf("initial_deployment_dam_update.pdf")
boxplot(avg_time~bundles_count,data=initial_deployment_dam_update, xlab="Size", ylab="Time(ms)")
dev.off()

dam_updated_1 <- tbl_df(dataframe) %>%
  group_by(bundles_count, numberOfGoals, variability) %>%
  summarise(avg_time = mean( (dam_updated_1 + deployment_change_planned_1) /1000000),  std=sd( (dam_updated_1+ deployment_change_planned_1)/1000000))

pdf("dam_updated_1.pdf")
boxplot(avg_time~bundles_count,data=dam_updated_1, xlab="Size", ylab="Time(ms)")
dev.off()

dam_updated_2 <- tbl_df(dataframe) %>%
  group_by(bundles_count, numberOfGoals, variability) %>%
  summarise(avg_time = mean( (dam_updated_2 + deployment_change_planned_2) /1000000),  std=sd( (dam_updated_2 + deployment_change_planned_2)/1000000))

#data <- read.csv(file="plan_size_vs_time.dat" ,head=TRUE,sep="\t")
#setPDF()
pdf("dam_updated_2.pdf")
boxplot(avg_time~bundles_count,data=dam_updated_2, xlab="Size", ylab="Time(ms)")
dev.off()


#' @param method Smoothing method (function) to use, accepts either
#'   `NULL` or a character vector, e.g. `"lm"`, `"glm"`, `"gam"`, `"loess"`
#'   or a function, e.g. `MASS::rlm` or `mgcv::gam`, `stats::lm`, or `stats::loess`.
#'   `"auto"` is also accepted for backwards compatibility.  It is equivalent to
#'   `NULL`.
#'
#'   For `method = NULL` the smoothing method is chosen based on the
#'   size of the largest group (across all panels). [stats::loess()] is
#'   used for less than 1,000 observations; otherwise [mgcv::gam()] is
#'   used with `formula = y ~ s(x, bs = "cs")` with `method = "REML"`. Somewhat anecdotally,
#'   `loess` gives a better appearance, but is \eqn{O(N^{2})}{O(N^2)} in memory,
#'   so does not work for larger datasets.
#'
#'   If you have fewer than 1,000 observations but want to use the same `gam()`
#'   model that `method = NULL` would use, then set
#'   `method = "gam", formula = y ~ s(x, bs = "cs")`.
#' @param formula Formula to use in smoothing function, eg. `y ~ x`,
#'   `y ~ poly(x, 2)`, `y ~ log(x)`. `NULL` by default, in which case
#'   `method = NULL` implies `formula = y ~ x` when there are fewer than 1,000
#'   observations and `formula = y ~ s(x, bs = "cs")` otherwise.
#' @param se Display confidence interval around smooth? (`TRUE` by default, see
#'   `level` to control.)
#' @param fullrange Should the fit span the full range of the plot, or just
#'   the data?
#' @param level Level of confidence interval to use (0.95 by default).
#' @param span Controls the amount of smoothing for the default loess smoother.
#'   Smaller numbers produce wigglier lines, larger numbers produce smoother
#'   lines. Only used with loess, i.e. when `method = "loess"`,
#'   or when `method = NULL` (the default) and there are fewer than 1,000
#'   observations.
#' @param n Number of points at which to evaluate smoother.
#' @param method.args List of additional arguments passed on to the modelling
#'   function defined by `method`.
#' @section Computed variables:
#' `stat_smooth()` provides the following variables, some of which depend on the orientation:
#' \describe{
#'   \item{y *or* x}{predicted value}
#'   \item{ymin *or* xmin}{lower pointwise confidence interval around the mean}
#'   \item{ymax *or* xmax}{upper pointwise confidence interval around the mean}
#'   \item{se}{standard error}
#' }
#' @export
#' @rdname geom_smooth
stat_smooth <- function(mapping = NULL, data = NULL,
                        geom = "smooth", position = "identity",
                        ...,
                        method = NULL,
                        formula = NULL,
                        se = TRUE,
                        n = 80,
                        span = 0.75,
                        fullrange = FALSE,
                        level = 0.95,
                        method.args = list(),
                        na.rm = FALSE,
                        orientation = NA,
                        show.legend = NA,
                        inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = StatSmooth,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      method = method,
      formula = formula,
      se = se,
      n = n,
      fullrange = fullrange,
      level = level,
      na.rm = na.rm,
      orientation = orientation,
      method.args = method.args,
      span = span,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatSmooth <- ggproto("StatSmooth", Stat,
  setup_params = function(data, params) {
    params$flipped_aes <- has_flipped_aes(data, params, ambiguous = TRUE)
    msg <- character()
    if (is.null(params$method) || identical(params$method, "auto")) {
      # Use loess for small datasets, gam with a cubic regression basis for
      # larger. Based on size of the _largest_ group to avoid bad memory
      # behaviour of loess
      max_group <- max(table(interaction(data$group, data$PANEL, drop = TRUE)))

      if (max_group < 1000) {
        params$method <- "loess"
      } else {
        params$method <- "gam"
      }
      msg <- c(msg, paste0("method = '", params$method, "'"))
    }

    if (is.null(params$formula)) {
      if (identical(params$method, "gam")) {
        params$formula <- y ~ s(x, bs = "cs")
      } else {
        params$formula <- y ~ x
      }
      msg <- c(msg, paste0("formula '", deparse(params$formula), "'"))
    }
    if (identical(params$method, "gam")) {
      params$method <- mgcv::gam
    }

    if (length(msg) > 0) {
      message("`geom_smooth()` using ", paste0(msg, collapse = " and "))
    }

    params
  },

  extra_params = c("na.rm", "orientation"),

  compute_group = function(data, scales, method = NULL, formula = NULL,
                           se = TRUE, n = 80, span = 0.75, fullrange = FALSE,
                           xseq = NULL, level = 0.95, method.args = list(),
                           na.rm = FALSE, flipped_aes = NA) {
    data <- flip_data(data, flipped_aes)
    if (length(unique(data$x)) < 2) {
      # Not enough data to perform fit
      return(new_data_frame())
    }

    if (is.null(data$weight)) data$weight <- 1

    if (is.null(xseq)) {
      if (is.integer(data$x)) {
        if (fullrange) {
          xseq <- scales$x$dimension()
        } else {
          xseq <- sort(unique(data$x))
        }
      } else {
        if (fullrange) {
          range <- scales$x$dimension()
        } else {
          range <- range(data$x, na.rm = TRUE)
        }
        xseq <- seq(range[1], range[2], length.out = n)
      }
    }

    # Special case span because it's the most commonly used model argument
    if (identical(method, "loess")) {
      method.args$span <- span
    }

    if (is.character(method)) {
      if (identical(method, "gam")) {
        method <- mgcv::gam
      } else {
        method <- match.fun(method)
      }
    }
    # If gam and gam's method is not specified by the user then use REML
    if (identical(method, mgcv::gam) && is.null(method.args$method)) {
      method.args$method <- "REML"
    }

    base.args <- list(quote(formula), data = quote(data), weights = quote(weight))
    model <- do.call(method, c(base.args, method.args))

    prediction <- predictdf(model, xseq, se, level)
    prediction$flipped_aes <- flipped_aes
    flip_data(prediction, flipped_aes)
  },

  required_aes = c("x", "y")
)


library(shiny)
library(leaflet)

# ==== HTML ====
shinyUI(fluidPage(
  titlePanel("Median Household Income in the United States"),

  # Median Household Income Data
  fluidRow(
    p('The US median household income distribution has a strong right skew when
      counting at a town level, but looks much more symmetric when counting at
      a county level. A possible explanation for this is while more affluent
      households tend to live close together in the same town, the towns themselves
      are located in counties with a mixture of different levels of wealth. There
      are not a lot of "super counties" filled with entirely wealthy towns, although
      the small right skew on the county histogram shows they do exist.'),
    tabsetPanel(
      tabPanel("Towns",
        plotOutput("median_household_income")),
      tabPanel("Counties",
        plotOutput("median_household_income.county")
      )
    )
  ),

  # ==== Median Income of 25 Most Populous Cities ====
  fluidRow(
    h2("Median Household Income of 25 Most Populous Cities"),
    p("Apparently, the majority 25 most populous US cities
      median US household income line (indicated with a solid black line)."),
    plotOutput("mhhi_biggest_cities")
  ),

  # Median Income vs. Housing Price
  fluidRow(
    h3("Median Household Income vs. Housing Prices"),
    p(HTML(
      "While some cities have higher earners than others, does this translate
      to an increase in purchasing power? Here, median household income was paired
      with home prices (courtesy of
      Zillow). The median price per square foot of a single-family residence
      was used to compare different cities. This value was averaged across 12 months
      from July 2015 to June 2016 to lessen the effect of potential seasonal
      variation and other random shocks. Unfortunately, six of the twenty-five cities
      could not be included in this analysis because there was no straightforward
      Zillow data available for that city.")),
    p(HTML(
      'After this was done, San Francisco appeared as a large outlier. While the median
      San Francisco household earns more than twice as much than—for example—
      the median Philadelphia household, it pays disproportionately much more for a home.
      Thus, there is a bar chart under "San Francisco Money" which shows how
      much square footage a median household in a city could hypothetically afford if they had
      the income of a median San Francisco household.')),
    tabsetPanel(
      tabPanel("Income vs. Housing Price", plotOutput("top_25_scatter")),
      tabPanel("Bar Chart", plotOutput("top_25_bar.inc_vs_home")),
      tabPanel("San Francisco Money",
               plotOutput("top_25_bar.sf_vs_home"))
    )
  ),

  # ==== Map ====
  fluidRow(
    h2("Map"),
    p("The blue markers represented the 25 richest counties in the United States when
      ranked by median household income. As we can see, a large number of those are clustered
      around our nation's capital. Furthermore, the only markers on the West Coast all
      belong counties in the San Francisco Bay Area."),

    # Dataset
    selectInput("map_dataset", "Dataset",
                c("ACS 5-Year Estimates",  # <-- Default
                  "ACS 1-Year Estimates")),

    # Option to change year: Default ACS 5-Year
    selectInput("map_year", "Year", ACS_5YR_RANGE),

    # Map
    leafletOutput("mhhi_map")
  ),

  # Median Income Table Output
  fluidRow(
    h2("Data Explorer"),
    p("Do you have any more lingering questions about the distribution of income
      in the United States? Want to find out how rich your home town is? This data
      explorer has access to the median household income of every US town and county
      (when viewing ACS 5-Year Estimates)."),
    h3("Comparing Change Between Years"),
    p("You may have noticed that the years for which data is available is spaced out.
      This is because consecutive ACS surveys contain overlapping samples,
      making comparisons unreliable."),
    h3("Notes"),
    p(HTML("

MoE = 'Margin of Error'

All figures are in 2016 inflation-adjusted dollars using annual average
                  values of the CPI for all urban consumers

")),

    # Median Income Table Options
    selectInput("mhhi_table",
                "Data Set",
                c("Towns (ACS 2015 5-Year Estimates)",
                  "Counties (ACS 1-Year Estimates)",
                  "Counties (ACS 5-Year Estimates)")
                ),

    dataTableOutput("mhhi_table")
  )
))


xtable_lme = function(lme_model_name){

  #'  Create a cleaner lme4 model output for
  #'  printing with xtable.
  #'
  #'  Parameters
  #'  ----------
  #'  lme_model_name : lme4 model
  #'     Model whose output will be cleaned.
  #'
  #'  Output
  #'  ------
  #'  neat_output : table
  #'     Cleaned lme4 model output.

  # load in pander
  library(pander)
  library(dplyr)
  library(xtable)

  # disable scientific notation
  options(scipen = 999)

  # convert the model summary to a dataframe
  neat_output = data.frame(summary(lme_model_name)$coefficient)

  # round p-values (using Psychological Science's recommendations)
  neat_output$p = 2*(1-pnorm(abs(neat_output$t.value)))
  neat_output$p[neat_output$p < .0005] = round(neat_output$p[neat_output$p < .0005],4)
  neat_output$p[neat_output$p >= .0005] = round(neat_output$p[neat_output$p >= .0005],3)
  neat_output$p[neat_output$p >= .25] = round(neat_output$p[neat_output$p >= .25],2)

  # create significance and trending markers
  neat_output$sig = ' '
  neat_output$sig[neat_output$p < .1] = '.'
  neat_output$sig[neat_output$p < .05] = '*'
  neat_output$sig[neat_output$p < .01] = '**'
  neat_output$sig[neat_output$p < .001] = '***'

  # remove unneeded variables
  neat_output = select(neat_output, -Std..Error, -t.value)

  # fix printed names
  setDT(neat_output, keep.rownames = TRUE)[]
  names(neat_output)[1] = ""
  names(neat_output)[2] = "Estimate"
  names(neat_output)[3] = "p-value"
  names(neat_output)[4] = "Sig."

  # return the table
  return(neat_output)
}


#!/usr/bin/env Rscript

# this script converts a Connecticut model to the Hartford version
# and sets it up ready for parameter estimation

library(tidyverse)
library(CoRC)

# read experimental data
datafile = "CT-Hartford-COVID19.tsv"
data_experimental <-  read_tsv(datafile)

# serial number of the day of this iteration, in the last row of data file
today <- as.double( data_experimental$'#day'[NROW(data_experimental)])

# which models to process
modelnos <- c(7,11,14)

pathto <- getwd()

# deal with each model
for (modelno in modelnos)
{
  #get model
  modelfname <- sprintf("../SIDARTHE-CT_Model%d.cps",modelno)
  newmodelfname <- sprintf("SIDARTHE-CT-Hartford_Model%d-%d.cps",modelno,today)
  loadModel(modelfname)
  # change the name
  mname <- sprintf("SIDARTHE Hartford Model %d",modelno)
  setModelName(mname)
  # change the total population
  setGlobalQuantities("Population", initial_value = 894014)
  # add species UCH
  newSpecies("UCH", type = "reactions", initial_concentration = 0)
  # set I and A back to zero
  setSpecies("I", initial_concentration = 0)
  setSpecies("A", initial_concentration = 0)
  # update the conservation relation
  cons <- paste0(getSpecies("S")$initial_expression,"-{[UCH]_0}")
  setSpecies("S", initial_expression = cons)
  # add rate constant for progression to UCH
  newGlobalQuantity("mu_UCH", type = "fixed", initial_value = getValue(quantity_strict("mu", reference="InitialValue")) )
  # add new quantity for total hospitalized
  th1 = species_strict("T",reference = "Concentration")
  th2 = species_strict("UCH", reference = "Concentration")
  th =  paste(th1,th2,sep="+")
  newGlobalQuantity("Total_Hospitalized", type = "assignment", expression = th )
  # add global quantity for zero day
  newGlobalQuantity("ZeroDay", type = "fixed", initial_value = 0.1 )
  muuchval <- quantity_strict("mu_UCH", reference = "Value")
  # add reactions for UCH
  newReaction("A -> UCH", name = "critical_A_UCH", fun = "Mass action (irreversible)",
              mappings = list(k1 = "mu_UCH" ) )
  newReaction("R -> UCH", name = "critical_R_UCH", fun = "Mass action (irreversible)",
              mappings = list(k1 = "mu_UCH" ) )
  newReaction("UCH -> E", name = "death_UCH", fun = "Mass action (irreversible)",
              mappings = list(k1 = "tau" ) )
  newReaction("UCH -> H", name = "healing_UCH", fun = "Mass action (irreversible)",
              mappings = list(k1 = "sigma" ) )

  # add new event for introduction of infected
  newEvent("Seeding", trigger_expression = "{Time}>{Values[ZeroDay]}", assignment_target = c("I"), assignment_expression = c("1"))

  # setup parameter estimation
  clearParameterEstimationParameters()
  clearExperiments()

  data_pe <- data_experimental %>% rename("time" = "#day") %>% set_tidy_names(TRUE)

 types = c("time", "dependent", "dependent", "dependent", "ignore", "dependent", "ignore")
  mappings = c( "{Time}", "{Values[Diagnosed Cumulative infected]}", "{Values[Total_Hospitalized]}", "{[UCH]}", NA, "{[E]}", NA)
  data_pe <- data_pe[, types != "ignore"]
  mappings <- mappings[types != "ignore"]
  types <- types[types != "ignore"]

  outputdatafile <- sprintf("CT-Hartford-COVID19-%d-%d.tsv",modelno,today)
  # define the experiment with the Hartford data set
  fit_experiments <- defineExperiments(
    experiment_type = "time_course",
    data = data_pe,
    type = types,
    mapping = mappings,
    weight_method = "mean_square",
    filename = outputdatafile
  )

  # define the parameters to fit
  p1 <- defineParameterEstimationParameter(quantity_strict("ZeroDay", "InitialValue"), start_value = 1, lower_bound = 0, upper_bound = 15)
  p2 <-defineParameterEstimationParameter(quantity_strict("mu_UCH", "InitialValue"), start_value = getGlobalQuantities("mu_UCH")$initial_value, lower_bound = 1e-6, upper_bound = getGlobalQuantities("mu")$initial_value)
  val = getGlobalQuantities("day8x")$initial_value
  p3 <- defineParameterEstimationParameter(quantity_strict("day8x", "InitialValue"), start_value = val, lower_bound = val*0.7, upper_bound = 1)
  val = getGlobalQuantities("day15")$initial_value
  #up = quantity_strict("day8x",  reference = "Value")
  up = getGlobalQuantities("day8x")$initial_value
  p4 <- defineParameterEstimationParameter(quantity_strict("day15x", "InitialValue"), start_value = val, lower_bound = val*0.7, upper_bound = up)
  val = getGlobalQuantities("tau")$initial_value
  p5 <- defineParameterEstimationParameter(quantity_strict("tau", "InitialValue"), start_value = val, lower_bound = val*0.7, upper_bound = val*1.3)
  val = getGlobalQuantities("theta")$initial_value
  p6 <- defineParameterEstimationParameter(quantity_strict("theta", "InitialValue"), start_value = val, lower_bound = val*0.7, upper_bound = val*1.3)
  val = getGlobalQuantities("f_epsilon")$initial_value
  p7 <- defineParameterEstimationParameter(quantity_strict("f_epsilon", "InitialValue"), start_value = val, lower_bound = val*0.7, upper_bound = val*1.3)

  setPE(parameters = list(p1,p2,p3,p4,p5,p6,p7), experiments = list(fit_experiments))

  saveModel(newmodelfname)
  unloadModel()
}


.logsum <- function(x) {
    xmax <- which.max(x)
    log1p(sum(exp(x[-xmax] - x[xmax]))) + x[xmax]
}

setClass('mvd.marginal')
setMethod('summary', 'mvd.marginal', function(object, ...) {
    cat("mvdens marginal distribution of type:", object$type, "\n")
    if (object$type == "ecdf") {
        cat("  Bandwidths:\n")
        for (i in 1:length(object$bw)) {
            cat("   ", object$varnames[i], "-", object$bw[i], "\n")
        }
    } else if (object$type == "parametric") {
      for (i in 1:length(object$dists)) {
        cat("   ", object$dists[[i]]$name, "-", object$dists[[i]]$type, "\n")
      }
    } else if (object$type == "mixture") {
      for (i in 1:length(object$dists)) {
        cat("   ", object$dists[[i]]$name, "-", object$dists[[i]]$type, "- p:", paste(object$dists[[i]]$p, collapse = ","), "\n")
      }
    }
})

setClass('mvd.density')
setMethod('summary', 'mvd.density', function(object, ...) {
  cat("mvdens density approximation of type:", object$type, "\n")
  if (object$type == "kde") {
    cat("  Bandwidth matrix:")
    str(object$H)
    cat("\n")
  } else if (object$type == "kde.transformed") {
    cat("  Transformations:\n")
    for (i in 1:length(object$transform.bounds)) {
      cat("   ", i, "-", .mvd.transform_name(object$transform.bounds, i), "\n")
    }
    cat("  Bandwidth matrix:")
    str(object$H)
    cat("\n")
  } else if (object$type == "gmm") {
  } else if (object$type == "gmm.transformed") {
  } else if (object$type == "gmm.truncated") {
  } else if (object$type == "gp") {
      cat("  kernel=", object$kernel, "l = ", object$l, ", s := ", object$s, " \n")
    } else if (object$type == "vine.copula") {
    }
})


#  James Rekow

#  I just returned the fractured abdList in the beginning of the program
abdList = marginalDissDensity(M = 80, thresholdMult = 10 ^ (-3))

#  convert abd list to a matrix, each row is an abundance vector, so the columns are the abundances of a
#  given species
mat = Reduce(rbind, abdList)

h(101)

#  identify clusters using kmeans algorithm, standardizing cluster labels so that sample 1 is always in
#  cluster 1
f = function(x = NULL){
  kmr = kmeans(x = mat, centers = 2, iter.max = 1000, nstart = 10)$cluster
  if(kmr[1] == 2){
    a = kmr == 2
    kmr[a] = 1
    kmr[!a] = 2
  }
  return(kmr)
}

g = function(n){
  kmrMat = replicate(n, f())
  kmrAgg = apply(kmrMat, 1, numMode)
  return(which(kmrAgg == 1))
}

h = function(n){
  gr = g(n)
  a = sum((1:40) %in% g(n))
  b = sum((41:80) %in% g(n))
  return(c(a, b))
}


################################################################################
# Dependencies
# library("glmnet")
# .5097359 with RF Impute
GlmnetTrain <- function(train.name="train",target=NULL,args=list(test.name=NULL,
		R=1,pls=FALSE,prune=FALSE,std=FALSE,features=c("static","alsfrs","fvc",
		"svc","vital"),slope.features=NULL)) {
	# Trains a LASSO regression model to given training data and returns a function
	# that returns predictions given test data
	#
	# Args:
	#	train.name: base name of training dataset
	#	target: target vector; if NULL, future slopes are used as target
	#	args: list of additional arguments
	#	-test.name: base name of test set, if you want training set to be
	#	 processed using both test and train data
	#   - R: number of models to train; final predictions formed
	#        by averaging across model predictions
	#	- pls: TRUE means predicting the last score rather than the slope
	#	- prune: TRUE means keeping only features with data for at least 918/2
	#		patients
	#	- std: TRUE means standardize columns by subtracting away column means
	#	- features: a character vector of feature sets to get for the training
	#		data.  Choose from "static","alsfrs","fvc","svc","vital","lab"
	#	- slope.features: a character vector of datasets to get slope features
	#		for.  Choose from NULL if no slopes are desired, or among "static",
	#		"alsfrs","fvc","svc","vital","lab"
	#
	#
	# Returns:
	#	A function that returns predictions given test data
	#
	# Example usage:
	if (FALSE) {
		features = c("static","alsfrs","fvc","svc","vital")
	   	slope.features = c("alsfrs","fvc","svc","vital")
	   	args=list(test.name="test",R=1,pls=FALSE,prune=TRUE,std=FALSE,
	   		features=features,slope.features=slope.features)
		model <- GlmnetTrain(train.name="train",target=NULL,args=args)
		predictions<-model("test")
	}
	############################################################################

	# Preprocess training data according to arguments
	train.preprocess<-PreprocessFeatures(train.name=train.name,test.name=
		args[["test.name"]],args=args)

	# Get training data
	train.data<-train.preprocess$feature.data

	# Add onset interactions
	# onset.delta.x<-train.data[,-1]*train.data[,colnames(train.data)=="Onset.Delta"]
	# colnames(onset.delta.x)<-paste(colnames(train.data)[-1],"interact")
	# train.data<-cbind(train.data,onset.delta.x)

	target<-train.preprocess$target

	# Drop constant columns
	train.data<-train.data[,apply(train.data,2,function(c)length(unique(c))>1)]

	# Fit multiple models to training data
	GetModel <- function(i) {
		# Use cross-validation to choose Lasso parameter
		cv.res <- cv.glmnet(as.matrix(train.data[,-1]), target)
		print(sprintf("Model: %d, CV error: %g, lambda: %g",i,sqrt(min(cv.res$cvm)),
			cv.res$lambda.min))
		return(list(object = cv.res$glmnet.fit, param = cv.res$lambda.min))
	}
	models <- lapply(1:args[["R"]], GetModel)

	GlmnetPredict <- function(test.name="test",save.preds=TRUE) {
		# Predicts slopes using a LASSO regression fit to static training data.
		#
		# Args:
		#	test.name: base name of test set
		#   save.preds: save predictions to file? TRUE by default
		#
		# Returns:
		#	Two column matrix, ordered by the first column, with first column
		#   "subject.id" containing test set subject ids and the second column
		#   "prediction" containing predicted slopes.
		#
		# Side effects:
		#	Saves predictions to file

		# Preprocess test data according to arguments
		test.preprocess<-PreprocessFeatures(train.name=NULL,test.name=test.name,
			args=args,train.cols=train.preprocess$train.cols,train.data.std=
			train.preprocess$train.data.std,train.data.na=
			train.preprocess$train.data.na)

		test.data<-test.preprocess$feature.data

		# Match train columns
		test.data<-test.data[,colnames(train.data)]

		# Add onset interactions
		# onset.delta.x<-test.data[,-1]*test.data[,colnames(test.data)=="Onset.Delta"]
		# colnames(onset.delta.x)<-paste(colnames(test.data)[-1],"interact")
		# test.data<-cbind(test.data,onset.delta.x)

		# Form test predictions
		predictions <- rowMeans(sapply(models, function(model) predict(
			model$object,as.matrix(test.data[,-1]),s=model$param)))

		# If predicting last score, transform predictions back to slopes
		if (args[["pls"]]) {
			scaling<-PlsScale(test.name)
			predictions<-predictions-
				scaling$score.first*scaling$time.scale
		}
		predictions <- cbind(test.data[,1],predictions)

		if(save.preds) {
			# Write predictions to file
			out.file = GetPredictionFilename("GlmnetTrain",train.name,test.name,args)
			WritePredictions(predictions, out.file)
		}

		return(predictions)
	}

	return(GlmnetPredict)
}