validate_token <- function(session) {
  tokens = readLines('.valid_tokens')
  qs = paste0(session$clientData$url_search, session$clientData$url_hash)
  query <- parseQueryString(qs)
  if (!query$token %in% tokens) stop("Close session due to invalid token")
}

prepare_topic_scores <- function(data, topic_groups) {
  print('topic scores update')
  meta_cols = c('doc_id','medium','headline','date')
  topic_scores = data$m$theta
  colnames(topic_scores) = paste0('topic_', 1:ncol(topic_scores))
  topic_scores = group_matrix(topic_scores, topic_groups)
  topic_scores = data.table::as.data.table(topic_scores)
  topic_scores = cbind(data$tc$get_meta(columns = meta_cols), topic_scores)
  data.table::setindexv(topic_scores, c('medium','date'))
}

get_children <- function(tg, parents, done=parents) {
  .parents = parents
  children = unique(tg[list(parent=.parents),,on='parent',nomatch=0]$child)
  children = setdiff(children, done)
  done = union(parents,children)
  if (length(children) == 0) return(numeric())
  union(children, get_children(tg, children, done=done))
}

group_matrix <- function(m, topic_groups, only_return_top=F) {
  for (parent in unique(topic_groups$parent)) {
    children = get_children(topic_groups, parent)
    if (length(children) > 0) {
      topcols =
      m[,parent] = m[,parent] + Matrix::rowSums(m[,children,drop=F])
    }
  }
  if (only_return_top) {
    own_parent = unique(topic_groups$parent[topic_groups$parent == topic_groups$child])
    m = m[,own_parent]
  }
  m
}

create_meta_table <- function(session, input, data, topic_filter, topic_scores) {
  if (length(topic_filter) == 0) return(NULL)
  print('meta update')

  meta_cols = c('doc_id','medium','headline','date')
  meta_table = subset(topic_scores, select = colnames(topic_scores) %in% c(meta_cols, topic_filter))

  if (length(input$media_filter) > 0)
    meta_table = meta_table[list(medium=input$media_filter),,on='medium']

  if (length(input$query_filter) > 0) {
    hits = tryCatch(corpustools::search_contexts(data$tc, input$query_filter),
             error = function(e) NULL)
    if (is.null(hits)) hits = drop_bad_queries(session, input, data)
    if (is.null(hits)) return(NULL)
    .doc_ids = unique(hits$hits$doc_id)
    meta_table = meta_table[list(doc_id=.doc_ids),,on='doc_id']
  }

  if (nrow(meta_table) == 0) return(NULL)

  meta_table
}

drop_bad_queries <- function(session, input, data) {
  n = length(input$query_filter)
  is_bad = vector(length=n)
  for (i in 1:n) {
    q = input$query_filter[i]
    hits = tryCatch(corpustools::search_contexts(data$tc, q), error = function(e) NULL)
    if (is.null(hits)) is_bad[i] = T
  }
  if (any(is_bad)) {
    bad_queries = input$query_filter[is_bad]
    bad_queries = gsub('\\# .*', '', bad_queries)
    print('alert?')
    shinyalert::shinyalert('Incorrecte zoektermen', sprintf('De volgende zoektermen zijn incorrect gespecificeerd:\n\n%s\n\nDeze termen zijn nu gedeactiveerd in de zoektermen filter.', paste(bad_queries, collapse='\n')))
    shinyWidgets::updatePickerInput(session, 'query_filter', selected= input$query_filter[!is_bad])
    if (all(is_bad)) return(NULL)
  }
  corpustools::search_contexts(data$tc, input$query_filter[!is_bad])
}

create_graph_data <- function(input, meta_table) {
  if (is.null(meta_table)) {
    return(NULL)
  }
  print('graph data update')
  graph_data = subset(meta_table, select = !colnames(meta_table) %in% c('date','headline','doc_id','medium'))
  if (input$aggregate == 'day') graph_data$agg_date = as.Date(meta_table$date)
  if (input$aggregate == 'week') graph_data$agg_date = as.Date(cut(meta_table$date, breaks = 'weeks'))
  if (input$aggregate == 'month') graph_data$agg_date = as.Date(cut(meta_table$date, breaks = 'months'))

  graph_data = as.data.table(graph_data)
  agg = graph_data[, lapply(.SD, sum), by='agg_date']

  data.table::setorderv(agg, 'agg_date')
  agg[is.na(agg)] = 0
  subset(agg, select = !colnames(agg) == 'topic_mix')
}

create_graph <- function(input, data, graph_data, topic_filter, topic_names, topic_colors) {
  if (is.null(graph_data)) {
    return(NULL)
  }

  print('create graph')
  if (input$dateselect != 'vrij') {
    mindate = as.Date(graph_data$agg_date[1])
    enddate = as.Date(graph_data$agg_date[nrow(graph_data)])
    if (input$dateselect == 'week') startdate = enddate - 7
    if (input$dateselect == 'maand') startdate = enddate - 30
    if (input$dateselect == 'jaar') startdate = enddate - 365
    if (input$dateselect == 'alles') startdate = mindate
    if (startdate < mindate) startdate = mindate
    datewindow = c(startdate, enddate)
  } else {
    isolate(
      if (!is.null(input$dategraph_date_window)) datewindow = as.Date(input$dategraph_date_window)
    )
  }

  color = if (length(topic_filter) > 0) as.character(unlist(topic_colors[topic_filter])) else as.character(unlist(topic_colors))
  color = substr(color, start = 0, stop = 7)

  selected_topics = colnames(graph_data)[-1]
  selected_topics_i = as.numeric(gsub('topic_','',selected_topics))
  colnames(graph_data)[-1] = topic_names[selected_topics_i]

  dygraphs::dygraph(graph_data, main = 'Aandacht voor topics over tijd') %>%
    dygraphs::dyRangeSelector(retainDateWindow=F, height=30, dateWindow = datewindow,
                              fillColor = " #A7B1C4", strokeColor = "#808FAB", keepMouseZoom = T) %>%
    dygraphs::dyUnzoom() %>%
    dygraphs::dyLegend(labelsDiv = 'legend', show='always', showZeroValues = F, labelsSeparateLines = T) %>%
    dygraphs::dyOptions(useDataTimezone = T, colors=color)

}

parse_url_queries <- function(session, output) {
  qs = isolate(paste0(session$clientData$url_search, session$clientData$url_hash))
  query <- parseQueryString(qs)
  queries = if (is.null(query$amcat_queries)) NULL else utils::URLdecode(query$amcat_queries)
  #output$sb_imported_queries = renderText(queries)
  queries
}

set_widget_defaults <- function(session, data) {
  mindate = min(as.Date(data$tc$meta$date))
  maxdate = max(as.Date(data$tc$meta$date))
  updateDateRangeInput(session, 'daterange', start= mindate, end=maxdate)

  media = sort(unique(data$tc$meta$medium))
  shinyWidgets::updatePickerInput(session, inputId = 'media_filter', choices = as.list(media))
}

set_topic_names <- function(session, input, data, topic_names, topic_groups) {
  isolate({current_selection = input$topic_filter})

  valid_choices = unique(topic_groups$parent)
  valid_choices = intersect(valid_choices, paste('topic', data$topic_selection, sep='_'))
  l = as.list(valid_choices)
  names(l) = topic_names[as.numeric(gsub('topic\\_','',valid_choices))]
  #l = as.list(paste0('topic_', 1:length(topic_names)))
  #names(l) = topic_names

  new_selection = intersect(current_selection, valid_choices)

  shinyWidgets::updatePickerInput(session, inputId = 'topic_filter', choices = l, selected=new_selection)
}

save_topic_names <- function(session, input, data, topic_names) {
  selected_topic = input$sb_select_topic
  selected_topic_i = as.numeric(gsub('topic_','',selected_topic))
  topic_names[selected_topic_i] = input$sb_rename_topic
  saveRDS(topic_names, file=data$topic_names_file)
}

save_topic_color <- function(session, input, data, topic_colors) {
  selected_topic = input$sb_select_topic
  selected_topic_i = as.numeric(gsub('topic_','',selected_topic))
  topic_colors[selected_topic_i] = input$sb_color_topic
  saveRDS(topic_colors, file=data$topic_colors_file)
}

save_topic_groups <- function(session, output, input, data, topic_names, topic_groups) {
  .children = input$sb_group_topic
  .rm_children = topic_groups[list(parent = input$sb_select_topic),,on='parent']$child
  .rm_children = setdiff(.rm_children, .children)

  if (length(.children) > 0)
    topic_groups[list(child = .children), parent := input$sb_select_topic, on='child']
  if (length(.rm_children) > 0)
    topic_groups[list(child = .rm_children), parent := child, on='child']

  valid_choices = unique(topic_groups$parent)
  choices = as.list(valid_choices)
  names(choices) = topic_names[as.numeric(gsub('topic\\_','',valid_choices))]
  new_selection = intersect(input$topic_filter, valid_choices)
  shinyWidgets::updatePickerInput(session, inputId = 'topic_filter', choices = choices, selected=new_selection)

  output$save_groups_button = renderUI(NULL)
  saveRDS(topic_groups, file=data$topic_groups_file)
}

save_queries <- function(session, output, input, data) {
  queries = input$sb_queries
  saveRDS(queries, file=data$queries_file)
  output$save_queries_button = renderUI(NULL)
}

on_select_topic <- function(session, output, input, data, topic_names, topic_colors, topic_groups) {
  selected_topic = input$sb_select_topic
  selected_topic_i = as.numeric(gsub('topic_','',selected_topic))

  output$sb_top_words = renderText(paste(data$top_terms$frex[selected_topic_i,], collapse=', '))
  #output$sb_top_words_lift = renderText(paste(head(data$top_terms$lift[,selected_topic_i], 10), collapse=', '))
  updateSearchInput(session, 'sb_rename_topic', value='')
  colourpicker::updateColourInput(session, 'sb_color_topic', value=topic_colors[[selected_topic]])

  parent = topic_groups[list(child = selected_topic),,on='child']$parent
  if (parent == selected_topic)
    output$in_group = renderText('')
  else {
    parent_i = as.numeric(gsub('topic\\_','',parent))
    output$in_group = renderText(sprintf('Let op: Het topic "%s" is zelf al gegroepeerd onder topic "%s". Alle hier geselecteerde topics zullen daar ook onder gegroepeerd worden', topic_names[selected_topic_i], topic_names[parent_i]))
  }

  valid_choices = topic_groups$child[!topic_groups$child %in% c(selected_topic,parent)]
  choices = as.list(valid_choices)
  names(choices) = topic_names[as.numeric(gsub('topic\\_','',unlist(choices)))]
  selected = topic_groups[list(parent = selected_topic),,on='parent', nomatch=0]$child
  shinyWidgets::updateMultiInput(session, 'sb_group_topic', choices=choices, selected=selected)
}

update_sidebar_topic_names <- function(session, input, topic_names) {
  l = as.list(paste0('topic_', 1:length(topic_names)))
  names(l) = topic_names

  selected_topic = input$sb_select_topic
  selected_topic_i = as.numeric(gsub('topic_','',selected_topic))

  updateSelectizeInput(session, 'sb_select_topic', choices=l, selected=l[[selected_topic_i]])
}

update_query_widgets <- function(session, input, imported_queries, queries) {
  updateTextAreaInput(session, 'sb_queries', value = queries)
  queries = rbind(parse_queries(imported_queries),
                  parse_queries(queries))
  dup_i = match(queries$code, unique(queries$code))

  if (nrow(queries) > 0) {
    queries$code = as.character(queries$code)
    queries$code = stringi::stri_trim(queries$code)
    queries$code = unique_label(queries$code)
  }

  l = as.list(paste(queries$code, queries$query, sep='# '))
  names(l) = queries$code
  current_selection = gsub('# .*', '', input$query_filter) %in% queries$code
  current_selection = input$query_filter[current_selection]
  shinyWidgets::updatePickerInput(session, inputId = 'query_filter', choices = l, selected=current_selection)
}

unique_label <- function(x) {
  x = as.character(x)
  dup_str = paste0(x, '#', 1)
  i = 2
  while(TRUE){
    dupl = duplicated(dup_str)
    if (any(dupl)) {
      dup_str[dupl] = paste0(dup_str[dupl], '#', i)
      i = i + 1
    } else break
  }
  dup_i = as.numeric(gsub('.*#','',dup_str))
  ifelse(dup_i > 1, sprintf('%s (%s)', x, dup_i), x)
}

parse_queries <- function(query_txt) {
  if (is.null(query_txt)) return(NULL)
  queries_txt = strsplit(query_txt, '\n')[[1]]
  queries_txt = queries_txt[grepl('#', queries_txt)]
  data.frame(code = gsub('#.*','', queries_txt),
             query = gsub('.*# *', '', queries_txt))
}

#sidebar_topic_names <- function(session, input, data) {
#  ntopics = ncol(data$m$theta)
#  topic_names = character(ntopics)
#  for (i in 1:ntopics) {
#    id = paste0('topic_', i)
#    topic_names[i] = input[[id]]
#  }
#  topic_names
#}

create_topic_colors <- function(k) {
  ## default topic colors, only made at first run
  colors = as.list(grDevices::rainbow(k+1)[-1])
  names(colors) = paste0('topic_', 1:k)
  colors
}

create_topic_groups <- function(k) {
  ## default topic merges (that is, no mergers), only made at first run
  data.table::data.table(parent = paste0('topic_', 1:k),
                         child = paste0('topic_', 1:k))
}

is_datepreset <- function(graph_data, datewindow) {
  mindate = as.Date(graph_data$agg_date[1])
  enddate = as.Date(graph_data$agg_date[nrow(graph_data)])

  if (datewindow[2] == enddate) {
    if (datewindow[1] == enddate - 7) return('week')
    if (datewindow[1] == enddate - 30) return('maand')
    if (datewindow[1] == enddate - 365) return('jaar')
    if (datewindow[1] == mindate) return('alles')
  }
  return('vrij')
}

create_articlelist_data <- function(input, data, topic_filter, meta_table, daterange) {
  if (is.null(meta_table)) return(NULL)

  m = subset(meta_table, select = c('doc_id','medium','date','headline', topic_filter))
  m$date = as.Date(m$date)

  if (!is.null(daterange)) {
    daterange = as.Date(daterange)
    if (input$aggregate == 'week') daterange[2] = daterange[2] + 6
    if (input$aggregate == 'month') daterange[2] = month_ceiling(daterange[2])
    date_seq = seq.Date(daterange[1], daterange[2], by = 1)
    date_seq = rev(date_seq)   ## lastest date first
    m = m[list(date=date_seq),on='date', nomatch=0]
  }

  if (nrow(m) == 0) NULL else {
    ## if multiple topics are selected, documents with lowest max are mixture topics
    if (length(topic_filter) == 1)
      m$topic_mix = m[,5]
    else {
      m$topic_mix = apply(m[,5:ncol(m)], 1, mixture_score)
    }
    m = m[order(-m$topic_mix),]
    subset(m, select=c('doc_id','medium','date','headline', topic_filter))
  }
}

mixture_score <- function(x) {
  ## given the topic proportions for a selection of topics, rank documents on:
  ## 1. being most defined by the selection of topics (i.e. the sum of proportions)
  ## 2. in case of multiple topics, prioritize mixtures
  sum(x) - sd(x)
}

create_articlelist <- function(data, articlelist_data, topic_colors) {
  if (is.null(articlelist_data)) return(NULL)

  js <- "function(data, type, full){ return '' + data + '' }"
  colDefs <- list(list(targets = 4, render = DT::JS(js)))

  topic_colors = topic_colors[colnames(articlelist_data)[5:ncol(articlelist_data)]]
  bar_string <- sprintf("type: 'bar', height: '40px', colorMap: [%s], highlightColor: 'black'", paste(paste0("'", topic_colors, "'"), collapse=','))
  cb_bar <- DT::JS(paste0("function (oSettings, json) { $('.spark:not(:has(canvas))').sparkline('html', { ",
                          bar_string, " }); }"), collapse = "")

  d = articlelist_data[,-1]  ## drop doc_id
  if (ncol(d) == 4)
    sparkline = paste0(d[[4]],',0')
  else
    sparkline = as.character(apply(round(d[,4:ncol(d)], 3), 1, paste, collapse=','))
  d = cbind(d[,1:3], topic=sparkline)
  DT::datatable(d, options=list(dom = 'tp', stateSave=T, columnDefs = colDefs, fnDrawCallback = cb_bar), selection='single')
}

month_ceiling <- function(x) {
  y = data.table::year(x)
  m = data.table::month(x)
  if (m == 12) {
    y = y + 1
    m = 1
  } else
    m = m + 1
  next_month = as.Date(sprintf('%s-%s-01', y, m))
  next_month - 1
}

create_articles <- function(input, data, articlelist, topic_names, topic_colors) {
  if (is.null(articlelist)) return(NULL)
  if (is.null(input$articlelist_rows_selected)) return(NULL)
  ## option 1: get article index for table pagination
  #pag_start = input$articlelist_state$start
  #pag_end = pag_start + input$articlelist_state$length
  #art_i = (pag_start+1):pag_end
  #art_id = articlelist$doc_id[art_i]

  ## option 2: get selected article

  art_id = articlelist$doc_id[input$articlelist_rows_selected]

  tokens = data$tc$get(doc_id = art_id)
  #tokens$topic = as.character(topic_names[tokens$topic])
  tokens$topic = ifelse(is.na(tokens$topic), NA, paste0('topic_', tokens$topic))
  #token_label = na.omit(unique(tokens$topic))
  tokens$topic = factor(tokens$topic, na.omit(unique(tokens$topic)))
  meta = data$tc$get_meta(columns = c('doc_id','medium','headline','date'), doc_id = art_id)

  #topic_id = paste0('topic_', as.numeric(tokens$topic[!is.na(tokens$topic)]))
  col = as.character(unlist(topic_colors[levels(tokens$topic)]))
  col = substr(col, start = 0, stop = 7)

  ## switch topic_ids with topic_labels
  topic_i = as.numeric(gsub('topic_','',levels(tokens$topic)))
  levels(tokens$topic) = topic_names[topic_i]

  topicscore = ifelse(is.na(tokens$topicscore), 0, tokens$topicscore)
  topicscore = tokenbrowser::rescale_var(topicscore, new_min = 0.1, new_max=0.6)
  tokens$token = tokenbrowser::category_highlight_tokens(tokens$token, tokens$topic, alpha=topicscore, span_adjacent = T, colors = col, doc_id = tokens$doc_id)
  if ('space' %in% colnames(tokens)) tokens$token = paste(tokens$token, tokens$space, sep='')
  doc = tokenbrowser::wrap_documents(tokens, meta)

  #doc = gsub('<doc_id>.*</doc_id>', '<doc_id></doc_id>', doc)
  doc = gsub('(
) *(
)((
)| )+', '

', doc)
  doc = gsub('\\s', '', doc, fixed=T)
  doc
}

create_topwords_matrix <- function(data, topic_groups) {
  logbeta = data$m$beta$logbeta[[1]]
  logbeta = t(logbeta)
  colnames(logbeta) = paste0('topic_', 1:ncol(logbeta))
  logbeta = group_matrix(logbeta, topic_groups, only_return_top = T)
  exp(logbeta)
}

create_topwords <- function(data, topwords_matrix) {
  max_n=50
  #apply(topwords_matrix, 2, function(x) data$m$vocab[order(-x)[1:max_n]])
  wordcounts <- data$m$settings$dim$wcounts$x
  vocab = data$m$vocab
  frexlabels <- stm::calcfrex(log(t(topwords_matrix)), 0.5, wordcounts)
  apply(frexlabels, 2, function(x) vocab[head(x, max_n)])
}

create_wordcloud <- function(topic_filter, data, topic_names, topic_colors, top_words, top_words_matrix) {
  if (length(topic_filter) > 0) {
    n = max(10, 50 / length(topic_filter) )
    plot_topicwords(data, n, topics = topic_filter, topic_colors = topic_colors, topic_names=topic_names, top_words, top_words_matrix)
  } else NULL
}

plot_topicwords <- function(data, n, topics, topic_colors, topic_names, top_words, top_words_matrix) {
  selected_topics_i = as.numeric(gsub('topic_','',topics))

  words = top_words[1:n, selected_topics_i]
  words = data.frame(word = as.vector(t(words)),
                     topic = rep(selected_topics_i, each=n))
  words = words[!duplicated(words$word),]

  vocab_i = match(words$word, data$m$vocab)

  wordmat = top_words_matrix[vocab_i,paste("topic", selected_topics_i, sep='_'),drop=F]

  col = as.character(unlist(topic_colors[topics]))

  rownames(wordmat) = words$word
  colnames(wordmat) = topic_names[selected_topics_i]

  par(mar=c(0,0,0,0))
  set.seed(1)
  if (length(topics) == 1)
    wordcloud::wordcloud(words=rownames(wordmat), scale = c(2,0.7), freq = wordmat[,1], colors=col)
  else
    wordcloud::comparison.cloud(wordmat, scale = c(2,0.7), colors=col, title.size = 0.001)
}

save_graph <- function(session, g) {
  g = htmlwidgets::appendContent(g, shiny::br(), shiny::div(id='legend', style="margin-left:100px"))
  g$width = 1000
  g$height = 600
  user = if (is.null(session$user)) 'test' else session$user
  dir = file.path(tempdir(), user)
  if (!dir.exists(dir)) dir.create(dir, recursive=T)
  tf = file.path(dir, 'graph.html')
  tf2 = file.path(dir, 'graph.png')
  htmlwidgets::saveWidget(g, tf)
  webshot::webshot(tf, file=tf2)
  tf2
}


rm(list=ls())
library("shiny")
library("rhandsontable")
library("deSolve")
library("ggplot2")

if("ubiquity" %in% rownames(installed.packages())){require(ubiquity)} else
{source(file.path('library', 'r_general', 'ubiquity.R')) }

cfg = build_system(output_directory     = file.path(".", "output"),
                   temporary_directory  = file.path(".", "transient"))

Rmdfile = "system_report.Rmd"

# If you run the app, put in the values you want in terms of parameters and
# dosing then run the simulation it should save the following file with a
# snapshot of the values that will be sent into the report for generation:
load(file.path("transient", "app_base", "app_post_sim.RData"))
params = list()
params$cfg        = values$cfg
params$som        = values$som
params$parameters = values$parameters

# This is needed for debugging
cfg$options$misc$operating_environment = 'script'

rmarkdown::render(Rmdfile,
                  params        = params,
                  output_format = "html_document")


commandArgs()

for (e in commandArgs()) {
  ta = strsplit(e,"=",fixed=TRUE)
  if(! is.na(ta[[1]][2])) {
    temp = ta[[1]][2]
    if(substr(ta[[1]][1],nchar(ta[[1]][1]),nchar(ta[[1]][1])) == "I") {
      temp = as.integer(temp)
    }
    if(substr(ta[[1]][1],nchar(ta[[1]][1]),nchar(ta[[1]][1])) == "N") {
      temp = as.numeric(temp)
    }
    assign(ta[[1]][1],temp)
    cat("assigned ",ta[[1]][1]," the value of |",temp,"|\n")
  } else {
    assign(ta[[1]][1],TRUE)
    cat("assigned ",ta[[1]][1]," the value of TRUE\n")
  }
}

#### plus_plus
data_file <- sprintf("%s.bedpe.selected.intra-chrom.distance.plusplus.txt", filePrefix)
plusplus <- as.matrix(read.table(data_file))
#### plus_minus
data_file <- sprintf("%s.bedpe.selected.intra-chrom.distance.plusminus.txt", filePrefix)
plusminus <- as.matrix(read.table(data_file))
#### minus_plus
data_file <- sprintf("%s.bedpe.selected.intra-chrom.distance.minusplus.txt", filePrefix)
minusplus <- as.matrix(read.table(data_file))
#### minus_minus
data_file <- sprintf("%s.bedpe.selected.intra-chrom.distance.minusminus.txt", filePrefix)
minusminus <- as.matrix(read.table(data_file))

breaks <- c(-3E9, seq(-100000,100000,10), 3E9)
mids <- seq(-100000,100000-10,10) + 10/2

h.plusplus   <- hist(plusplus,   breaks=breaks)$counts
h.plusminus  <- hist(plusminus,  breaks=breaks)$counts
h.minusplus  <- hist(minusplus,  breaks=breaks)$counts
h.minusminus <- hist(minusminus, breaks=breaks)$counts
max_count <- max(c(h.plusplus, h.plusminus, h.minusplus, h.minusminus))

write.table(h.plusplus,   file="h.plusplus.binsize_10bp.txt")
write.table(h.plusminus,  file="h.plusminus.binsize_10bp.txt")
write.table(h.minusplus,  file="h.minusplus.binsize_10bp.txt")
write.table(h.minusminus, file="h.minusminus.binsize_10bp.txt")

distribution_diff <- h.minusplus - (h.plusplus + h.plusminus + h.minusminus)/3
write.table(distribution_diff, file="h.diff.binsize_10bp.txt")

hist_plot_file <- sprintf("%s.hist.binsize_10bp.png", filePrefix)
png(hist_plot_file, width = 960, height = 480)
plot(  mids, h.plusplus[2:20001], xlim=c(-100000,100000), ylim=c(1,max_count), xlab="pet span (bp)", ylab="frequency of pets", col="red", log="y")
points(mids, h.plusminus[2:20001],  col="green")
points(mids, h.minusplus[2:20001],  col="blue")
points(mids, h.minusminus[2:20001], col="black")
legend("topleft", c("plus,plus", "plus,minus", "minus,plus", "minus,minus"), col=c("red", "green", "blue", "black"))
dev.off()

indexes_1 <- 10001:20001
logMids <- log10(mids[indexes_1]+10/2)

hist_plot_file.loglog <- sprintf("%s.hist.loglog.binsize_10bp.png", filePrefix)
png(hist_plot_file.loglog, unit = "in", width = 7, height = 5, res = 300, pointsize = 4)
indexes <- (h.plusplus[indexes_1] > 0)
plot(  logMids[indexes], (h.plusplus[indexes_1])[indexes],  col="red", xlim=c(1.5,5), ylim=c(1,max_count), xlab="Pet span (bp)", ylab="frequency of pets", xaxt="n", log="y")
indexes <- (h.plusminus[indexes_1] > 0)
points(logMids[indexes], (h.plusminus[indexes_1])[indexes], col="green")
indexes <- (h.minusplus[indexes_1] > 0)
points(logMids[indexes], (h.minusplus[indexes_1])[indexes], col="blue")
indexes <- (h.minusminus[indexes_1] > 0)
points(logMids[indexes], (h.minusminus[indexes_1])[indexes], col="black")
axis(1, at=seq(-5,5,1), lab=c(-100000, -10000, -1000, -100, -10, 0, 10, 100, 1000, 10000, 100000))
legend("topleft", c("plus,plus", "plus,minus", "minus,plus", "minus,minus"), text.col=c("red", "green", "blue", "black"))
for (i in -4:4) {
    abline(v=i, lty="dashed")
}
dev.off()

indexes_1 <- 10001:20001
logMids <- log10(mids[indexes_1]+10/2)

hist_diff_plot_file.loglog <- sprintf("%s.hist_diff.loglog.binsize_10bp.png", filePrefix)
png(hist_diff_plot_file.loglog, unit = "in", width = 7, height = 5, res = 300, pointsize = 4)
indexes <- (distribution_diff[indexes_1] > 0)
plot(  logMids[indexes], (distribution_diff[indexes_1])[indexes],  col="red", xlim=c(1.5,5), ylim=c(1,max_count), xlab="Pet span (bp)", ylab="frequency of pets", xaxt="n", log="y")
axis(1, at=seq(-5,5,1), lab=c(-100000, -10000, -1000, -100, -10, 0, 10, 100, 1000, 10000, 100000))
legend("topleft", c("plus,plus", "plus,minus", "minus,plus", "minus,minus"), text.col=c("red", "green", "blue", "black"))
for (i in -4:4) {
    abline(v=i, lty="dashed")
}
#abline(v=log10(8000), lty="dashed")
dev.off()


# R code to plot preliminary results for OSGeoLive 2011
# install.packages(c("RSQLite","car","spdep","rgdal","reshape","RColorBrewer")
start <- function(){
    #usage con <- start()
    require(RSQLite)
    m <- dbDriver("SQLite")
    con <- dbConnect(m, dbname = "osgeolivedata.sqlite",loadable.extensions = TRUE)
    return(con)
}

fixITUdata <- function(con){
    ## Reshape ITU data to long format and save back to sqlite
    # Assumes db is already connected
    library(reshape2)
    inp1 <- dbReadTable(con,"'ITU-Internet'")
    outp1 <- melt(inp1,id=c("PK_UID","Country","iso_a2"))
    dbWriteTable(con,"ITU-InternetByYear",outp1)

    inp2 <- dbReadTable(con,"'ITU-Subscriptions'")
    outp2 <- melt(inp1,id=c("PK_UID","Country"))
    dbWriteTable(con,"ITU-SubscriptionsByYear",outp2)
}

exploreplots <- function(con){
    codes <- unique(dspeed$country_code)
    plot(range(as.POSIXct(dspeed$date)),range(dspeed$download_kbps))
    colors <- rainbow(length(codes))

    for (i in 1:length(codes)) {
        country <- subset(dspeed, country_code==codes[i])
        lines(as.POSIXct(country$date), country$download_kbps, type="l", lwd=1.5,col=colors[i])
    }

    #dspeed[,d:=as.Date(date)]
    dspeed$d<-as.Date(dspeed$date)
    #dspeed[,cc:=factor(country_code)]
    dspeed$cc<-factor(dspeed$country_code)
    ggplot(dspeed,aes(d,download_kbps,color=cc))+geom_line()
}

testRandom <- function(con){
    #Set the seed to the psuedo random number generator for repeatable results
    set.seed(9)
    #require(randomForest)
    #require(ROCR)
    require(party)
    #downdata <-dbReadTable(con,"Metrics2012wDemIndex")
    # Filter out null ITU
    dsql <- 'SELECT * FROM "Metrics2012wDemIndex" WHERE ITUbroadband IS NOT NULL'
    downdata <- dbGetQuery(con,dsql)

    #economy and income should probably be factors
    downdata$economy <- as.factor(downdata$economy)
    downdata$income <- as.factor(downdata$income)
    #Set the seed, same seed = same random selection
    #split the data into training and test data, 1/2 - use 75% of data for training 25% for testing
    #train = sample(1:nrow(downdata),nrow(downdata)/2)
    train = sample(1:nrow(downdata),floor(nrow(downdata)*.75))

    #build a random forest regression
    #mtry default is p/3 unless doing bagging
    #ntree can be change
    #Potentially use tuneRF to find the mtry and ntree values to use
    # itu-broadband had nulls values
    #downdata.rf <- randomForest(downbypop ~ economy+income+ooklaaverage+akuniqueip+akaverage+akpeak+akhighbroadband+akbroadband+aknarrowband+DemIndex, data=downdata, subset=train, keep.forest=TRUE,importance = TRUE)
    #importance(downdata.rf)

    #party might be better since its a mix of categorical(ordinal) and (interval)
    #party is supposed to be better for highly correlated data (see papers)
    #ITU has 2 NA, count as zero?
    #downdata[is.na(downdata)] <- 0
    downdata.cf <- cforest(downbypop ~ economy+income+OoklaAverage+ITUbroadband+AkUniqueIP+AkAverage+AkPeak+AkHighBroadband+AkBroadband+AkNarrowband+DemIndex, data=downdata, subset=train, control = cforest_unbiased(ntree = 1000))
    #downdata.cf <- cforest(downbypop ~ economy+income+OoklaAverage+ITUbroadband+AkUniqueIP+AkAverage+AkPeak+AkHighBroadband+AkBroadband+AkNarrowband+DemIndex, data=downdata)

    #Is the formula right?
    #Maybe don't need to divided downloads by population, so that forest can tell if population matters
    #uniqueip is dangerous since number of ip's is highly controlled, and early adopters have larger share - maybe this makes it a good measure?

    #Population is a big driver, is it better to just multiply downbypop*100? to make it more readable
    #downdata.cf <- cforest(downloads ~ pop+economy+income+average+peak+highbroadband+akamaibroadband+narrowband+DemIndex+itubroadband, data=downdata, subset=train)

    #Try to figure out which variables are important, conditional means assume the variables are correlated
    downdata.varimp <- varimp(downdata.cf, conditional=TRUE)

    #save results to file, nothing useful to save?
    of <- "ForestResults.txt"
    capture.output(print(downdata.cf),file=of,append=FALSE)

    #Plot with a line at the abs(of the biggest negative)
    #http://www.stanford.edu/~stephsus/R-randomforest-guide.pdf
    pdf(file="ImportantVariables-notrain.pdf",width=6,height=8)
    opar<-par()
    par(oma=c(2,4,2,2))
    barplot(sort(downdata.varimp),horiz=TRUE, las=1,xlab="")
    abline(v=abs(min(downdata.varimp)), col='red',lty='longdash', lwd=2)
    dev.off()
    par(opar)

    #For testing get the inverse of the training data
    testdata <- downdata[-train,]

    require(corrgram)
    pdf(file="CorrelationMatrix.pdf",width=6,height=6)
    corrgram(downdata, order=TRUE, lower.panel=panel.shade,  upper.panel=panel.pie, text.panel=panel.txt,  main="OSGeo Download, PCA ordered")
    dev.off()

    require(car)
    pdf(file="ScatterPlotMatrix.pdf",width=11,height=8.5)
    scatterplotMatrix(economy+income+OoklaAverage+ITUbroadband+AkUniqueIP+AkAverage+AkPeak+AkHighBroadband+AkBroadband+AkNarrowband+DemIndex,data=downdata)
    dev.off()

    #Posthoc testing
    #http://stats.stackexchange.com/questions/77290/does-party-package-in-r-provide-out-of-bag-estimates-of-error-for-random-forest
    require(caret)
    require(parallel)
    ooberror <- caret:::cforestStats(downdata.cf)

    #Save the model error estimates
    capture.output(print(ooberror),file=of,append=TRUE)

}

caretForest <- function(con){

    #Set the seed to the psuedo random number generator for repeatable results
    set.seed(10)
    #require(randomForest)
    #require(ROCR)
    require(party)
    require(caret)
    require(parallel)
    require(doMC) #caret can be done in parrallel
    registerDoMC(cores = 4)

    #downdata <-dbReadTable(con,"Metrics2012wDemIndex")
    # Filter out null ITU
    dsql <- 'SELECT * FROM "Metrics2012wDemIndex" WHERE ITUbroadband IS NOT NULL'
    downdata <- dbGetQuery(con,dsql)

    #Stratified random sampling - didn't really work
    #inTrain <- createDataPartition(downdata$downbypop,p=0.8,list=FALSE)

    #Setup the Caret model with cforest
    mod1 <- train(downbypop ~ economy+income+OoklaAverage+ITUbroadband+AkUniqueIP+AkAverage+AkPeak+AkHighBroadband+AkBroadband+AkNarrowband+DemIndex, data = downdata,method = "cforest",trControl = trainControl(method = "oob",allowParallel = TRUE, number = 10, repeats = 10),controls = cforest_unbiased(ntree = 10000))

    #When doing more than 1 at a time turn off parallel
    #mod1 <- train(downbypop ~ economy+income+OoklaAverage+ITUbroadband+AkUniqueIP+AkAverage+AkPeak+AkHighBroadband+AkBroadband+AkNarrowband+DemIndex, data = downdata,method = "cforest",trControl = trainControl(method = "oob",allowParallel = FALSE, number = 10, repeats = 10),controls = cforest_unbiased(ntree = 10000))

    test.varimp <- varimp(mod1$finalModel,conditional=TRUE)

    #Plot important variables
    pdf(file="ImportantVariables-caret.pdf",width=6,height=8)
    #opar<-par()
    par(oma=c(2,4,2,2))
    barplot(sort(test.varimp),horiz=TRUE,las=1,xlab="")
    abline(v=abs(min(test.varimp)), col='red',lty='longdash', lwd=2)
    dev.off()
    #par(opar)

    of <- "CaretCForestResults.txt"
    capture.output(print(mod1),file=of,append=FALSE)
    capture.output(print(test.varimp),file=of,append=TRUE)

    #What it does when DemIndex is dropped
    mod2 <- train(downbypop ~ economy+income+OoklaAverage+ITUbroadband+AkUniqueIP+AkAverage+AkPeak+AkHighBroadband+AkBroadband+AkNarrowband, data = downdata,method = "cforest",trControl = trainControl(method = "oob",allowParallel = TRUE, number = 10, repeats = 10),controls = cforest_unbiased(ntree = 10000))

    test.varimp2 <- varimp(mod2$finalModel,conditional=TRUE)
    of <- "CaretCForestResults.txt"
    capture.output(print(mod2),file=of,append=TRUE)
    capture.output(print(test.varimp2),file=of,append=TRUE)

    pdf(file="ImportantVariables-NoDemIndex.pdf",width=6,height=8)
    #opar<-par()
    par(oma=c(2,4,2,2))
    barplot(sort(test.varimp2),horiz=TRUE,las=1,xlab="")
    abline(v=abs(min(test.varimp2)), col='red',lty='longdash', lwd=2)
    dev.off()
    #par(opar)

}

OSanalysis <- function(con){
    #require(Deducer)
    #require(polytomous)
    require(reshape2)
    #file to hold output of tests
    #of <- "ContingencyResults.txt"
    #capture.output(print(date()),file=of,append=FALSE)

    #Two nominal variables - Country and Operating System
    #http://udel.edu/~mcdonald/statgtestind.html
    of <- "TotDownByOs.txt"
    downbyos <- dbReadTable(con,"TotDownByOs")
    compbyos <- c(92.02,6.81,1.16,0.00)
    downbyos.mat <- as.matrix(downbyos[1,-1]/sum(downbyos[1,-1])*100)
    downbyos.cont <- rbind(downbyos.mat,compbyos)
    row.names(downbyos.cont) <- c("downloads","computers")
    #chisq.test(downbyos.cont)
    #downbyos.lt <- likelihood.test(downbyos.cont)
    #capture.output(print(downbyos.lt),file=of,append=TRUE)
    fullcont(con,downbyos.cont,of)
    #	Pearson's Chi-squared test
    #data:  downbyos.cont
    #X-squared = 25.4531, df = 3, p-value = 1.241e-05

    #Summary information
    #Convert to percentages, calculate min, max, avg, std_dev by column

    #Contingency analysis of Countries by Downloads, Contributors and Translators
    of <- "CountryCont.txt"
    ### Disabling separate columns in favor of combined
    downsSQL <- 'SELECT "country", sum(total) as downloads FROM "sfosbycountry" WHERE Version <= 6.5 GROUP BY country ORDER BY country;'
    downs <- dbGetQuery(con,downsSQL)
    #note 90% of the downloads from ~45 countries
    info1<- sum(sort(downs$downloads,decreasing=TRUE)[0:45])/sum(downs$downloads)

    #combined Contrib+Translators, overlap removed
    combineSQL  <- 'SELECT country,count(name) as participants FROM (SELECT distinct(name),max(country) as country FROM (SELECT distinct(name),country FROM contributors UNION SELECT distinct(name),country FROM translators) GROUP BY name) GROUP BY country;'
    #TODO limit by version
    combined <- dbGetQuery(con,combineSQL)

    #country.df <- merge(downs,contrib,all.x=TRUE)
    #country.df <- merge(country.df,trans,all.x=TRUE)
    country.df <- merge(downs,combined,all.x=TRUE)

    #How much of the downloads is from countries with no participation
    info2 <- sum(country.df[is.na(country.df$participants),2])/sum(country.df$downloads)
    #number of countries without participants
    length(country.df[is.na(country.df$participants),1])

    #Replace NA with 0
    country.df[is.na(country.df)] <- 0
    #Convert to martix contingency table
    country.cont <- as.matrix(country.df[,-1])
    row.names(country.cont) <- country.df[,1]
    #country.lt <- likelihood.test(country.cont)
    #capture.output(print(country.lt),file=of,append=TRUE)
    #Not appropriate to treat as contingency table
    #fullcont(con,country.cont,of)
    #correlation test instead for non-parametric data (regression won't work here - non-normal data, no easy transform)
    cor.k = cor.test(country.cont[,1],country.cont[,2],method="kendall")
    capture.output(print(cor.s),file=of,append=TRUE)
    #Don't use Pearson's not looking for linear effect, data not normally distributed.
    cor.p = cor.test(country.cont[,1],country.cont[,2],method="pearson")
    capture.output(print(cor.p),file=of,append=TRUE)

    #subset only those countries with participants
    #TODO split contributors and translators
    #contribSQL <- 'SELECT country,count(name) as contributors FROM contributors as a, (SELECT max(rev) as mrev FROM "contributors") as b WHERE rev = mrev GROUP BY Country;'
    #contrib <- dbGetQuery(con,contribSQL)
    #transSQL <- 'SELECT country,count(name) as translators FROM translators as a,(SELECT max(rev) as mrev FROM "translators") as b WHERE rev = mrev GROUP BY Country;'
    #trans <- dbGetQuery(con,transSQL)
    #country.df <- merge(downs,contrib,all.x=TRUE)
    #country.df <- merge(country.df,trans,all.x=TRUE)

    country.part <- country.df[country.df$participants > 0,]
    country.partmatrix <- as.matrix(country.part[,-1])
    row.names(country.partmatrix) <- country.part[,1]
    country.dist <- dist(country.partmatrix)
    country.clust <- hclust(country.dist)

    #optional use ggplot2 based dendrogram plot with rotate
    require(ggplot2)
    require(ggdendro)
    country.dendro <- dendro_data(country.clust)
    ggdendrogram(country.dendro, rotate=TRUE)

    #Contingency analysis of Countries By OS variation
    # the tails of Windows use(none/100) seem to have something in common
    of <- "CountryByOS.txt"
    countrybyos <- dbReadTable(con,"CountryByOS")
    countrybyos.cont <- as.matrix(countrybyos[,-1])
    row.names(countrybyos.cont) <- countrybyos[,1]
    #countrybyos.lt <- likelihood.test(countrybyos.cont)
    #capture.output(print(countrybyos.lt),file=of,append=TRUE)
    fullcont(con,countrybyos.cont,of)
    countrymelt <- melt(countrybyos)
    pdf(file="CountryOSVariation.pdf",width=6,height=8)
    #opar<-par()
    boxplot(value~variable,data=countrymelt,ylab="Percentage of Downloaders")
    dev.off()
    #par(opar)

    #Contigency analysis of Type of Download by OS of Downloader
    of <- "TypeByOs.txt"
    typebyos <- dbReadTable(con,"TypeByOS")
    typebyos.cont <- as.matrix((typebyos[,-1]))
    row.names(typebyos.cont) <- typebyos[,1]
    typebyos.trans <- t(typebyos.cont)
    #typebyos.lt <- likelihood.test(typebyos.trans)
    #capture.output(print(typebyos.trans),file=of,append=FALSE)
    #capture.output(print(typebyos.lt),file=of,append=TRUE)
    fullcont(con,typebyos.trans,of)

}

importantvargraphs <- function(con){
    #Based on the caretForest analysis, post-hoc visualization of the relationship between dependent and important independant variables.
    #opar <- par()
    dsql <- 'SELECT * FROM "Metrics2012wDemIndex" WHERE ITUbroadband IS NOT NULL'
    downdata <- dbGetQuery(con,dsql)

    samewidth <- 1

    pdf(file="ImportantVarGraph.pdf",width=9,height=6)
    par(mfrow=c(2,2),mar=c(4,5,1,1),cex=0.6)

    plot(downbypop~DemIndex, data=downdata,ylab="downbypop (%)",xlab="DemIndex (0-10)")
    abline(lm(downdata$downbypop~downdata$DemIndex), col="red", lwd=samewidth)
    lines(lowess(downdata$DemIndex,downdata$downbypop), col="blue", lwd=samewidth)
    legend("topleft",legend=c("Linear Regression Fit","LOWESS Regression Fit"),fill=c("red","blue"))

    boxplot(downbypop~income, data=downdata, xlab="Income",ylab="downbypop (%)")

    plot(downbypop~ITUbroadband, data=downdata,xlab="ITUbroadband (% of population)",ylab="downbypop (%)")
    abline(lm(downdata$downbypop~downdata$ITUbroadband), col="red", lwd=samewidth)
    lines(lowess(downdata$ITUbroadband,downdata$downbypop), col="blue", lwd=samewidth)

    plot((downdata$AkPeak/1000),downdata$downbypop,xlab="AkPeak (Mbps)",ylab="downbypop (%)")
    Mbps <- downdata$AkPeak/1000
    abline(lm(downdata$downbypop~Mbps), col="red", lwd=samewidth)
    lines(lowess((downdata$AkPeak/1000),downdata$downbypop), col="blue", lwd=samewidth)
    dev.off()
    #par <- opar
}

fullcont <- function(con,cont,of){
    #Function runs chisq, g-test and posthoc tests on contingency tables
    require(polytomous)
    require(vcd)
    require(Deducer)

    capture.output(print(date()),file=of,append=FALSE)
    capture.output(print(cont),file=of,append=TRUE)
    #Standard Chi square
    cont.chi <- chisq.test(cont)
    capture.output(print(cont.chi),file=of,append=TRUE)

    #Standard Posthoc
    cont.post <- chisq.posthoc(cont)
    capture.output(print(cont.post),file=of,append=TRUE)

    #Gstat
    cont.like <- likelihood.test(cont)
    capture.output(print(cont.like),file=of,append=TRUE)

    #percent deviation
    cont.dev <- ((cont-cont.chi$expected)/cont.chi$expected)*100
    capture.output(print(cont.dev),file=of,append=TRUE)

    #Residuals - contributions to the solution
    #capture.output(print(cont.chi$residuals),file=of,append=TRUE)

    #Posthoc tests on Chisq, includes G2 stat too
    cont.a <- associations(cont)
    capture.output(print(cont.a),file=of,append=TRUE)
    cont.b <- assocstats(cont)
    capture.output(print(cont.b),file=of,append=TRUE)
}


###VISUALISE MODEL OUTPUTS###
library(tidyverse)
library(ggpubr)

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)
folder_inputs = file.path(folder, 'subscriptions', "data_inputs")

files = list.files(path=folder_inputs, pattern="*.csv")

data <-
  do.call("rbind",
          lapply(files,
                 function(x)
                   read.csv(file.path(folder_inputs, x),
                            stringsAsFactors = FALSE)))

data$country = factor(data$country, levels=c("CIV",
                                             'MLI',
                                             "SEN",
                                             "KEN",
                                             "TZA",
                                             "UGA"),
                      labels=c("Cote D'Ivoire",
                               "Mali",
                               "Senegal",
                               "Kenya",
                               "Tanzania",
                               "Uganda"
                      ))

data$scenario = factor(data$scenario, levels=c("low",
                                               'baseline',
                                               "high"
),
labels=c("Low",
         "Baseline",
         "High"
))

data = data[complete.cases(data),]

subscriptions = ggplot(data, aes(x=year, y=penetration, group=country)) +
  geom_point(aes(shape=country, color=country), size=1) +
  geom_line(aes(color=country)) +
  scale_shape_manual(values=c(0, 1, 2, 3, 4, 5)) +
  scale_size_manual(values=c(0.1, 0.1, 0.1, 0.1, 0.1)) +
  scale_color_manual(values=c("#009E73", "#F0E442","#E69F00",
                              "#56B4E9","#D55E00", "#0072B2")) +
  geom_vline(xintercept=2020, linetype="dashed", color = "grey", size=.5) +
  scale_x_continuous(expand = c(0, 0.5), limits = c(2010,2030),
                     breaks = seq(2010,2030,2)) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1),
        legend.position = "bottom", legend.title=element_blank()) +
  labs(title = "(A) Mobile Subscriptions by Country",
       x = NULL, y = "Subscribers (%)") +
  guides(shape=guide_legend(ncol=6), colour=guide_legend(ncol=6)) +
  facet_grid(~scenario)

#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)
folder_inputs = file.path(folder, 'smartphones', "data_inputs")

files = list.files(path=folder_inputs, pattern="*.csv")

data <-
  do.call("rbind",
          lapply(files,
                 function(x)
                   read.csv(file.path(folder_inputs, x),
                            stringsAsFactors = FALSE)))

data$country = factor(data$country, levels=c("CIV",
                                             'MLI',
                                             "SEN",
                                             "KEN",
                                             "TZA",
                                             "UGA"),
                      labels=c("Cote D'Ivoire",
                               "Mali",
                               "Senegal",
                               "Kenya",
                               "Tanzania",
                               "Uganda"
                      ))

data$scenario = factor(data$scenario, levels=c("low",
                                               'baseline',
                                               "high"
),
labels=c("Low",
         "Baseline",
         "High"
))

data$settlement_type = factor(data$settlement_type,
                              levels=c("urban",
                                       "rural"),
                              labels=c("Urban",
                                       "Rural"))

data = data[complete.cases(data),]

smartphones = ggplot(data, aes(x=year, y=penetration, group=country)) +
  geom_point(aes(shape=country, color=country), size=1) +
  geom_line(aes(color=country)) +
  scale_shape_manual(values=c(0, 1, 2, 3, 4, 5)) +
  scale_color_manual(values=c("#009E73", "#F0E442","#E69F00",
                              "#56B4E9","#D55E00", "#0072B2")) +
  scale_x_continuous(expand = c(0, 0.25), limits = c(2020,2030),
                     breaks = seq(2020,2030,2)) +
  scale_y_continuous(expand = c(0, 0), limits = c(0,100)) +
  theme(axis.text.x = element_text(angle = 45, hjust = 1),
        legend.position = "bottom", legend.title=element_blank()) +
  labs(title = "(B) Smartphone Penetration by Country",
       x = NULL, y = "Smartphones (%)") +
  guides(shape=guide_legend(ncol=6), colour=guide_legend(ncol=6)) +
  facet_grid(settlement_type~scenario)

combined <- ggarrange(subscriptions, smartphones,
                      ncol = 1, nrow = 2,
                      common.legend = TRUE,
                      legend='bottom', heights=c(3.5, 5))

path = file.path(folder, 'figures', 'a_demand_graphic.png')
ggsave(path, units="in", width=7, height=5.5, dpi=300)
print(combined)
dev.off()

remove(subscriptions, smartphones, combined, data)

###################################################################
folder <- dirname(rstudioapi::getSourceEditorContext()$path)

#load data
filename = 'national_market_cost_results_technology_options.csv'
data <- read.csv(file.path(folder, '..', 'results', 'model_results', filename))

data <- data[grep("10_10_10", data$scenario), ]
data <- data[!(data$total_market_cost == "NA"),]
data <- data[(data$confidence == 50),]

names(data)[names(data) == 'GID_0'] <- 'country'

data <- select(data, country, scenario, strategy, financial_cost)

data$scenario = factor(data$scenario, levels=c("low_10_10_10",
                                               "baseline_10_10_10",
                                               "high_10_10_10"),
                       labels=c("Low",
                                "Baseline",
                                "High"))

data$country = factor(data$country, levels=c("CIV",
                                             'MLI',
                                             "SEN",
                                             "KEN",
                                             "TZA",
                                             "UGA"),
                      labels=c("Cote D'Ivoire",
                               "Mali",
                               "Senegal",
                               "Kenya",
                               "Tanzania",
                               "Uganda"
                      ))

data$strategy = factor(data$strategy, levels=c(
  "3G_epc_wireless_baseline_baseline_baseline_baseline_baseline",
  "3G_epc_fiber_baseline_baseline_baseline_baseline_baseline",
  "4G_epc_wireless_baseline_baseline_baseline_baseline_baseline",
  "4G_epc_fiber_baseline_baseline_baseline_baseline_baseline"),
  labels=c("3G (W)",
           "3G (FB)",
           "4G (W)",
           "4G (FB)"))

min_value = round(min(data$financial_cost)/1e9,0)
max_value = round(max(data$financial_cost)/1e9,0)

financial_cost_10mbps = ggplot(data,
  aes(x=strategy, y=round(financial_cost/1e9),
      group=scenario, fill=scenario)) +
  geom_bar(stat = "identity", position=position_dodge()) +
  geom_text(aes(label = round(financial_cost/1e9)), size = 2.5,
            position = position_dodge(width = 1), hjust=-.25) +
  coord_flip() +
  scale_fill_manual(values=c("#E1BE6A", "#40B0A6", "#5D3A9B"), name=NULL) +
  theme(legend.position = "bottom") +
  labs(
  title="(A) Financial Cost of Universal Broadband by Technology (~10 Mbps Per User)",
       colour=NULL,
       subtitle = "Reported as the NPV for all scenarios and strategies over 2020-2030",
       x = NULL, y = "Financial Cost (Billions $USD)") +
  scale_y_continuous(expand = c(0, 0), limits = c(0, max_value+17)) +
  theme(panel.spacing = unit(0.6, "lines")) +
  guides(fill=guide_legend(ncol=3, reverse = TRUE)) +
  facet_wrap(~country, scales = "free", ncol=3)

############################################################
#load data
filename = 'national_market_cost_results_technology_options.csv'
data <- read.csv(file.path(folder, '..', 'results', 'model_results', filename))

data <- data[grep("2_2_2", data$scenario), ]
data <- data[!(data$total_market_cost == "NA"),]
data <- data[(data$confidence == 50),]

names(data)[names(data) == 'GID_0'] <- 'country'

data <- select(data, country, scenario, strategy, financial_cost)

data$scenario = factor(data$scenario, levels=c("low_2_2_2",
                                               "baseline_2_2_2",
                                               "high_2_2_2"),
                       labels=c("Low",
                                "Baseline",
                                "High"))

data$country = factor(data$country, levels=c("CIV",
                                             'MLI',
                                             "SEN",
                                             "KEN",
                                             "TZA",
                                             "UGA"),
                      labels=c("Cote D'Ivoire",
                               "Mali",
                               "Senegal",
                               "Kenya",
                               "Tanzania",
                               "Uganda"
                      ))

data$strategy = factor(data$strategy, levels=c(
  "3G_epc_wireless_baseline_baseline_baseline_baseline_baseline",
  "3G_epc_fiber_baseline_baseline_baseline_baseline_baseline",
  "4G_epc_wireless_baseline_baseline_baseline_baseline_baseline",
  "4G_epc_fiber_baseline_baseline_baseline_baseline_baseline"),
  labels=c("3G (W)",
           "3G (FB)",
           "4G (W)",
           "4G (FB)"))

min_value = round(min(data$financial_cost)/1e9,0)
max_value = round(max(data$financial_cost)/1e9,0)

financial_cost_2mbps = ggplot(data, aes(x=strategy, y=round(financial_cost/1e9),
                                     group=scenario, fill=scenario)) +
  geom_bar(stat = "identity", position=position_dodge()) +
  geom_text(aes(label = round(financial_cost/1e9)), size = 2.5,
            position = position_dodge(width = 1), hjust=-.25) +
  coord_flip() +
  scale_fill_manual(values=c("#E1BE6A", "#40B0A6", "#5D3A9B"), name=NULL) +
  theme(legend.position = "bottom") +
  labs(title = "(B) Financial Cost of Universal Broadband by Technology (~2 Mbps Per User)",
       colour=NULL,
       subtitle = "Reported as the NPV for all scenarios and strategies over 2020-2030",
       x = NULL, y = "Financial Cost (Billions $USD)") +
  scale_y_continuous(expand = c(0, 0), limits = c(0, max_value+17)) +
  theme(panel.spacing = unit(0.6, "lines")) +
  guides(fill=guide_legend(ncol=3, reverse = TRUE)) +
  facet_wrap(~country, scales = "free", ncol=3)

combined <- ggarrange(financial_cost_10mbps, financial_cost_2mbps,
                      ncol = 1, nrow = 2)

path = file.path(folder, 'figures', 'b_financial_cost_by_technology.png')
ggsave(path, units="in", width=8, height=11, dpi=300)
print(combined)
dev.off()

############################################################
###################Cost to Government
folder <- dirname(rstudioapi::getSourceEditorContext()$path)

#load data
filename = 'national_market_cost_results_technology_options.csv'
data <- read.csv(file.path(folder, '..', 'results', 'model_results', filename))

data <- data[grep("10_10_10", data$scenario), ]
data <- data[!(data$government_cost == "NA"),]
data <- data[(data$confidence == 50),]

names(data)[names(data) == 'GID_0'] <- 'country'

data <- select(data, country, scenario, strategy, government_cost)

data$scenario = factor(data$scenario, levels=c("low_10_10_10",
                                               "baseline_10_10_10",
                                               "high_10_10_10"),
                       labels=c("Low",
                                "Baseline",
                                "High"))

data$country = factor(data$country, levels=c("CIV",
                                             'MLI',
                                             "SEN",
                                             "KEN",
                                             "TZA",
                                             "UGA"),
                      labels=c("Cote D'Ivoire",
                               "Mali",
                               "Senegal",
                               "Kenya",
                               "Tanzania",
                               "Uganda"
                      ))

data$strategy = factor(data$strategy, levels=c(
  "3G_epc_wireless_baseline_baseline_baseline_baseline_baseline",
  "3G_epc_fiber_baseline_baseline_baseline_baseline_baseline",
  "4G_epc_wireless_baseline_baseline_baseline_baseline_baseline",
  "4G_epc_fiber_baseline_baseline_baseline_baseline_baseline"),
  labels=c("3G (W)",
           "3G (FB)",
           "4G (W)",
           "4G (FB)"))

min_value = round(min(data$government_cost)/1e9,2)
max_value = round(max(data$government_cost)/1e9, 2)

govt_costs_10mbps = ggplot(data, aes(x=strategy,
   y=round(government_cost/1e9,1), group=scenario, fill=scenario)) +
  geom_bar(stat = "identity", position=position_dodge()) +
  geom_text(aes(label = round(government_cost/1e9)), size = 2.5,
            position = position_dodge(width = 1), hjust=-1) +
  coord_flip() +
  scale_fill_manual(values=c("#E1BE6A", "#40B0A6", "#5D3A9B"), name=NULL) +
  theme(legend.position = "bottom") +
  labs(title="(A) Net Government Cost for Universal Broadband by Technology (~10 Mbps Per User)",
       colour=NULL,
       subtitle = "Reported as the NPV for all scenarios and strategies over 2020-2030",
       x = NULL, y = "Total Cost (Billions $USD)") +
  scale_y_continuous(expand = c(0, 0),
                     limits = c(min_value-.5, max_value+15)) +
  theme(panel.spacing = unit(0.6, "lines")) +
  guides(fill=guide_legend(ncol=3, reverse = TRUE)) +
  facet_wrap(~country, scales = "free", ncol=3)

############################################################
#load data
filename = 'national_market_cost_results_technology_options.csv'
data <- read.csv(file.path(folder, '..', 'results', 'model_results', filename))

data <- data[grep("2_2_2", data$scenario), ]
data <- data[!(data$government_cost == "NA"),]
data <- data[(data$confidence == 50),]

names(data)[names(data) == 'GID_0'] <- 'country'

data <- select(data, country, scenario, strategy, government_cost)

data$scenario = factor(data$scenario, levels=c("low_2_2_2",
                                               "baseline_2_2_2",
                                               "high_2_2_2"),
                       labels=c("Low",
                                "Baseline",
                                "High"))

data$country = factor(data$country, levels=c("CIV",
                                             'MLI',
                                             "SEN",
                                             "KEN",
                                             "TZA",
                                             "UGA"),
                      labels=c("Cote D'Ivoire",
                               "Mali",
                               "Senegal",
                               "Kenya",
                               "Tanzania",
                               "Uganda"
                      ))

data$strategy = factor(data$strategy, levels=c(
  "3G_epc_wireless_baseline_baseline_baseline_baseline_baseline",
  "3G_epc_fiber_baseline_baseline_baseline_baseline_baseline",
  "4G_epc_wireless_baseline_baseline_baseline_baseline_baseline",
  "4G_epc_fiber_baseline_baseline_baseline_baseline_baseline"),
  labels=c("3G (W)",
           "3G (FB)",
           "4G (W)",
           "4G (FB)"))

min_value = round(min(data$government_cost)/1e9,2)
max_value = round(max(data$government_cost)/1e9, 2)

govt_costs_2mbps = ggplot(data, aes(x=strategy,
    y=round(government_cost/1e9,1), group=scenario, fill=scenario)) +
  geom_bar(stat = "identity", position=position_dodge()) +
  geom_text(aes(label = round(government_cost/1e9)), size = 2.5,
            position = position_dodge(width = 1), hjust=-1) +
  coord_flip() +
  scale_fill_manual(values=c("#E1BE6A", "#40B0A6", "#5D3A9B"), name=NULL) +
  theme(legend.position = "bottom") +
  labs(title="(B) Net Government Cost for Universal Broadband by Technology (~2 Mbps Per User)", colour=NULL,
       subtitle = "Reported as the NPV for all scenarios and strategies over 2020-2030",
       x = NULL, y = "Total Cost (Billions $USD)") +
  scale_y_continuous(expand = c(0, 0),
                     limits = c(min_value-.5, max_value+15)) +
  theme(panel.spacing = unit(0.6, "lines")) +
  guides(fill=guide_legend(ncol=3, reverse = TRUE)) +
  facet_wrap(~country, scales = "free", ncol=3)

combined <- ggarrange(govt_costs_10mbps, govt_costs_2mbps,
                      ncol = 1, nrow = 2)

path = file.path(folder, 'figures', 'c_govt_cost_by_technology.png')
ggsave(path, units="in", width=8, height=11, dpi=300)
print(combined)
dev.off()

############################################################
###Business model
folder <- dirname(rstudioapi::getSourceEditorContext()$path)
filename = 'national_market_results_business_model_options.csv'
data <- read.csv(file.path(folder, '..', 'results', 'model_results', filename))

data <- data[grep("10_10_10", data$scenario), ]
data <- data[!(data$total_market_cost == "NA"),]
data <- data[(data$confidence == 50),]

names(data)[names(data) == 'GID_0'] <- 'country'

data <- select(data, country, scenario, strategy, financial_cost)

data$scenario = factor(data$scenario, levels=c("low_10_10_10",
                                               "baseline_10_10_10",
                                               "high_10_10_10"),
                       labels=c("Low",
                                "Baseline",
                                "High"))

data$country = factor(data$country, levels=c("CIV",
                                             'MLI',
                                             "SEN",
                                             "KEN",
                                             "TZA",
                                             "UGA"),
                      labels=c("Cote D'Ivoire",
                               "Mali",
                               "Senegal",
                               "Kenya",
                               "Tanzania",
                               "Uganda"
                      ))

data$strategy = factor(data$strategy, levels=c(
  "4G_epc_wireless_srn_srn_baseline_baseline_baseline",
  "4G_epc_wireless_moran_baseline_baseline_baseline_baseline",
  "4G_epc_wireless_psb_baseline_baseline_baseline_baseline",
  "4G_epc_wireless_baseline_baseline_baseline_baseline_baseline"
),
labels=c(
  "SRN",
  "Active",
  "Passive",
  "Baseline"
))

data <- data[complete.cases(data),]

min_value = round(min(data$financial_cost)/1e9,2)
max_value = round(max(data$financial_cost)/1e9,2)

cost_10mbps = ggplot(data, aes(x=strategy, y=round(financial_cost/1e9),
                               group=scenario, fill=scenario)) +
  geom_bar(stat = "identity", position=position_dodge()) +
  geom_text(aes(label = round(financial_cost/1e9, 1)), size = 2.5,
            position = position_dodge(width = 1), hjust=-.5) +
  coord_flip() +
  scale_fill_manual(values=c("#E1BE6A", "#40B0A6", "#5D3A9B"), name=NULL) +
  theme(legend.position = "bottom") +
  labs(title = "(A) Financial Cost of Universal Broadband with Infrastructure Sharing (~10 Mbps Per User)",
       colour=NULL,
       subtitle = "Reported as the NPV for all scenarios and strategies (2020-2030) using 4G (Wireless)",
       x = NULL, y = "Financial Cost (Billions $USD)") +
  scale_y_continuous(expand = c(0, 0), limits = c(0, max_value+17)) +
  theme(panel.spacing = unit(0.6, "lines")) +
  guides(fill=guide_legend(ncol=3, reverse = TRUE)) +
  facet_wrap(~country, scales = "free", ncol=3)

######################################################################
folder <- dirname(rstudioapi::getSourceEditorContext()$path)
filename = 'national_market_results_business_model_options.csv'
data <- read.csv(file.path(folder, '..', 'results', 'model_results', filename))

data <- data[grep("2_2_2", data$scenario), ]
data <- data[!(data$financial_cost == "NA"),]
data <- data[(data$confidence == 50),]

names(data)[names(data) == 'GID_0'] <- 'country'

data <- select(data, country, scenario, strategy, financial_cost)

data$scenario = factor(data$scenario, levels=c("low_2_2_2",
                                               "baseline_2_2_2",
                                               "high_2_2_2"),
                       labels=c("Low",
                                "Baseline",
                                "High"))

data$country = factor(data$country, levels=c("CIV",
                                             'MLI',
                                             "SEN",
                                             "KEN",
                                             "TZA",
                                             "UGA"),
                      labels=c("Cote D'Ivoire",
                               "Mali",
                               "Senegal",
                               "Kenya",
                               "Tanzania",
                               "Uganda"
                      ))

data$strategy = factor(data$strategy, levels=c(
  "4G_epc_wireless_srn_srn_baseline_baseline_baseline",
  "4G_epc_wireless_moran_baseline_baseline_baseline_baseline",
  "4G_epc_wireless_psb_baseline_baseline_baseline_baseline",
  "4G_epc_wireless_baseline_baseline_baseline_baseline_baseline"
),
labels=c(
  "SRN",
  "Active",
  "Passive",
  "Baseline"
))

data <- data[complete.cases(data),]

min_value = round(min(data$financial_cost)/1e9,2)
max_value = round(max(data$financial_cost)/1e9,2)

cost_2mbps = ggplot(data, aes(x=strategy, y=round(financial_cost/1e9),
                              group=scenario, fill=scenario)) +
  geom_bar(stat = "identity", position=position_dodge()) +
  geom_text(aes(label = round(financial_cost/1e9, 1)), size = 2.5,
            position = position_dodge(width = 1), hjust=-.5) +
  coord_flip() +
  scale_fill_manual(values=c("#E1BE6A", "#40B0A6", "#5D3A9B"), name=NULL) +
  theme(legend.position = "bottom") +
  labs(title = "(B) Financial Cost of Universal Broadband with Infrastructure Sharing (~2 Mbps Per User)",
       colour=NULL,
       subtitle = "Reported as the NPV for all scenarios and strategies (2020-2030) using 4G (Wireless)",
       x = NULL, y = "Financial Cost (Billions $USD)") +
  scale_y_continuous(expand = c(0, 0), limits = c(0, max_value+17)) +
  theme(panel.spacing = unit(0.6, "lines")) +
  guides(fill=guide_legend(ncol=3, reverse = TRUE)) +
  facet_wrap(~country, scales = "free", ncol=3)

combined <- ggarrange(cost_10mbps, cost_2mbps,
                      ncol = 1, nrow = 2)

path = file.path(folder, 'figures', 'd_infra_sharing_cost.png')
ggsave(path, units="in", width=8, height=11, dpi=300)
print(combined)
dev.off()

#########################################################################
#get folder directory
folder <- dirname(rstudioapi::getSourceEditorContext()$path)
folder_inputs = file.path(folder, '..', 'results', 'user_costs')

data1 <- read.csv(file.path(folder_inputs, 'total_cost_estimates_2.csv'))
data1$Capacity = '~2 Mbps Per User'

data2 <- read.csv(file.path(folder_inputs, 'total_cost_estimates_10.csv'))
data2$Capacity = '~10 Mbps Per User'

data = rbind(data1, data2)

remove(data1, data2)

data <- data[(data$Confidence == 50),]

data <- select(data, Scenario, Strategy, Capacity,
               Private.Cost...Bn., Government.Cost...Bn.,
               Financial.Cost...Bn.)

data$Scenario = factor(data$Scenario, levels=c("Low",
                                               "Baseline",
                                               "High"))

data$Capacity = factor(data$Capacity, levels=c("~10 Mbps Per User",
                                               "~2 Mbps Per User"
))

totals <- data %>%
  group_by(Scenario, Strategy, Capacity) %>%
  summarize(financial_cost = round(
    (Private.Cost...Bn. + Government.Cost...Bn.)/1000, 1))

colnames(data)[colnames(data) == 'Private.Cost...Bn.'] <- 'Private Cost ($USD)'
colnames(data)[colnames(data) == 'Government.Cost...Bn.'] <- 'Government Cost ($USD)'
colnames(data)[colnames(data) == 'Financial.Cost...Bn.'] <- 'financial_cost'

data <- data %>% gather(key="Cost_Type", value = "value",
                        'Private Cost ($USD)',
                        'Government Cost ($USD)',
)

min_value = min(round(data$financial_cost/1e3, 2))
max_value = max(round(data$financial_cost/1e3, 2))

data$value = round(data$value/1e3, 2)

ggplot(data, aes(y=value, x=Strategy, fill=Cost_Type)) +
  geom_bar(position="stack", stat="identity") +
  geom_text(aes(Strategy, financial_cost, label = financial_cost, fill = NULL),
            size = 2.5, data = totals, hjust=-.5) +
  coord_flip() +
  scale_fill_manual(values=c("#E1BE6A", "#40B0A6"), name=NULL) +
  theme(legend.position = "bottom") +
  labs(title = "Financial Cost of Universal Broadband Across Africa by Technology", colour=NULL,
       subtitle = "Reported as the NPV for all scenarios and strategies over 2020-2030",
       x = NULL, y = "Financial Cost (Trillions $USD)") +
  scale_y_continuous(expand = c(0, 0), limits = c(-min_value, max_value+0.5)) +
  theme(panel.spacing = unit(0.6, "lines")) +
  guides(fill=guide_legend(ncol=3, reverse = TRUE)) +
  facet_grid(Capacity~Scenario)

path = file.path(folder, 'figures', 'f_total_financial_cost_across_Africa.png')
ggsave(path, units="in", width=8, height=5, dpi=300)
dev.off()

#############################
###VISUALISE MODEL OUTPUTS###
folder <- dirname(rstudioapi::getSourceEditorContext()$path)

#load data
filename = 'national_market_results_sensitivity_analysis.csv'
data <- read.csv(file.path(folder, '..', 'results',
                           'sensitivity_analysis', filename))

data = data %>%
  separate(scenario, into = c("scenario", "capacity", NA, NA), sep="_") %>%
  separate(strategy, into = c("generation", "core", "backhaul",
                              NA, NA, NA, NA, "obf", "costs"), sep="_")

data$strategy = paste(data$generation, data$backhaul, sep='_')

data = data[data$strategy == "4G_wireless",]
data = data[data$scenario == "baseline",]
data = data[data$capacity == "10",]

data$GID_0 = factor(data$GID_0, levels=c("UGA",
                                         "TZA",
                                         "KEN",
                                         "SEN",
                                         "MLI",
                                         "CIV"),
                    labels=c(
                      "Uganda",
                      "Tanzania",
                      "Kenya",
                      "Senegal",
                      "Mali",
                      "Cote D'Ivoire"))

data$obf = factor(data$obf, levels=c('15', '20', '25' ),
                  labels=c('-25%', 'Baseline', '+25%'))

data$costs = factor(data$costs, levels=c('125', '100', '75'),
                    labels=c('+25%', 'Baseline', '-25%'))

data = select(data, GID_0, scenario, obf, costs, financial_cost)

data_obf = data[data$costs == "Baseline",]

min_value = round(min(data_obf$financial_cost)/1e9,0)
max_value = round(max(data_obf$financial_cost)/1e9,0)

obf_figure = ggplot(data_obf,
                    aes(x=GID_0, y=round(financial_cost/1e9),
                        group=obf, fill=obf)) +
  geom_bar(stat = "identity", position=position_dodge()) +
  geom_text(aes(label = round(financial_cost/1e9)), size = 2.5,
            position = position_dodge(width = 1), hjust=-.25) +
  coord_flip() +
  scale_fill_manual(values=c("#E1BE6A", "#40B0A6", "#5D3A9B"), name=NULL) +
  theme(legend.position = "bottom") +
  labs(
    title="(A) Cost Sensitivity for Active Network Users when Maintaining QoS",
    colour=NULL,
    subtitle = "Reported as the NPV for 4G (W) targetting ~10 Mbps Per User (2020-2030)",
    x = NULL, y = "Financial Cost (Billions $USD)") +
  scale_y_continuous(expand = c(0, 0), limits = c(0, max_value+17)) +
  theme(panel.spacing = unit(0.6, "lines")) +
  guides(fill=guide_legend(ncol=3, reverse = TRUE))

data_costs = data[data$obf == "Baseline",]

min_value = round(min(data_costs$financial_cost)/1e9,0)
max_value = round(max(data_costs$financial_cost)/1e9,0)

costs_figure = ggplot(data_costs,
                      aes(x=GID_0, y=round(financial_cost/1e9),
                          group=costs, fill=costs)) +
  geom_bar(stat = "identity", position=position_dodge()) +
  geom_text(aes(label = round(financial_cost/1e9)), size = 2.5,
            position = position_dodge(width = 1), hjust=-.25) +
  coord_flip() +
  scale_fill_manual(values=c("#E1BE6A", "#40B0A6", "#5D3A9B"), name=NULL) +
  theme(legend.position = "bottom") +
  labs(
    title="(B) Cost Sensitivity to Model Input Costs (2020-2030)",
    colour=NULL,
    subtitle = "Reported as the NPV for 4G (W) targetting ~10 Mbps Per User (2020-2030)",
    x = NULL, y = "Financial Cost (Billions $USD)") +
  scale_y_continuous(expand = c(0, 0), limits = c(0, max_value+17)) +
  theme(panel.spacing = unit(0.6, "lines")) +
  guides(fill=guide_legend(ncol=3, reverse = TRUE))

combined <- ggarrange(obf_figure, costs_figure,
                      ncol = 1, nrow = 2)

path = file.path(folder, 'figures', 'sensitivity_analysis.png')
ggsave(path, units="in", width=8, height=11, dpi=300)
print(combined)
dev.off()


  Hoover
           value  ------------- Distribution ------------- count
               9                                         | 0
           >= 10 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@| -100

  Nixon
           value  ------------- Distribution ------------- count
           < -10 |@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 25
             -10 |                                         0

  Harding
           value  ------------- Distribution ------------- count
           < -10 |                                         0
             -10 |@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 15
              -9 |                                         0

  Bush
           value  ------------- Distribution ------------- count
               9 |                                         0
           >= 10 |@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 150


library(tidyverse)
library(readr)
library(plotly)
library(zoo)

library(extrafont)
# this line is not very portable. You might need to remove the references to ETBembo below
font_import(paths="~/Library/Fonts/", pattern = "*et*", prompt = FALSE)

countries <- c("Sweden", "Germany", "Denmark", "Belgium", "France", "Czech Republic", "Czechia", "Austria", "United Kingdom", "Slovakia")
colors <- c("#F8766D", "#D3920070", "#93AA0070", "#00BA3870", "#00C19F70", "#00B9E370", "#619CFF70", "#DB72FB70", "#FF61C370")

cols <- c("Country", "Date", "Retail & recreation",
          "Grocery & pharmacy",
          "Parks",
          "Transit stations",
          "Workplaces",
          "Residential")

#download.file("https://www.gstatic.com/covid19/mobility/Global_Mobility_Report.csv", "data/Global_Mobility_Report.csv")
Global_Mobility_Report <- read_csv("data/Global_Mobility_Report.csv",
                                   col_types = cols(census_fips_code = col_skip(),
                                                    country_region_code = col_skip(),
                                                    iso_3166_2_code = col_skip()))

All_Mobility_Data <- Global_Mobility_Report %>%
  dplyr::select(- sub_region_2) %>%
  dplyr::select(- metro_area) %>%
  filter( is.na(sub_region_1)) %>%
  select(-sub_region_1)

colnames(All_Mobility_Data) <- cols

Subset_Mobility_Data_long <- All_Mobility_Data %>%
  gather(Mobility_Type, Percent_Change, -c(Date, Country)) %>%
  filter(Country %in% countries)

# Name Czech Republic consistently
Subset_Mobility_Data_long$Country <- gsub("Czechia", "Czech Republic", Subset_Mobility_Data_long$Country)
Subset_Mobility_Data_long$Change <- rollmean(Subset_Mobility_Data_long$Percent_Change, 7, na.pad=TRUE, align = "right")
write_csv(Subset_Mobility_Data_long, "data/Subset_Mobility_Data_long.csv")

Subset_Mobility_Data_long <- read_csv("data/Subset_Mobility_Data_long.csv")
Subset_Mobility_Data_long <-transform(Subset_Mobility_Data_long, Country = factor(Country,levels=countries) )

our_theme <- theme_minimal() +
  theme(text=element_text(family="ETBembo-RomanLF"))

plot_mob_cat <- function (Mob_Type)
{
  g <- ggplot(Subset_Mobility_Data_long %>% filter(Mobility_Type == Mob_Type),
         aes(Date, Change,
             color = Country)) +
    geom_line() +
    our_theme +
    ggtitle(paste("Google mobility report - ", Mob_Type)) +
    ylab("Change from baseline") +
    scale_y_continuous(labels = scales::percent_format(scale = 1)) +
    scale_color_manual(name = "Country", values = colors) +
    geom_hline(yintercept = 0, linetype="dashed")
    ggsave(scale = 0.6, paste("img/", Mob_Type, ".png"), plot = g)
    return(g)
}

ggplotly(plot_mob_cat("Residential"))
ggplotly(plot_mob_cat("Retail & recreation"))
ggplotly(plot_mob_cat("Workplaces"))
ggplotly(plot_mob_cat("Transit stations"))
ggplotly(plot_mob_cat("Parks"))

plot_country <- function (cntry)
{
  g <- ggplot(Subset_Mobility_Data_long %>%
                filter(Country == cntry)%>%
                filter(Mobility_Type != "Parks") ,
              aes(x = Date,
                  y = Change,
                  color = Mobility_Type)) +
    geom_line() +
    our_theme +
    ggtitle(paste("Google mobility report - ", cntry)) +
    ylab("Change from baseline")
  return(g)
}

ggplotly(plot_country("Sweden"))
ggplotly(plot_country("Germany"))
ggplotly(plot_country("Denmark"))
ggplotly(plot_country("Belgium"))
ggplotly(plot_country("France"))
ggplotly(plot_country("Czech Republic"))

plot_mob_facet <- function (Mob_Type)
{
  g<-ggplot(Subset_Mobility_Data_long %>%
              filter(Mobility_Type == Mob_Type), aes(Date, Change, color = Country)) +
    geom_line() +
    our_theme +
    theme(legend.title = element_blank(), legend.position = "none") +
    ggtitle(paste("Google mobility - ", Mob_Type)) +
    ylab("Change from baseline") +
    scale_y_continuous(labels = scales::percent_format(scale = 1)) +
    geom_hline(yintercept=0, linetype="dashed")  +
    scale_x_date(date_breaks = "1 month",
                 limits = as.Date(c('2020-10-01','2020-12-04')),
                 labels = date_format("%b")) +
    facet_wrap(~ Country)
    ggsave(scale = 0.6, paste("img/", Mob_Type, "_facet.png"), plot = g)
    return(g)
}

ggplotly(plot_mob_facet("Residential"))
ggplotly(plot_mob_facet("Retail & recreation"))
ggplotly(plot_mob_facet("Workplaces"))
ggplotly(plot_mob_facet("Transit stations"))
ggplotly(plot_mob_facet("Parks"))

g <- ggplot(Subset_Mobility_Data_long %>%
              filter(Mobility_Type != "Parks") %>%
              filter(Mobility_Type != "Residential"),
            aes(x = Date,
                y = Change,
                color = Country)) +
  geom_line() +
  our_theme +
  ggtitle("Google mobility report") +
  geom_hline(yintercept=0, linetype="dashed")  +
  scale_color_manual(name = "Country", values = colors) +
  #  theme(legend.title = element_blank(), legend.position = "none") +
  ylab("Change from baseline") +
  scale_y_continuous(labels = scales::percent_format(scale = 1)) +
  facet_wrap(~ Mobility_Type)
g

ggsave(scale = 0.6, "img/mobility_facet.png", plot = g)
ggplotly(g)


 #' Write MT3DMS .ucn File
#'
#' This function writes a ucn dataframe created in R (i.e., from readucn) to a binary ucn file
#' composed of the following elements:
#'
#' writeucn(ucn, ofl)
#' @param ucn is the ucn data frame
#' @param ofl is the output ucn file name
#' @export
#' @examples
#' writeucn(ucn = u, ofl = "T04R1.ucn")

writeucn <- function(ucn, ofl){

    NTTS <- ucn$TIME %>% data.frame() %>% dplyr::distinct() %>% nrow()
    NLAY <- ucn$LAY %>% data.frame() %>% dplyr::distinct() %>% nrow()
    NC <- ucn$COL %>% data.frame() %>% dplyr::distinct() %>% nrow()
    NR <- ucn$ROW %>% data.frame() %>% dplyr::distinct() %>% nrow()
    FROM <- outer(((1:NLAY - 1) * NR * NC + 1), ((1:NTTS - 1) * NLAY * NC * NR), FUN = "+") %>% as.vector()
    TO <- FROM + NR * NC - 1
    INDX <- rep(1:NTTS * NLAY * NR * NC, each = NLAY)
    LAY <- rep(1:NLAY, NTTS)
    obin <- file(ofl, "wb")
    for(j in 1:(NTTS * NLAY)){
            op1   <- c(ucn$TRANS[INDX[j]] %>% as.integer(),
                       ucn$STP[INDX[j]] %>% as.integer(),
                       ucn$PER[INDX[j]] %>% as.integer())
            op2   <- ucn$TIME[INDX[j]] %>% as.double()
            opTxt <- "CONCENTRATION   "
            op3   <- c(NC %>% as.integer(),
                       NR %>% as.integer(),
                       LAY[j] %>% as.integer())
            op4   <- ucn$CONC[FROM[j]:TO[j]] %>% as.double()
            writeBin(op1, obin)
            writeBin(op2, obin, size = 4)
            writeChar(opTxt, obin, nchars = 16, eos = NULL)
            writeBin(op3, obin)
            writeBin(op4, obin, size = 4)
    }
    close(obin)

}


test <- function(h, b, seed, alg) {
    set.seed(seed)
    k <- 2*h+1
    n <- k*b
    x <- sample(2**32, n)
    e <- system.time(runmed(x, k, "keep", alg))["elapsed"]
    if (e < 0.01) {
        e <- system.time(for(i in 1:100) runmed(x, k, "keep", alg))["elapsed"] / 100.0
        cat(sprintf('R%s\t%d\t%d\tr-large\t%d\t%.5f\n', alg, h, b, seed, e), sep="")
    } else if (e < 0.1) {
        e <- system.time(for(i in 1:10) runmed(x, k, "keep", alg))["elapsed"] / 10.0
        cat(sprintf('R%s\t%d\t%d\tr-large\t%d\t%.4f\n', alg, h, b, seed, e), sep="")
    } else {
        cat(sprintf('R%s\t%d\t%d\tr-large\t%d\t%.3f\n', alg, h, b, seed, e), sep="")
    }
    flush.console()
}

test1 <- function(h, b, seed) {
    test(h, b, seed, "Turlach")
}

test2 <- function(h, b, seed) {
    test(h, b, seed, "Stuetzle")
}

for (seed in 1:10) {
    test1(1, 10000, seed)
    test1(10, 1000, seed)
    test1(100, 100, seed)
    test1(1000, 10, seed)
    test1(1, 100000, seed)
    test1(10, 10000, seed)
    test1(100, 1000, seed)
    test1(1000, 100, seed)
    test1(10000, 10, seed)
    test1(1, 1000000, seed)
    test1(10, 100000, seed)
    test1(100, 10000, seed)
    test1(1000, 1000, seed)
    test1(10000, 100, seed)
    test1(100000, 10, seed)
    test1(1, 10000000, seed)
    test1(10, 1000000, seed)
    test1(100, 100000, seed)
    test1(1000, 10000, seed)
    test1(10000, 1000, seed)
    test1(100000, 100, seed)
    test1(1000000, 10, seed)

    test2(1, 10000, seed)
    test2(10, 1000, seed)
    test2(100, 100, seed)
    test2(1000, 10, seed)
    test2(1, 100000, seed)
    test2(10, 10000, seed)
    test2(100, 1000, seed)
    test2(1000, 100, seed)
    test2(10000, 10, seed)
}


Rebol [
    Title: "Deflate De/Compression"
    Date: 4-Jan-2022
    Author: "Christopher Ross-Gill"
    Home: http://www.ross-gill.com/
    File: %deflate.r
    Version: 0.3.2
    Purpose: "DEFLATE de/compression including ZLIB/GZIP envelopes"
    Rights: http://opensource.org/licenses/Apache-2.0

    Type: 'module
    Name: 'rgchris.deflate
    Exports: [
        deflate inflate
        crc32-checksum-of adler32-checksum-of
    ]

    History: [
        07-Apr-2022 0.3.2 "Tweaks to return correct end of compressed stream"
        04-Jan-2022 0.3.0 "Added INFLATE algorithm and wrapper"
        04-Jan-2022 0.2.0 "Added DEFLATE wrapper around COMPRESS"
        25-May-2015 0.1.0 "Rudimentary CRC Routine"
    ]

    Notes: [
        "Tiny Inflate" 'tiny-inflate
        https://github.com/foliojs/tiny-inflate
        https://github.com/jibsen/tinf
        https://gist.github.com/rgchris/d3fb5f6a6ea6d27ea3817c0e697ac25d

        "Other"
        https://www.zlib.net/

        gzip-platform [
            ; no yellow dots
            1 "Amiga" #{01}
            2 "Mac" #{07}
            3 "Windows" #{00}
            4 "Linux/Unix" #{03}
        ]
    ]
]

crc32-checksum-of: use [
    table value
][
    table: collect [
        repeat n 256 [
            value: n - 1

            loop 8 [
                value: either equal? 1 value and 1 [
                    -306674912 xor shift/logical value 1
                    ;
                    ; 0xEDB88320
                ][
                    shift/logical value 1
                ]
            ]

            keep value
        ]
    ]

    func [
        stream [binary!]
    ][
        value: -1

        foreach byte stream [
            value: (shift/logical value 8) xor pick table value and 255 xor byte + 1
        ]

        debase/base to-hex value xor -1 16
    ]
]

adler32-checksum-of: func [
    stream [binary!]
    /local a b remaining cap
][
    a: 1
    b: 0

    cap: 8'388'608  ; 8MB
    remaining: length? stream

    while [remaining > 0] [
        loop min remaining cap [
            a: a + stream/1
            b: a + b

            stream: next stream
        ]

        a: mod a 65521
        b: mod b 65521

        remaining: length? stream
    ]

    b: shift/left b 16

    debase/base to-hex a or b 16
]

deflate: func [
    "Compress data using DEFLATE: https://en.wikipedia.org/wiki/DEFLATE"

    data [binary! string!]
    "Series to compress"

    /envelope
    "Add an envelope with header plus checksum/size information"

    format
    "'zlib (adler32, no size), 'gzip (crc32, uncompressed size), 'legacy"

    /local compressed
][
    compressed: compress data

    switch format [
        #[none] [
            remove remove head clear skip tail compressed -8
        ]

        zlib [
            head clear skip tail compressed -4
        ]

        gzip [
            change skip tail compressed -8 reverse crc32-checksum-of as-binary data

            rejoin [
                #{1F8B08000000000000} #{FF}
                next next compressed
            ]
        ]

        legacy [
            compressed
        ]
    ]
]

tiny-inflate: make object! [
    TINF-OK: 0
    TINF-DATA-ERROR: -3

    new-tree: func [] [
        reduce [
            'table array/initial 16 0  ; table of code length counts
            'translations array/initial 288 0  ; code -> symbol translation
        ]
    ]

    new-encoding: func [
        source
        target
    ][
        make object! compose [
            source: (source)
            index: 0
            tag: 0
            bit-count: 0

            target: (target)
            length: 0

            sym-tree: new-tree  ; dynamic length/symbol tree
            dst-tree: new-tree  ; dynamic distance tree

            debug: false
        ]
    ]

    ; -- uninitialized global data (static structures) --
    ; ---------------------------------------------------
    ;
    static-sym-tree: new-tree
    static-dst-tree: new-tree

    ; extra bits and base tables for length codes
    ;
    length-bits: array/initial 30 0
    length-base: array/initial 30 0  ; Uint16Array

    ; extra bits and base tables for distance codes
    ;
    distance-bits: array/initial 30 0
    distance-base: array/initial 30 0  ; Uint16Array

    ; special ordering of code length codes */
    ;
    code-length-code-index: [
        16 17 18 0 8 7 9 6
        10 5 11 4 12 3 13 2
        14 1 15
    ]

    ; used by decode-trees, avoids allocations every call
    ;
    code-tree: new-tree
    lengths: array/initial 288 + 32 0

    ; -- utility functions --
    ; -----------------------

    ; build extra bits and base tables
    ;
    build-bits-base: func [
        bits [block!]
        base
        delta [integer!]
        start

        /local sum
    ][
        sum: start

        ; build bits table
        ;
        change bits array/initial delta 0

        repeat offset 30 - delta [
            poke bits offset + delta to integer! any [
                attempt [
                    (offset - 1) / delta
                ]

                0
            ]
        ]

        ; build base table
        ;
        repeat offset 30 [
            poke base offset sum
            sum: sum + shift/left 1 bits/:offset
        ]

        ()
    ]

    ; build the fixed huffman trees
    ;
    build-fixed-trees: func [
        sym-tree
        dst-tree
    ][
        ; build fixed-length tree
        ;
        change sym-tree/table [
            0 0 0 0 0 0 0 24 152 112
        ]

        repeat offset 24 [
            poke sym-tree/translations offset 255 + offset
        ]

        repeat offset 144 [
            poke sym-tree/translations 24 + offset offset - 1
        ]

        repeat offset 8 [
            poke sym-tree/translations 24 + 144 + offset 279 + offset
        ]

        repeat offset 112 [
            poke sym-tree/translations 24 + 144 + 8 + offset 143 + offset
        ]

        ; build fixed distance tree
        ;
        change dst-tree/table [
            0 0 0 0 0 32
        ]

        repeat offset 32 [
            poke dst-tree/translations offset offset - 1
        ]

        ()
    ]

    ; given an array of code lengths, build a tree
    ;
    offsets: array/initial 16 0

    build-tree: func [
        tree
        lengths
        start [integer!]
        count [integer!]
        /local sum
    ][
        ; clear code length count table
        ;
        change tree/table array/initial 16 0

        ; scan symbol lengths, and sum code length counts
        ;
        repeat offset count [
            poke tree/table 1 + lengths/(start + offset) 1 + tree/table/(1 + lengths/(start + offset))
        ]

        change tree/table 0

        ; compute offset table for distribution sort
        ;
        sum: 0

        repeat offset 16 [
            poke offsets offset sum
            sum: sum + pick tree/table offset
        ]

        ; create code->symbol translation table (symbols sorted by code)
        ;
        repeat offset count [
            if lengths/(start + offset) > 0 [
                poke tree/translations 1 + offsets/(1 + lengths/(start + offset)) offset - 1
                poke offsets 1 + lengths/(start + offset) 1 + offsets/(1 + lengths/(start + offset))
            ]
        ]

        ()
    ]

    ; -- decode functions --
    ; ----------------------

    ; get one bit from source stream
    ;
    get-bit: func [
        encoding

        /local bit
    ][
        ; check if tag is empty
        ;
        if zero? encoding/bit-count [
            ; load next tag
            ;
            encoding/tag: encoding/source/1
            encoding/bit-count: 8
            encoding/source: next encoding/source
        ]

        encoding/bit-count: encoding/bit-count - 1

        ; shift bit out of tag
        ;
        bit: encoding/tag and 1

        encoding/tag: shift/logical encoding/tag 1

        bit
    ]

    ; read a <length> bit value from a stream and add base
    ;
    read-bits: func [
        encoding
        length [integer!]
        base [integer!]

        /local value
    ][
        either zero? length [
            base
        ][
            while [
                encoding/bit-count < 24
            ][
                encoding/tag: encoding/tag or shift/left any [encoding/source/1 0] encoding/bit-count
                encoding/source: next encoding/source
                encoding/bit-count: encoding/bit-count + 8
            ]

            value: encoding/tag and shift/logical 65535 16 - length

            encoding/tag: shift/logical encoding/tag length
            encoding/bit-count: encoding/bit-count - length

            value + base
        ]
    ]

    ; given a data stream and a tree, decode a symbol
    ;
    decode-symbol: func [
        encoding
        tree
        /local sum current length tag
    ][
        while [
            encoding/bit-count < 24
        ][
            encoding/tag: encoding/tag or shift/left any [encoding/source/1 0] encoding/bit-count
            encoding/source: next encoding/source
            encoding/bit-count: encoding/bit-count + 8
        ]

        sum: 0
        current: 0
        length: 0
        tag: encoding/tag

        ; get more bits while code value is above sum
        ;
        until [
            current: 2 * current + (tag and 1)
            tag: shift/logical tag 1
            length: length + 1

            sum: sum + pick tree/table length + 1
            current: current - pick tree/table length + 1

            current < 0
        ]

        encoding/tag: tag
        encoding/bit-count: encoding/bit-count - length

        pick tree/translations sum + current + 1
    ]

    ; given a data stream, decode dynamic trees from it
    ;
    decode-trees: func [
        encoding
        sym-tree
        dst-tree

        /local
        lengths-count distances-count code-lengths-count
        count length
        code-length symbol prev
    ][
        ; get 5 bits HLIT (257-286)
        ;
        lengths-count: read-bits encoding 5 257

        ; get 5 bits HDIST (1-32)
        ;
        distances-count: read-bits encoding 5 1

        ; get 4 bits HCLEN (4-19)
        ;
        code-lengths-count: read-bits encoding 4 4

        change lengths array/initial 19 0

        ; read code lengths for code length alphabet
        ;
        repeat offset code-lengths-count [
            ; get 3 bits code length (0-7)
            ;
            code-length: read-bits encoding 3 0

            poke lengths code-length-code-index/:offset + 1 code-length
        ]

        ; build code length tree
        ;
        build-tree code-tree lengths 0 19

        ; decode code lengths for the dynamic trees
        ;
        count: 1

        while [
            count < (lengths-count + distances-count + 1)
        ][
            symbol: decode-symbol encoding code-tree

            switch/default symbol [
                16 [
                    ; copy previous code length 3-6 times (read 2 bits)
                    ;
                    prev: pick lengths count - 1
                    length: read-bits encoding 2 3

                    while [
                        length > 0
                    ][
                        poke lengths count prev

                        count: count + 1
                        length: length - 1
                    ]
                ]

                17 [
                    ; repeat code length 0 for 3-10 times (read 3 bits)
                    ;
                    length: read-bits encoding 3 3

                    while [
                        length > 0
                    ][
                        poke lengths count 0

                        count: count + 1
                        length: length - 1
                    ]
                ]

                18 [
                    ; repeat code length 0 for 11-138 times (read 7 bits)
                    ;
                    length: read-bits encoding 7 11

                    while [
                        length > 0
                    ][
                        poke lengths count 0

                        count: count + 1
                        length: length - 1
                    ]
                ]
            ][
                ; values 0-15 represent the actual code lengths
                ;
                poke lengths count symbol
                count: count + 1
            ]
        ]

        ; build dynamic trees
        ;
        build-tree sym-tree lengths 0 lengths-count
        build-tree dst-tree lengths lengths-count distances-count

        ()
    ]

    ; -- block inflate functions --
    ; -----------------------------

    ; given a stream and two trees, inflate a block of data
    ;
    inflate-block-data: func [
        encoding
        sym-tree
        dst-tree

        /local
        symbol length distance offset
    ][
        until [
            symbol: decode-symbol encoding sym-tree

            case [
                symbol == 256 [
                    TINF-OK
                ]

                symbol < 256 [
                    append encoding/target to char! symbol

                    false
                ]

                <else> [
                    symbol: 1 + symbol - 257
                    ; + 1 for 1-based indexing

                    ; possibly get more bits from length code
                    ;
                    length: read-bits encoding length-bits/:symbol length-base/:symbol

                    distance: 1 + decode-symbol encoding dst-tree
                    ; + 1 for 1-based indexing

                    ; possibly get more bits from distance code
                    ;
                    offset: length? encoding/target

                    offset: offset - read-bits encoding distance-bits/:distance distance-base/:distance

                    ; copy match
                    ;
                    repeat char length [
                        append encoding/target to char! pick encoding/target offset + char
                    ]

                    false
                ]
            ]
        ]
    ]

    ; inflate an uncompressed block of data
    ;
    inflate-uncompressed-block: func [
        encoding

        /local length inverse-length
    ][
        ; unread from bitbuffer
        ;
        while [
            encoding/bit-count > 8
        ][
            encoding/source: back encoding/source
            encoding/bit-count: encoding/bit-count - 8
        ]

        ; get length
        ;
        length: 256 * encoding/source/2 + encoding/source/1

        ; get one's complement of length
        ;
        inverse-length: 256 * encoding/source/4 + encoding/source/3

        ; check length
        ;
        either inverse-length xor 65535 == length [
            encoding/source: skip encoding/source 4

            assert [
                length <= length? encoding/source
            ]

            ; copy block
            ;
            loop length [
                append encoding/target to char! encoding/source/1
                encoding/source: next encoding/source
            ]

            ; make sure we start next block on a byte boundary
            ;
            encoding/bit-count: 0

            TINF-OK
        ][
            TINF-DATA-ERROR
        ]
    ]

    ; inflate stream from source to target
    ;
    uncompress: func [
        source target
        /debug

        /local
        encoding type-block is-unpacked is-last-block
    ][
        encoding: new-encoding source target

        if any [
            debug
            512 > length? source
        ] [
            encoding/debug: true
        ]

        until [
            ; read final block flag
            ;
            is-last-block: 1 == get-bit encoding

            ; read block type (2 bits)
            ;
            type-block: read-bits encoding 2 0

            ; decompress block
            ;
            is-unpacked: switch/default type-block [
                0 [
                    ; Decompress an uncompressed block
                    ;
                    inflate-uncompressed-block encoding
                ]

                1 [
                    ; Decompress a block with fixed huffman trees
                    ;
                    inflate-block-data encoding static-sym-tree static-dst-tree
                ]

                2 [
                    ; decompress block with dynamic huffman trees
                    ;
                    decode-trees encoding encoding/sym-tree encoding/dst-tree

                    inflate-block-data encoding encoding/sym-tree encoding/dst-tree
                ]
            ][
                TINF-DATA-ERROR
            ]

            if is-unpacked <> TINF-OK [
                make error! "DEFLATE stream integrity error"
            ]

            is-last-block
        ]

        ; reset source position
        ;
        while [
            encoding/bit-count > 8
        ][
            encoding/source: back encoding/source
            encoding/bit-count: encoding/bit-count - 8
        ]

        reduce [
            encoding/target encoding/source
        ]
    ]

    ; -- initialization --
    ; --------------------

    ; build fixed huffman trees
    ;
    build-fixed-trees static-sym-tree static-dst-tree

    ; build extra bits and base tables
    ;
    build-bits-base length-bits length-base 4 3
    build-bits-base distance-bits distance-base 2 1

    ; fix a special case
    ;
    length-bits/29: 0
    length-base/29: 258
]

inflate: func [
    [catch]
    "Decompress DEFLATE data: https://en.wikipedia.org/wiki/DEFLATE"

    data [binary!]
    "Series to decompress"

    /max
    bound
    "Error out if result is larger than this"

    /envelope
    "Expect (and verify) envelope with header/CRC/size information"

    format [word!]
    "ZLIB, GZIP, or LEGACY"

    /local remaining size flags
][
    switch format [
        #[none] [
            first tiny-inflate/uncompress data copy #{}
        ]

        ; wrappers
        ;
        zlib [
            case [
                8 > length? data [
                    throw make error! "ZLIB wrapper too small"
                ]

                data/1 and 15 <> 8 [
                    throw make error! "ZLIB sequence does not contain DEFLATE-compressed data"
                ]

                data/1 > 120 [
                    throw make error! "ZLIB window size too large"
                ]

                error? try [
                    data: skip data pick [2 6] zero? data/2 and 32
                    set [data remaining] tiny-inflate/uncompress data make binary! 1024
                ][
                    throw make error! "Inflate error"
                ]

                not find/match remaining adler32-checksum-of data [
                    throw make error! "Inflate ZLIB checksum fail"
                ]

                <else> [
                    data
                ]
            ]
        ]

        gzip [
            case [
                not parse/all data [
                    #{1F8B08} 7 skip data: 8 skip to end
                    (data: as-binary data)
                ][
                    throw make error! "Missing GZIP header"
                ]

                not integer? size: to integer! reverse copy skip tail data -4 [
                    throw make error! "Inflate: Should not happen"
                ]

                error? try [
                    set [data remaining] tiny-inflate/uncompress data make binary! size
                ][
                    throw make error! "Inflate error"
                ]

                not find/match remaining reverse crc32-checksum-of data [
                    throw make error! "Inflate GZIP checksum fail"
                ]

                <else> [
                    data
                ]
            ]
        ]

        legacy [
            as-binary decompress data
        ]
    ]
]