#script classifies MapBiomas maps (possibly output from ResampleMosaic.r)
#then optionally uses planted area data to improve classification ('disaggregation')

##load libraries
rm(list=ls())
library(raster)
library(tidyverse)
library(readxl)

################
##Script settings
input_path <- "C:/Users/k1076631/Google Drive/Shared/Crafty Telecoupling/Data/LandCover/MapBiomas4/BrazilInputMaps/"

#Classifications to loop through (from Excel)
cls <- c("PastureA", "PastureB","PastureC")

#classify for the following years
yrs <- seq(2001, 2018, 1)

#map for our study area, cell values are municipality IDs
munis.r <- raster(paste0(input_path,"Data/BaseMaps/sim10_BRmunis_latlon_5km.asc"))

#indicate whether to improve classification by disaggregating some classes using planted area data
disaggregate <- T

#indicate whether to create summary tables or not (these are needed for disaggregation but take some time to create so pre-created might be used)
sumTab <- T

################
##Functions

#function converts raster to xyz  (with help from https://stackoverflow.com/a/19847419)
#specify input raster, whether nodata cells should be output, whether a unique cell ID should be added
#return is a matrix. note format is row (Y) then col (X)
extractXYZ <- function(raster, nodata = FALSE, addCellID = TRUE){

  vals <- raster::extract(raster, 1:ncell(raster))   #specify raster otherwise dplyr used
  xys <- rowColFromCell(raster,1:ncell(raster))
  combine <- cbind(xys,vals)

  if(addCellID){
    combine <- cbind(1:length(combine[,1]), combine)
  }

  if(!nodata){
    combine <- combine[!rowSums(!is.finite(combine)),]  #from https://stackoverflow.com/a/15773560
  }

  return(combine)
}

#function to calculate proportion of each LC in a muni (ignoring NAs, help from https://stackoverflow.com/a/44290753)
getLCs <- function(data)
{

  data %>%
    group_by(muniID) %>%
    dplyr::summarise(LC1 = round(sum(lcMap == 1, na.rm = T) / sum(!is.na(lcMap)), 3),
                     LC2 = round(sum(lcMap == 2, na.rm = T) / sum(!is.na(lcMap)), 3),
                     LC3 = round(sum(lcMap == 3, na.rm = T) / sum(!is.na(lcMap)), 3),
                     LC4 = round(sum(lcMap == 4, na.rm = T) / sum(!is.na(lcMap)), 3),
                     LC5 = round(sum(lcMap == 5, na.rm = T) / sum(!is.na(lcMap)), 3),
                     NonNAs = sum(!is.na(lcMap)),
                     NAs = sum(is.na(lcMap))
    ) -> LCs

  return(LCs)
}

#function converts data in CRAFTY output file for a single variable and creates a raster
outputRaster <- function(data, variable){

  out <- data %>%
    dplyr::select(X, Y, !!variable)

  ras <- rasterFromXYZ(out)

  return(ras)
}

#function to Calculate number of OAgri, Agri and Pasture cells needed to match OA_plant and A_plant
calcDiffcs <- function(tbl) {

  # Calculate number of OAgri, Agri and Pasture cells needed to match OA_plant and A_plant:
  #Overall A_final + OA_final + P_final must equal A_mapped + OA_mapped
  #So:
  #case 1
  #if OA_mapped > OA_planted AND A_mapped < A_planted
  #then take enough from difference so A_mapped == A_planted, any remainder is pasture
  #case 2
  #if OA_mapped > OA_planted AND A_mapped >= A_planted
  #then OA is planted value and remainder is pasture, A_mapped does not change
  #case 3
  #if OA_mapped == OA_planted AND A_mapped < A_planted
  #then nothing changes
  #case 4
  #if OA_mapped == OA_planted AND A_mapped >= A_planted
  #then nothing changes
  #case 5
  #if OA_mapped < OA_planted AND A_mapped <= A_planted
  #then nothing changes
  #case 6
  #if OA_mapped < OA_planted AND A_mapped > A_planted
  #then add difference from A to OA (so that OA_M == OA_p, or until A_m == A_p)

  #calculate differences (used in cases below)
  tbl <- tbl %>%
    dplyr::select(muniID, A_mapped_cells, OA_mapped_cells, A_plant_cells, OA_plant_cells) %>%
    mutate(A_diffc = A_mapped_cells - A_plant_cells) %>%
    mutate(OA_diffc = OA_mapped_cells - OA_plant_cells)

  #case 1
  #if OA_mapped > OA_planted AND A_mapped < A_planted
  #then take enough from difference so A_mapped == A_planted, any remainder is pasture
  tbl <- tbl %>%
    mutate(OA_final =
             if_else(OA_diffc > 0 & A_diffc < 0, OA_plant_cells,99))  %>%
    mutate(A_final =
             if_else(OA_diffc > 0 & A_diffc < 0,
                     if_else(OA_diffc >= abs(A_diffc), A_plant_cells, A_mapped_cells + OA_diffc),
                     99)) %>%
    mutate(P_final =
             if_else(OA_diffc > 0 & A_diffc < 0,
                     if_else(OA_diffc >= abs(A_diffc), OA_mapped_cells - OA_plant_cells - abs(A_diffc), 0),
                     99))

  #case 2
  #if OA_mapped > OA_planted AND A_mapped >= A_planted
  #then OA is planted value and remainder is pasture, A_mapped does not change
  tbl <- tbl %>%
    mutate(OA_final =
             if_else(OA_diffc > 0 & A_diffc >= 0, OA_plant_cells, OA_final)) %>%
    mutate(A_final =
             if_else(OA_diffc > 0 & A_diffc >= 0, A_plant_cells, A_final)) %>%
    mutate(P_final =
             if_else(OA_diffc > 0 & A_diffc >= 0, OA_diffc, P_final))

  #case 6
  #if OA_mapped < OA_planted AND A_mapped > A_planted
  #then add difference from A to OA:
  #if A_diffc <= abs(OA_diffc) OA_final is max possible, otherwise OA_plant (A_final is always A_mapped - A_diffc)
  #nothing goes to P_final
  tbl <- tbl %>%
    mutate(OA_final =
             if_else(OA_diffc < 0 & A_diffc > 0,
                     if_else(A_diffc <= abs(OA_diffc), OA_mapped_cells + A_diffc, OA_mapped_cells + abs(OA_diffc)),
                     OA_final)) %>%
    mutate(A_final =
             if_else(OA_diffc < 0 & A_diffc > 0,
                     if_else(A_diffc <= abs(OA_diffc), A_mapped_cells - A_diffc, A_mapped_cells - abs(OA_diffc)),
                     A_final)) %>%
    mutate(P_final =
             if_else(OA_diffc < 0 & A_diffc > 0, 0, P_final))

  #case 3
  tbl <- tbl %>%
    mutate(OA_final =
             if_else(OA_diffc == 0 & A_diffc < 0, 0, OA_final)) %>%
    mutate(A_final =
             if_else(OA_diffc == 0 & A_diffc < 0, 0, A_final)) %>%
    mutate(P_final =
             if_else(OA_diffc == 0 & A_diffc < 0, 0, P_final))

  #case 4
  tbl <- tbl %>%
    mutate(OA_final =
             if_else(OA_diffc == 0 & A_diffc >= 0, 0, OA_final)) %>%
    mutate(A_final =
             if_else(OA_diffc == 0 & A_diffc >= 0, 0, A_final)) %>%
    mutate(P_final =
             if_else(OA_diffc == 0 & A_diffc >= 0, 0, P_final))

  #case 5
  tbl <- tbl %>%
    mutate(OA_final =
             if_else(OA_diffc < 0 & A_diffc <= 0, 0, OA_final)) %>%
    mutate(A_final =
             if_else(OA_diffc < 0 & A_diffc <= 0, 0, A_final)) %>%
    mutate(P_final =
             if_else(OA_diffc < 0 & A_diffc <= 0, 0, P_final))

  tbl <- tbl %>%
    mutate(Agri_final = A_final + OA_final)

  return(tbl)

  #check all cells have changed
  #k <- j %>%
  #  filter(OA_final == 99)
}

#function for each municipality:
#- compare A obs and desired; change if necessary (increase from OA, decrease to OA)
#- compare OA obs and desired; change if necessary (increase from Pas, decrease to Pas)
#convs is the conversions calculated in calcDiffcs, lcs is the lc_munis df
#both should already have been subst to a single muni
convertLCs <- function(convs, lcs) {

  #print(convs[,8:11])
  #print(lcs)

  #subset data
  NA_lcs <- filter(lcs, lc == 1 | lc == 4)  #not Agri or Pas
  Agri_lcs <- filter(lcs, lc == 2 | lc == 3)   #Agri (not Pas or Nat)
  P_lcs  <- filter(lcs, lc == 5)  #Pas
  A_lcs <- filter(lcs, lc == 3)   #soy/maize
  OA_lcs <- filter(lcs, lc == 2)  #OA

  #calc how many conversions needed (if negative move to pasture)
  Agri_obs <- length(Agri_lcs$lc)
  Agri_diffc <- Agri_obs - convs$Agri_final

  # print(convs)
  # print(Agri_obs)
  # print(convs$Agri_final)
  # print(Agri_diffc)
  # print(is.na(Agri_diffc))
  # print(length(convs$Agri_final))

  #print(OA_lcs)
  ctr <- 1 #counter to ensure we don't try to access beyond length of tables below

  #if(length(OA_lcs$lc) == 0) print("length(OA_lcs$lc) == 0")

  #if we observe more Agri than we want, move OA to pasture
  #try to move sufficient amount to get the right amount of Agri, otherwise all OA
  if(length(OA_lcs$lc) > 0)  #if there are some Agri pixels
  {
    while(Agri_diffc > 0) {
      if(!any(2 %in% OA_lcs$lc)) break   #if there are no OA values to convert, break
      if(ctr > length(OA_lcs$lc)) break  #should never happen but check if we are trying to convert more values than available, break

      OA_lcs[ctr,4] <- 5                 #do the conversion to Pas
      #print("update: 2 -> 5")

      ctr <- ctr + 1                     #update counter
      Agri_diffc <- Agri_diffc - 1       #update counter
    }
  }

  #print(OA_lcs)
  #update data as we may have made some conversions that have changed OA_lcs
  nlcs <- bind_rows(NA_lcs, A_lcs, OA_lcs, P_lcs)

  #split out again for later
  NA_lcs <- filter(nlcs, lc == 1 | lc == 4)  #not Agri or Pas
  Agri_lcs <- filter(nlcs, lc == 2 | lc == 3)   #Agri (not Pas or Nat)
  P_lcs  <- filter(nlcs, lc == 5)  #Pas
  A_lcs <- filter(nlcs, lc == 3)   #soy/maize
  OA_lcs <- filter(nlcs, lc == 2)  #OA

  #print("nlcs")
  #print(nlcs)
  #if(length(Agri_lcs$lc) == 0) print("length(Agri_lcs$lc) == 0")

  #now distribute amongst soy/maize (A) vs OA (only if there are any Agri cells)
  if(length(Agri_lcs$lc) > 0) {

    #calculate desired soy/maize prop
    Agri_sum <- convs$A_final + convs$OA_final  #total number of desired Agri cells, used to calc prop
    A_prop <- NA

    #if both A and OA have a value we need to calc prop, otherwise we can assign based on 0s
    if(convs$A_final > 0 & convs$OA_final > 0) {
      A_prop <- convs$A_final / Agri_sum
    } else if(convs$A_final > 0) {
      A_prop <- 1.0
    } else {
      A_prop <- 0
    }

    #print(paste0("A_prop: ", A_prop))

    #use desired prop to calc desired soy/maize cells
    A_obs <- length(A_lcs$lc)
    OA_obs <- length(OA_lcs$lc)

    if(is.na(length(A_lcs$lc))) A_obs <- 0
    if(is.na(length(OA_lcs$lc))) OA_obs <- 0

    Agri_obs <- A_obs + OA_obs

    #desired number of soy/maize cells
    A_dobs <- round(Agri_obs * A_prop, 0)

    #check difference between desired and observed
    A_diffc <- A_dobs - A_obs

    #print(paste0("A_diffc: ", A_diffc))

    ctr <- 1 #counter to ensure we don't try to access beyond length of tables below

    #print(OA_lcs)

    #if desired soy/maize is greater than observed, take some from OA
    while(A_diffc > 0) {
      if(!any(2 %in% OA_lcs$lc)) break   #if there are no OA values to convert (because we already changed them all), break
      if(ctr > length(OA_lcs$lc)) break  #should never happen but check if we are trying to convert more values than available, break

      OA_lcs[ctr,4] <- 3                 #do the conversion to soy/maize
      #print("update: 2 -> 3")

      ctr <- ctr + 1               #update counter
      A_diffc <- A_diffc - 1       #update counter
    }

    #print(OA_lcs)

    ctr <- 1 #counter to ensure we don't try to access beyond length of tables below

    #print(A_lcs)

    #if desired soy/maize is less than observed, give some to OA
    while(A_diffc < 0) {
      if(!any(3 %in% A_lcs$lc)) break   #if there are no A values to convert (because we already changed them all), break
      if(ctr > length(A_lcs$lc)) break  #should never happen but check if we are trying to convert more values than available, break

      A_lcs[ctr,4] <- 2                 #do the conversion to other agri
      #print("update: 3 -> 2")

      ctr <- ctr + 1               #update counter
      A_diffc <- A_diffc + 1       #update counter
    }

    #print(A_lcs)
  }

  #update data as we may have made some conversions
  nlcs <- bind_rows(NA_lcs, A_lcs, OA_lcs, P_lcs)

  return(nlcs)

}

#function to create summary table for pre-classified map for comparison
#output tables contain proportions of LCs and count of data and NA cells for each muni (munis are rows)
createSummaryTable <- function(munisMap, yr, cname, disagg){

  if(!disagg){
    lcname <- paste0("LandCover",yr,"_",cname,".asc")
    print(paste0("Creating Summary Table from: ", lcname))
    outname <- paste0("Data/Classified/SummaryTable",yr,"_",cname,".csv")
  }

  if(disagg){
    lcname <- paste0("LandCover",yr,"_",cname,"_Disagg.asc")
    print(paste0("Creating Summary Table from: ", lcname))
    outname <- paste0("Data/Classified/SummaryTable",yr,"_",cname,"_Disagg.csv")
  }

  inname <- paste0("Data/Classified/",lcname)
  lcMap <- raster(inname)

  #extract cell values to table format
  munis.t <- extractXYZ(munisMap, addCellID = F)
  lcMap.t <- extractXYZ(lcMap, addCellID = F)

  munis.t <- as.data.frame(munis.t)
  munis.t <- plyr::rename(munis.t, c("vals" = "muniID"))

  lcMap.t <- as.data.frame(lcMap.t)
  lcMap.t <- plyr::rename(lcMap.t, c("vals" = "lcMap"))

  #set NA in both rasters
  lcMap[is.na(munisMap)] <- NA
  munisMap[is.na(lcMap)] <- NA

  #then check what setting NA does....
  munis.t2 <- extractXYZ(munisMap, addCellID = F)
  lcMap.t2 <- extractXYZ(lcMap, addCellID = F)

  munis.t2 <- as.data.frame(munis.t2)
  munis.t2 <- plyr::rename(munis.t2, c("vals" = "muniID"))

  lcMap.t2 <- as.data.frame(lcMap.t2)
  lcMap.t2 <- plyr::rename(lcMap.t2, c("vals" = "lcMap"))

  #so need to join
  lcMap_munis <- left_join(as.data.frame(munis.t), as.data.frame(lcMap.t), by = c("row" = "row", "col" = "col"))

  #now summarise by muniID
  lcs <- getLCs(lcMap_munis)

  #head(lcs)
  #summary(lcs)

  #write to file
  write.csv(lcs, outname, row.names = F)

}

################
##Disaggregate
disaggFn <- function(yr,cname){

  print(paste0("Disaggregating, year: ", yr))

  summary_filename <- paste0(input_path,"Data/Classified/SummaryTable",yr,"_",cname,".csv")

  if(!file.exists(summary_filename)){
    createSummaryTable(munis.r, yr, cname, disagg=FALSE)  #disagg must always be FALSE in this call
  }

  #read Summary table for this year - this contains number of cells in each muni (and proportions in each LC)
  mapped <- read_csv(summary_filename)

  # From mapbiomas data calculate number of cells for:
  # - agriculture
  # - OAgri
  mapped <- mapped %>%
    mutate(A_mapped_cells = round(LC3 * NonNAs,0)) %>%
    mutate(OA_mapped_cells = round(LC2 * NonNAs,0))

  #muni 5006275 was only created in 2013, partitioned from 5000203
  #so add values from 5006275 to 5000203
  old <- mapped$A_mapped_cells[mapped$muniID == 5000203]
  new <- mapped$A_mapped_cells[mapped$muniID == 5006275] + old
  mapped$A_mapped_cells[mapped$muniID == 5000203] <- new

  old <- mapped$OA_mapped_cells[mapped$muniID == 5000203]
  new <- mapped$OA_mapped_cells[mapped$muniID == 5006275] + old
  mapped$OA_mapped_cells[mapped$muniID == 5000203] <- new

  #mapped %>%
  #  filter(A_mapped_cells > 0) %>%
  #  ggplot(aes(x = A_mapped_cells)) +
  #  geom_histogram(binwidth=5)

  #read planted area data (from IBGE)
  planted <- read_excel(paste0(input_path,"Data/PlantedAreas/PlantedArea_",yr,".xlsx"), sheet = paste0(yr), col_names=T)
  #  planted <- read_csv("Data/ObservedLCmaps/PlantedArea_2000-2003.csv")

  # #From planted area data calculate number of cells for:
  # - Soybean + Maize  [A_plant]
  # - Cotton + Rice + Sugar_Cane + Bean + Sorghum + Wheat [OA_plant]

  #no data for first_crop maize in 2001 and 2002 so use 2003 data
  if(yr == 2001 | yr == 2002) {
    planted <- planted %>%
      mutate(A_plant_ha = first_crop_2003 + soybean)
  } else {
    planted <- planted %>%
      mutate(A_plant_ha = first_crop + soybean)
  }

  planted <- planted %>%
    mutate(OA_plant_ha = cotton + rice + sugarcane + bean + sorghum + wheat) %>%
    mutate(A_plant_cells = round(A_plant_ha / 2500, 0)) %>%
    mutate(OA_plant_cells = round(OA_plant_ha / 2500, 0))  #one cell = 2500ha

  #join the data
  joined <- left_join(mapped, planted, by = c("muniID" = "IBGE_CODE"))

  #previously used to check the join
  #(this is where issue with muni 5006275 was discovered
  #munis 4300001 and 4300002 are also missing, but these are large lakes with minimal agriculture
  #missing <- joined %>%
  #  filter(is.na(A_plant_cells))

  #calculate differences between mapped and planted areas (in cells)
  diffs <- calcDiffcs(joined)
  diffs <- diffs %>% filter(!is.na(A_plant_cells))  #drop NA

  #now update map
  #read muniID map -> get x,y,z
  #load the rasters
  #munis.r <- raster(munis.r)
  lc.r <- raster(paste0(input_path,"Data/Classified/LandCover",yr,"_",cname,".asc"))

  munis.t <- extractXYZ(munis.r, addCellID = F)
  lc.t <- extractXYZ(lc.r, addCellID = F)

  munis.t <- as.data.frame(munis.t)
  munis.t <- plyr::rename(munis.t, c("vals" = "muniID"))

  lc.t <- as.data.frame(lc.t)
  lc.t <- plyr::rename(lc.t, c("vals" = "lc"))

  #join observed land cover map (so have x,y,muniID,original LC
  lc_munis <- left_join(as.data.frame(munis.t), as.data.frame(lc.t), by = c("row" = "row", "col" = "col"))

  #note: missing cells after join
  #lcNA <- lc_munis %>% filter(is.na(lc))

  #for testing
  #this.muniID <- 4202073
  #lcs <- filter(lc_munis, muniID == this.muniID)
  #convs <- filter(j, muniID == this.muniID)
  #convertLCs(convs, lcs)

  final <- data.frame()

  #for testing
  #dummy <- c(3527603,3527603,3527504,3527504,3528205)

  #loop through all munis to update https://stackoverflow.com/a/13916342/10219907
  for(i in 1:length(unique(diffs$muniID))) {

    #for(i in 1:length(unique(dummy))) {

    #i <- 1 # for testing
    #this.muniID <- unique(dummy)[i]

    this.muniID <- unique(diffs$muniID)[i]

    lcm <- filter(lc_munis, muniID == this.muniID)
    js <- filter(diffs, muniID == this.muniID)

    this.conv <- convertLCs(js, lcm)

    #print(this.muniID)
    #print(lcm)
    #print(this.conv)

    if(i == 1) final <- this.conv
    else final <- bind_rows(final, this.conv)

  }

  #set final to a raster with same extent as inputs (to the same)with help from https://gis.stackexchange.com/questions/250149/assign-values-to-a-subset-of-cells-of-a-raster)
  final.r <- raster(munis.r)
  final.r[] <- NA_real_
  cells <- cellFromRowCol(final.r, final$row, final$col)
  final.r[cells] <- final$lc

  #becasue there are a few munis with no planted data we end up with some 'holes' in the data
  #fill those holes with the original lc data
  final.cov <- cover(final.r, lc.r)
  final.r <- mask(final.cov, munis.r)

  #protected and pasture, change to nature
  Lprotect <- raster(paste0(input_path,"Data/All_ProtectionMap.asc")) #read protected map #land protection is intially identical for all services
  final.r[final.r == 5 & Lprotect < 1] <- 1   #protected and pasture, change to nature

  writeRaster(final.r, paste0(input_path,"Data/Classified/LandCover",yr,"_",cname,"_Disagg.asc"), format = 'ascii', overwrite=T)

  if(sumTab){
    createSummaryTable(munis.r, yr, cname, disagg=TRUE)  #disagg must always be TRUE in this call
  }
}

################
#run

if(!dir.exists(paste0(input_path,"Data/Classified"))){
  dir.create(paste0(input_path,"Data/Classified"))
}

for(c in seq_along(cls)){

  classification <- read_excel(paste0(input_path,"Data/MapBiomas_CRAFTY_classifications_v4.xlsx"), sheet = cls[c], range="B1:C28", col_names=T)

  for(y in seq_along(yrs)){

    map <- raster(paste0(input_path,"Data/Unclassified/Brazil_",yrs[y],"_5km.asc"))  #read pre-classified data
    map <- reclassify(map, rcl=as.matrix(classification))                 #classify
    writeRaster(map, paste0(input_path,"Data/Classified/LandCover",yrs[y],"_",cls[c],".asc"), format = 'ascii', overwrite=T)  #output

    if(sumTab){
      createSummaryTable(munis.r, yrs[y], cls[c], disagg=FALSE)  #disagg must always be FALSE in this call (as dissagregation has not yet happened)
    }

    if(disaggregate) { disaggFn(yrs[y], cls[c]) }

  }
}


#' Populate Concentration Columns
#'
#' Creates ConcLow, ConcHigh, Uncen (0 if censored, 1 if uncensored) columns for Sample data frame for WRTDS study.
#'
#' @param rawData vector with value and code columns
#' @return concentrationColumns dataframe
#' @export
#' @examples
#' code <- c("","<","")
#' value <- c(1,2,3)
#' dataInput <- data.frame(value, code, stringsAsFactors=FALSE)
#' concentrationDF <- populateConcentrations(dataInput)
populateConcentrations <- function(rawData){  # rawData is a dataframe with value, code
  concentrationColumns <- as.data.frame(matrix(ncol=3,nrow=length(rawData$value)))
  colnames(concentrationColumns) <- c('ConcLow','ConcHigh','Uncen')
  concentrationColumns$ConcLow <- as.numeric(ifelse((rawData$code!="<" | is.na(rawData$code)),rawData$value,0))
  concentrationColumns$ConcHigh <- as.numeric(rawData$value)
  tempConcLow<-ifelse((rawData$code!="<" | is.na(rawData$code)),rawData$value,0)
  concentrationColumns$Uncen <- ifelse(tempConcLow==0,0,1)
  #Add if value = NA?
  return (concentrationColumns)  # returns ConcLow, ConcHigh, Uncen (0 if censored, 1 if uncensored)
}


#!/bin/env Rscript

# Copyright (c) 2015 Hanspeter Portner (dev@open-music-kontrollers.ch)
#
# This is free software: you can redistribute it and/or modify
# it under the terms of the Artistic License 2.0 as published by
# The Perl Foundation.
#
# This source is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# Artistic License 2.0 for more details.
#
# You should have received a copy of the Artistic License 2.0
# along the source as a COPYING file. If not, obtain it from
# http://www.perlfoundation.org/artistic_license_2_0.

f <- xzfile('bin.osc.xz', 'rb')

head <- readChar(f, 8)
srate <- readBin(f, 'integer', 1, 4, endian='big')

print(head)
print(srate)

a <- NULL
while(TRUE)
{
	time <- readBin(f, 'integer', 1, 4, endian='big')
	if(!length(time))
		break;
	size <- readBin(f, 'integer', 1, 4, endian='big')
	path <- readChar(f, 8) # '/blob000'
	fmt <- readChar(f, 4) # ',b00'
	len <- readBin(f, 'integer', 1, 4, endian='big')
	blob <- readBin(f, 'integer', len/2, 2, endian='big')
	a <- rbind(a, c(blob))
}

close(f)

pdf('read.pdf')
{
	mavg <- apply(a, c(1), mean)
	msd <- apply(a, c(1), sd)

	plot(mavg, type='l', ylim=c(0,1024))
	plot(msd, type='l', ylim=c(0,1024))

	#apply(a, c(1), function(o) {
	#	plot(o, type='l')
	#})
}
dev.off()


1 + for (x in 1:4) x


#' @title geomean
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
geomean <- function(x){
	x = exp(mean(log(x+median(x))))-median(x)
	return(x)
}


import(".", attach=TRUE)

if (is.null(module_name())) {
    library(testthat)
    library(dplyr)

    a = matrix(c(2,0,1,0,1,0), ncol=2, dimnames=list(c('x','y','z'), c('a','b')))
    b = setNames(c(1,2,0), c('x','y','z'))
    fit1 = lm(b ~ a)
    expect_equal(nrow(fit1), 2)
    expect_equal(fit1$a, c('a','b')) # column indices
    expect_equal(fit1$term, c('a','a')) # rhs of equation

    # fit a as one coefficients matrix
    fit2 = lm(b ~ a, atomic="a")
    expect_equal(nrow(fit2), 2)
    expect_equal(fit2$term, c('aa','ab'))

    c = matrix(c(1,1,2,2,1,1), ncol=2, dimnames=dimnames(a))
    fit3 = lm(a ~ b + c)
    idx = tidyr::crossing(c=colnames(c), a=colnames(a), term=c('b','c'))[c('a','c','term')]
    expect_equal(tbl_df(fit3[c('a','c','term')]), idx)

    fit4 = lm(a ~ c + b, group=c('a', 'c'))
    expect_equal(fit4 %>% arrange(a,c,term),
                 dplyr::filter(fit3, a==c) %>% arrange(a,c,term))
}


#NEON functional group tables.
#clear environment, source paths, packages and functions.
rm(list=ls())
library(data.table)
source('paths.r')

#set output paths.----
output.path <- NEON_taxa_fg.path

#load data.----
sv <- readRDS(NEON_SV.table_clean.path)
map <- readRDS(hierarch_filled.path)
map <- map$core.obs
fun <- readRDS(NEON_fun_clean.path)

#Assign functional groups.----
#Colin double checked everything stays in order.
#Things can't be both ECM and SAP in dirlichet. Creates a sum to 1 problem.
tax <- data.table(fun)
tax[grep('Ectomycorrhizal', tax$guild),Ectomycorrhizal := 1]
tax[is.na(Ectomycorrhizal),            Ectomycorrhizal := 0]
tax[grep('Saprotroph', tax$guild),          Saprotroph := 1]
tax[is.na(Saprotroph),                      Saprotroph := 0]
tax[grep('Arbuscular', tax$guild),          Arbuscular := 1]
tax[is.na(Arbuscular),                      Arbuscular := 0]
tax[grep('Patho', tax$guild),                 Pathogen := 1]
tax[is.na(Pathogen),                          Pathogen := 0]
#If you are ECTO you can't be SAP
tax[Ectomycorrhizal == 1, Saprotroph := 0]
#if you are ecto or sap you not path.
tax[Ectomycorrhizal == 1,   Pathogen := 0]
tax[     Saprotroph == 1,   Pathogen := 0]
#convert back to data.frame.
tax <- as.data.frame(tax)
rownames(tax) <- rownames(fun)

#Get counts of fucntional groups. (ECM, AM, SAP, PATH)
function_groups <- c('Ectomycorrhizal','Arbuscular','Saprotroph','Pathogen')
fun.list <- list()
tax$map.ID <- rownames(tax)
z <- data.table(cbind(tax,t(sv)))
for(i in 1:length(function_groups)){
  k <- z[eval(parse(text=function_groups[i]))== 1,]
  start <- ncol(tax) + 1
  out <- colSums(k[,start:ncol(k)])
  fun.list[[i]] <- out
}
fun.list <- data.frame(t(do.call('rbind',fun.list)))
colnames(fun.list) <- function_groups

#Get together abundances and seq_total.----
seq_total <- colSums(z[,start:ncol(z)])
seq_total <- seq_total[order(match(names(seq_total),rownames(fun.list)))]
other <- seq_total - rowSums(fun.list)
abundances <- cbind(other,fun.list)
rel.abundances <- abundances / seq_total

#get other IDs in here. deprecatedVialID does not match all products.----
    abundances$deprecatedVialID <- rownames(    abundances)
rel.abundances$deprecatedVialID <- rownames(rel.abundances)

    abundances <- merge(    abundances, map[,c('deprecatedVialID','geneticSampleID')],
                            by.x = 'deprecatedVialID', by.y = 'deprecatedVialID', all.x = T)
rel.abundances <- merge(rel.abundances, map[,c('deprecatedVialID','geneticSampleID')],
                            by.x = 'deprecatedVialID', by.y = 'deprecatedVialID', all.x = T)

#save output.----
dat.out <- list(abundances,rel.abundances,seq_total)
names(dat.out) <- c('abundances','rel.abundances','seq_total')
saveRDS(dat.out, output.path)


## Main file of the processing chain
## Mostly for documentation purposes; it takes way too long to actually run the whole thing.
## Instead, run the files mentioned manually. Many of them run in the terminal autonomously.

## Preprocessing ##

## Optical: preprocess PROBA-V data into a variety of indices

# Mask out clouds using built-in QC layer
source("optical/clean-builtin.r")

# Mask out clouds from NDVI even more using the time series method: produce a mask file
source("optical/clean-timeseries.r")
# Apply the mask file to get a directory of cleaned NDVI layers
source("optical/apply-timeseries-mask.r")

# Get a summer 2016 composite via maximum NDVI
source("optical/composite-probav.r")
# Calculate LSWI and OSAVI out of it, add a water mask, and merge all together
source("optical/calc-indices.r")

# Calculate harmonic parameters of NDVI
source("optical/get-harmonics.r")

## DEM: preprocess GLSDEM and EUDEM into a variety of indices

# Download and preprocess GLSDEM
source("elevation/get-dem.r")
# Preprocess EUDEM
source("elevation/process-eudem.r")
# Merge the two together
source("elevation/dem-merge.r")

## Validation data: preprocess and merge into a coherent file with everything

# Remove NAs because the algorithms cannot handle them
source("validation/remove-nas.r")
# Preprocess CCI land cover (for reference when gathering data only!)
source("validation/simplify-cci.r")
# Check consistency of validation data CSV and convert into SpatialPointsDataFrame
source("validation/process-csv.r")
# Merge everything together into a RasterStack/Brick to get the training/validation dataset with all covars
source("validation/merge-data.r")

## Classification: make use of coherent files to train and predict classification models

# Calculate error statistics and perform model optimisations:
# Fuzzy c-means
source("classification/classify-cmeans.r")
# Neural networks
source("classification/classify-nn.r")
# Gradient boosting
source("classification/classify-mgb.r")
# Random forest
source("classification/classify-rf.r")

# Perform full-tile predictions using optimised models:
# Control
source("classification/predict-dummy.r")
# Fuzzy c-means
source("classification/predict-cmeans.r")
# Neural networks
source("classification/predict-nn.r")
# Gradient boosting
source("classification/predict-mgb.r")
# Random forest
source("classification/predict-rf.r")


library(data.table); library(dplyr); library(magrittr); library(dtplyr)
library(scales)

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

colTrimmedMeans <- function(mat, top){
  prob <- 1-top/100
  apply(mat, 2, function(x){
      mean(x[x <= quantile(x, prob)], na.rm = T)
    })
}

colTrimmedSe <- function(mat, top){
  prob <- 1-top/100
  apply(mat, 2, function(x){
    sqrt(var(x[x <= quantile(x, prob)], na.rm = T)/length(x[x <= quantile(x, prob)]))
  })
}

countTrimmed <- function(mat, top){
  prob <- 1-top/100
  nrow(mat) # sum(mat[,1] < quantile(mat[,1], prob))
}

sumMatrix <- function(sublabels){
  flag <- 1
  # cat("7\n")
  for(label in sublabels){
    # cat("8\n")
    ifile <- sprintf("%s/%s/%s/%s.%s", idir_base, label, "ngsplot", "hm1", "txt")
    print(label)
    # ifiles <- sprintf("%s/%s/%s/%s.%s", idir_base, sublabels, sublabels, "avgprof", "txt")
    # cat("9\n")
    dt <- fread(ifile, header = T)
    # cat("10\n")
    if(flag == 1){
      ma <- matrix(0, nrow = dt %>% nrow, ncol = (dt %>%ncol)-4)
      print("Reset ma")
      flag <- 0
    }
    # if(!exists("ma")){
    #   ma <- matrix(0, nrow = dt %>% nrow, ncol = (dt %>%ncol)-4)
    #   print("Reset ma")
    # }
    # cat("11\n")
    ma <- ma + dt %>% select(-gid, -gname , -tid, -strand) %>% as.matrix()
    # cat("12\n")
    #   vc <- vc + dt %>% unlist
  }
  return(ma)
}

meanMatrix <- function(sublabels){
  flag <- 1
  # cat("7\n")
  for(label in sublabels){
    # cat("8\n")
    ifile <- sprintf("%s/%s/%s/%s.%s", idir_base, label, "ngsplot", "hm1", "txt")
    print(label)
    # ifiles <- sprintf("%s/%s/%s/%s.%s", idir_base, sublabels, sublabels, "avgprof", "txt")
    # cat("9\n")
    dt <- fread(ifile, header = T)
    # cat("10\n")
    if(flag == 1){
      ma <- matrix(0, nrow = dt %>% nrow, ncol = (dt %>%ncol)-4)
      print("Reset ma")
      flag <- 0
    }
    # if(!exists("ma")){
    #   ma <- matrix(0, nrow = dt %>% nrow, ncol = (dt %>%ncol)-4)
    #   print("Reset ma")
    # }
    # cat("11\n")
    ma <- ma + dt %>% select(-gid, -gname , -tid, -strand) %>% as.matrix()
    # cat("12\n")
    #   vc <- vc + dt %>% unlist
  }
  ma <- ma/length(sublabels)
  return(ma)
}

heatmapTrim <- function(vec_groups, metalabel, top = 1, max_value = NA){
  pdfname <- sprintf("%s/%s%s", odir_base, metalabel, ".heatmap.pdf")
  pdf(pdfname)

  for(group in vec_groups){
    sublabels <- labels[group == groups]
    print(group)

    # ma <- sumMatrix(sublabels)
    ma <- meanMatrix(sublabels)
    sel <- order(rowSums(ma, na.rm = T), decreasing = T)
    sel <- sel[seq_along(sel) > nrow(ma) * (top/100)]
    print(min(sel))
    print(max(ma[sel,]))

    N <- length(sel)

    mn <- sprintf("%s, %s (%s)", metalabel, group, experiment_name)
    sb <- paste0("top ", top, "% trimmed mean (N=", N, ")")
    plotHeatmap(ma[sel, ], main = mn, sub = sb, max_value = max_value, min_value = NA)
  }
  dev.off()
}

heatmapTrimFromArray <- function(arr, vec_groups, metalabel, top = 1, max_value = NA){
  pdfname <- sprintf("%s/%s%s", odir_base, metalabel, ".heatmap.pdf")
  pdf(pdfname)

  for(group in vec_groups){
    ma <- apply(arr[,,group == groups, drop = FALSE], 1:2, mean)
    print(group)

    sel <- order(rowSums(ma, na.rm = T), decreasing = T)
    sel <- sel[seq_along(sel) > nrow(ma) * (top/100)]
    print(min(sel))
    print(max(ma[sel,]))

    N <- length(sel)

    mn <- sprintf("%s, %s (%s)", metalabel, group, experiment_name)
    sb <- paste0("top ", top, "% trimmed mean (N=", N, ")")
    plotHeatmap(ma[sel, ], main = mn, sub = sb, max_value = max_value, min_value = NA)
  }
  dev.off()
}

cut2 <- function (x, breaks, labels = NULL, include.lowest = FALSE, right = TRUE,
                  dig.lab = 3L, ordered_result = FALSE, fixed_max, ...)
{
  if (!is.numeric(x))
    stop("'x' must be numeric")
  if (length(breaks) == 1L) {
    if (is.na(breaks) || breaks < 2L)
      stop("invalid number of intervals")
    nb <- as.integer(breaks + 1)
    dx <- diff(rx <- range(x, na.rm = TRUE))
    rx[2L] <- fixed_max
    if (dx == 0) {
      dx <- abs(rx[1L])
      breaks <- seq.int(rx[1L] - dx/1000, rx[2L] + dx/1000,
                        length.out = nb)
    }
    else {
      breaks <- seq.int(rx[1L], rx[2L], length.out = nb)
      breaks[c(1L, nb)] <- c(rx[1L] - dx/1000, rx[2L] +
                               dx/1000)
    }
  }
  else nb <- length(breaks <- sort.int(as.double(breaks)))
  if (anyDuplicated(breaks))
    stop("'breaks' are not unique")
  codes.only <- FALSE
  if (is.null(labels)) {
    for (dig in dig.lab:max(12L, dig.lab)) {
      ch.br <- formatC(0 + breaks, digits = dig, width = 1L)
      if (ok <- all(ch.br[-1L] != ch.br[-nb]))
        break
    }
    labels <- if (ok)
      paste0(if (right)
        "("
        else "[", ch.br[-nb], ",", ch.br[-1L], if (right)
          "]"
        else ")")
    else paste("Range", seq_len(nb - 1L), sep = "_")
    if (ok && include.lowest) {
      if (right)
        substr(labels[1L], 1L, 1L) <- "["
      else substring(labels[nb - 1L], nchar(labels[nb -
                                                     1L], "c")) <- "]"
    }
  }
  else if (is.logical(labels) && !labels)
    codes.only <- TRUE
  else if (length(labels) != nb - 1L)
    stop("lengths of 'breaks' and 'labels' differ")
  code <- .bincode(x, breaks, right, include.lowest)
  if (codes.only)
    code
  else factor(code, seq_along(labels), labels, ordered = ordered_result)
}

plotHeatmap <- function(mat, main, sub, max_value = NA, min_value = NA){
  require(grid)

  breaks <- 100
  pal <- colorRampPalette(c('white','blue'))
  pal <- pal(breaks)

  if(is.na(max_value)){
    max_value <- max(mat, na.rm = T)
  }
  if(is.na(min_value)){
    min_value <- min(mat, na.rm = T)
  }

  roworder <- order(rowSums(mat, na.rm = T), decreasing = T)

  grid.newpage()
  pushViewport(plotViewport(c(1,1,1,1)))
  col_ratio <- unit(c(1,1,4,1), c("null","cm", "null", "null"))
  pushViewport(viewport(layout = grid.layout(5, length(col_ratio), heights = unit(c(1, 1, 2,12, 1), c("lines", "lines", "lines", "null", "line") ), widths=col_ratio)))

  pushViewport(viewport(layout.pos.row = 4, layout.pos.col = 3))
  plotHeatmap2(mat[roworder,], breaks, pal, max_value)
  grid.rect(gp = gpar(fill = NA, col = "grey", alpha = 0.5))
  pushViewport(viewport(xscale = c(min(at), max(at))))
  grid.xaxis(gp = gpar(cex = 0.5), at = at, label = lb)
  popViewport()

  popViewport()

  pushViewport(viewport(layout.pos.row = 3, layout.pos.col = 3))
  plotColorKey(pal[1:breaks], min_value, max_value)
  popViewport()

  pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 3))
  grid.text(main)
  popViewport()

  pushViewport(viewport(layout.pos.row = 2, layout.pos.col = 3))
  grid.text(sub, gp = gpar(cex = 0.8))
  popViewport()

  popViewport()
}

plotHeatmap2 <- function(mat, breaks, pal, fixed_max){
  nr <- nrow(mat)
  grid.raster(matrix(pal[as.numeric(cut2(mat, breaks, fixed_max = fixed_max))], nrow = nr),
              interpolate = F, width =1, height = 1)
}
plotColorKey <- function(colors, min_color, max_color){
  pushViewport(viewport(layout = grid.layout(
    1,2,
    widths = unit(c(4,1), c("null","null"))
  )))
  pushViewport(viewport(layout.pos.row = 1, layout.pos.col = 2))

  grid.raster(matrix(colors,nrow=1), y = 0.25, interpolate = F, width = 1, height = 0.5, vjust = 0)
  grid.rect(x=0, y = 0.25, width=1, height = 0.5, gp = gpar(fill = NA, col="black"), vjust = 0, hjust = 0)

  grid.text(min_color, x=0, y=0.24, hjust = 0, vjust = 1, gp = gpar(cex = 0.5))
  grid.text(sprintf("%.3f", max_color), x=1, y=0.24, hjust = 1, vjust = 1, gp = gpar(cex = 0.5))

  popViewport()
  popViewport()
}


library( "rmacrolite" )

# # Setup MACRO directory (if needed)
# rmacroliteSetModelVar( "C:/swash/macro" )

#   Path to an example par-file
par_file_path <- system.file( "par-files",
    "chat_winCer_GW-X_900gHa_d182.par",
    package = "rmacrolite" )

#   Import the example par-file
par_file <- rmacroliteImportParFile(
    file = par_file_path )

#   Fetch the current parametrization
rmacroliteCropUptF( x = par_file )
    # [1] 0.9

#   Modify the parameter
par_file2 <- par_file
rmacroliteCropUptF( x = par_file2 ) <- 0.5

#   Check the result
cuf <- rmacroliteCropUptF( x = par_file2 )
cuf
    # [1] 0.5

#   Internal control
if(cuf != 0.5 ){
    stop( "Test of rmacroliteCropUptF() failed" ) }

#   Clean-up
rm( par_file_path, par_file, par_file2, cuf  )


library(data.table)
library(ggplot2)
library(ggbeeswarm)
library(patchwork)
source('../config.r')
source('../utils.r')

DT_cond_proxy <- fread('mod23_cond_proxy.csv')
DT_cond_proxy_bs <- fread('mod23_cond_proxy_bs.csv')
DT_cond_target <- fread('mod23_cond_target.csv')
DT_cond_target_bs <- fread('mod23_cond_target_bs.csv')

plot_corr <- function(data, data_mean, data_swarm, title, show.xlab = T)
{
  set.seed(33)
  data_swarm <- data[,.(coef = sample(coef, 200, replace = F)),
                     by = .(target, family, name)]

  this_colors <- with(color_cats, c(orange, `blueish green`, blue))
  fig <- ggplot(data = data) +
    aes(y = coef, fill = target, color = target, x = name) +
    geom_hline(yintercept = 0, linetype = 'dashed', alpha = 0.8) +
    stat_summary(fun.data = my_quants, geom = 'boxplot', outlier.shape = NA,
                 alpha = 0.3, width = 0.8, size=0.8) +
    stat_summary(fun.data = my_quants, geom = 'errorbar', width = 0.5) +
    geom_beeswarm(
      data = data_swarm,
      size = 0.7, cex = 0.8, alpha = 0.2, priority = "random") +
    facet_grid(.~target) +
    scale_color_manual(values = this_colors) +
    scale_fill_manual(values = this_colors) +
    scale_x_discrete(label = c(
      "# Cigarettes smoked\n(Pack-Years)",
      "Sleep duration (hours)",
      "Metabolic Equivalent Task\n(minutes/week)",
      "# Alcoholic beverages")) +
    my_theme +
    coord_flip(ylim = c(-0.27, 0.27)) +
    guides(
      color = guide_legend(nrow = 1, label.hjust = 1, title = element_blank()),
      fill = guide_legend(nrow = 1, label.hjust = 1, title = element_blank())
    ) +
    theme(
      legend.position = "none",
      legend.justification = "left",
      panel.grid.major.y = element_line(size = 1.5)
      # plot.title = element_text(vjust=-1.5, hjust=1.5)
    ) +
    labs(
      title = title,
      x = element_blank())

  if (show.xlab) {
    fig <- fig + labs(
      y = bquote(
        beta[proxy]%+-%scriptstyle(bootstrap-based~uncertainty~estimates)))
  } else {
    fig <- fig + labs(y = element_blank()) + theme(
      axis.text.x = element_blank(),
      axis.ticks.x = element_blank())
  }
  return(fig)
}

(
  fig_corr_proxy <- plot_corr(
    data = DT_cond_proxy_bs,
    data_mean = DT_cond_proxy,
    show.xlab = F,
    title = element_blank())
)

(
  fig_corr_target <- plot_corr(
    data = DT_cond_target_bs,
    data_mean = DT_cond_target,
    title = element_blank())
)

big_fig <- (fig_corr_proxy / fig_corr_target) +
  plot_annotation(
    title = 'Specific associations for proxy and target measures with health-related habits')

my_ggsave("figure_2_supp_3",
          plot = big_fig,
          width = 12, height = 6)


#' @title calcTier
#'
#' @description
#' Estimate engine NOx tier from the vessel's keel-laid year for C3 vessels.

#'@param engineType Engine type (vector of strings) (see
#'\code{\link{calcEngineType}}). Valid values are: \itemize{
#'\item "SSD"
#'\item "MSD"
#'\item "MSD-ED"
#'\item "GT"
#'\item "GT-ED"
#'\item "ST"
#'\item "LNG"
#'}
#' @param keelLaidYear Keel-laid year (vector of ints). If not available,
#' interpolate from build date
#' @param shipCategory Ship category (vector of ints) (see
#' \code{\link{calcShipCategory}}). Valid values are:
#' \itemize{
#'  \item 1
#'  \item 2
#'  \item 3
#' }
#'
#' @details
#' This function is designed to determine the engine NOx tier for C3 vessels.
#' Therefore, it will return "None" for C1 or C2 vessels.
#'
#' "Tier 0" is returned for steam turbine, gas turbine, and LNG engines, as well
#' as for diesel engines that were keel-laid prior to Tier 1 taking effect
#' (2000).
#'
#' "Tier 1", "Tier 2", and "Tier 3" refer to Tier I, Tier II, and Tier III,
#' respectively.
#'
#' @return
#' \code{tier}, a factorized vector with possible levels of: \itemize{
#'  \item "None" (used for C1/C2 vessels)
#'  \item "Tier 0"
#'  \item "Tier 1"
#'  \item "Tier 2"
#'  \item "Tier 3"
#' }
#
#' @references
#'\href{https://nepis.epa.gov/Exe/ZyPURL.cgi?Dockey=P1005ZGH.TXT}{EPA. 2009.
#'"Regulatory impact analysis: Control of emissions air pollution from category
#'3 marine diesel engines." Ann Arbor, MI: Office of Transportation and Air
#'Quality. US Environmental Protection Agency. Pg 3-118:119}
#'
#'@seealso \itemize{
#' \item \code{\link{calcEngineType}}
#' \item \code{\link{calcShipCategory}}
#'}
#'
#' @examples
#' calcTier(c("MSD","GT","LNG","SSD"),c(1985, 2011, 2001,2004),c(3,3,3,2))
#'
#' @export

calcTier<-function(engineType, keelLaidYear,shipCategory){
  tier<- ifelse(shipCategory==3,
            ifelse(engineType%in%c("ST","GT","GT-ED","LNG") | keelLaidYear<2000,
                   "Tier 0",
                   ifelse(keelLaidYear<2011,
                          "Tier 1",
                          ifelse(keelLaidYear<2016,
                                 "Tier 2",
                                 "Tier 3")))
                ,
    "None"
  )
  tier<-as.factor(tier)
  return(tier)
}


# introduction
# the purpose of this script is to desribe the characteristics of UAZCC LTBC Qualtrics registrations by:
# 1. getting data from qualtrics
# 2. tidy data
# 3. generate tables, charts, and maps

# setup ----

# packages
library(here)
library(tidyverse)
library(qualtRics)
library(zipcodeR)
library(leaflet)
library(ggthemes)

# load list of surveys
surveys <- all_surveys()
# display
surveys

# select zoom registration survey & inspect
zoom_reg <- fetch_survey(surveys$id[6])
glimpse(zoom_reg)

# exploratory data analysis ----
# which states?
distinct(zoom_reg, Q4_3)

# tidy data ----
table_zoom_reg <- zoom_reg %>%
  select(Q2_3, Q4_2, Q4_3, Q4_4, LocationLatitude, LocationLongitude) %>%
  arrange(Q2_3) %>%
  unique() %>%
  mutate(email = str_extract(Q2_3, "@.+"),
         zipcode = str_extract(Q4_2, "[\\d]{5}")) %>%
  select(email,
         zipcode,
         state = Q4_3,
         org = Q4_4)

table_zoom_reg$email <- str_to_lower(table_zoom_reg$email)

# inspect
glimpse(table_zoom_reg )

# save data to csv
write_csv(table_zoom_reg, "data/tidy/ltbc_registration.csv")

# save data to rds
write_rds(table_zoom_reg, "data/tidy/ltbc_registration.rds")

# prepare data for mapping ----
zoom_zips <- table_zoom_reg %>%
  count(zipcode) %>%
  arrange(desc(n)) %>%
  drop_na()

# print to console
zoom_zips

# save usa zip code to environment
zip_db <- zip_code_db

# match up zip codes from qualtrics with usa database
zoom_zips_map <- inner_join(zoom_zips, zip_db, by = "zipcode") %>%
  drop_na()

# inspect
glimpse(zoom_zips_map)

# generate map
leaflet(data = zoom_zips_map) %>%
  addTiles() %>%
  addMarkers(~lng, ~lat)

# data processing ----
# count unique email domain and save to csv
table_zoom_reg %>%
  count(email) %>%
  drop_na() %>%
  arrange(desc(n)) %>%
  write_csv("data/tidy/ltbc_registration_email.csv")

# plot chart of count of unique email domain
table_zoom_reg %>%
  count(email) %>%
  drop_na() %>%
  arrange(desc(n)) %>%
  ggplot(mapping = aes(x = n, y = reorder(email, n))) +
  geom_col() +
  labs(title = "email domain",
       x = "",
       y = "") +
  theme_classic()

# save plot of email to disk
ggsave(
  filename = "email.png",
  device = "png",
  path = "figures/",
  dpi = 100,
  limitsize = TRUE
)

# plot chart of count of unique zip code
table_zoom_reg %>%
  count(zipcode) %>%
  drop_na() %>%
  arrange(desc(n)) %>%
  ggplot(mapping = aes(x = n, y = reorder(zipcode, n))) +
  geom_col() +
  labs(title = "Zip Code",
       x = "",
       y = "") +
  theme_classic()

# save plot of zipcode to disk
ggsave(
  filename = "zipcode.png",
  device = "png",
  path = "figures/",
  dpi = 100,
  limitsize = TRUE
)

# count unique zipcode and save to csv
table_zoom_reg %>%
  count(zipcode) %>%
  drop_na() %>%
  arrange(desc(n)) %>%
  write_csv("data/tidy/ltbc_registration_zipcode.csv")

# plot chart of count of unique state
table_zoom_reg %>%
  count(state) %>%
  drop_na() %>%
  arrange(desc(n)) %>%
  ggplot(mapping = aes(x = n, y = reorder(state, n))) +
  geom_col() +
  labs(title = "State",
       x = "",
       y = "") +
  theme_classic()

# save plot of state to disk
ggsave(
  filename = "state.png",
  device = "png",
  path = "figures/",
  dpi = 100,
  limitsize = TRUE
)

# count unique zipcode and save to csv
table_zoom_reg %>%
  count(state) %>%
  drop_na() %>%
  arrange(desc(n)) %>%
  write_csv("data/tidy/ltbc_registration_state.csv")


# Recycle bin for codes
# tpm
ft_1 <- ft_0 %>% select(-c(Chr:Strand)) %>% pivot_longer(cols = -c(1:2), names_to = "sample_id", values_to = "raw_ct") %>% filter(raw_ct>0) %>% mutate(sample_id = gsub("data\\/mapped_STAR\\/Aligned\\.out\\.bam\\:", "", sample_id), sample_id = gsub("-", "\\.", sample_id), l_ef = pmax(0, Length - avg_fragment_len) + 1, ct_rate = raw_ct/l_ef) %>% group_by(sample_id) %>% mutate(tpm = ct_rate/sum(ct_rate)*1E6) %>% ungroup
# vocano plot
plot_volcano=function(dat){
    g = ggplot(data = dat, aes(x=logFC, y = -log10(adj.P.Val), col=diffexpressed, label=difflabel)) +
        geom_point() +
        #geom_vline(xintercept=c(-1, 1), col="red") +
        geom_hline(yintercept=-log10(0.1), col="red") +
        geom_text_repel() +
        scale_color_manual(values = c(No="gray70", Yes="red"), name = "differentiated\nexpressed") +
        labs(x = "Log2 Fold Change", y = "-log10(pValue)") +
        theme_minimal()
    g
}

# limma codes
gene_to_keep = ft_wk %>% mutate(Flag = tpm>=10) %>% group_by(Geneid) %>% summarise(N_Flag = sum(Flag)) %>% filter(N_Flag>0.2*nsamples) %>% pull(Geneid)

    dat_mat = ft_wk %>% filter(Geneid %in% gene_to_keep) %>% pivot_wider(id_cols = Geneid, names_from = sample_id, values_from = tpm_log2, values_fill = log2(3)) %>% column_to_rownames(var = "Geneid")

    grps = mt_wk$BirthMode[match(colnames(dat_mat), mt_wk$TubeID)]

    # dat_mat = ft_wk %>% pivot_wider(id_cols = Geneid, names_from = sample_id, values_from = raw_ct, values_fill = 0) %>% column_to_rownames(var = "Geneid")
    # x = DGEList(counts = dat_mat, genes = ft_0[ft_0$Geneid %in% rownames(dat_mat), c("Geneid", "Length")])
    #
    # grps = mt_wk$BirthMode[match(colnames(dat_mat), mt_wk$TubeID)]
    # x$samples$group = grps
    #
    # cpm <- cpm(x)
    # lcpm <- cpm(x, log = T)
    #
    # L <- mean(x$samples$lib.size) * 1e-6
    # M <- median(x$samples$lib.size) * 1e-6
    # c(L, M)
    #
    # summary(lcpm)
    #
    # keep.exprs <- filterByExpr(x, group = grps)
    # x <- x[keep.exprs,, keep.lib.sizes=FALSE]
    #
    # lcpm.cutoff <- log2(10/M + 2/L)
    # col <- brewer.pal(nsamples, "Paired")
    # par(mfrow=c(1,2))
    # plot(density(lcpm[,1]), col=col[1], lwd=2, ylim=c(0,0.26), las=2, main="", xlab="")
    # title(main="A. Raw data", xlab="Log-cpm")
    # abline(v=lcpm.cutoff, lty=3)
    # for (i in 2:nsamples){
    #     den <- density(lcpm[,i])
    #     lines(den$x, den$y, col=col[i], lwd=2)
    # }
    #
    # lcpm <- cpm(x, log=TRUE)
    # plot(density(lcpm[,1]), col=col[1], lwd=2, ylim=c(0,0.26), las=2, main="", xlab="")
    # title(main="B. Filtered data", xlab="Log-cpm")
    # abline(v=lcpm.cutoff, lty=3)
    # for (i in 2:nsamples){
    #     den <- density(lcpm[,i])
    #     lines(den$x, den$y, col=col[i], lwd=2)
    # }
    #
    # x <- calcNormFactors(x, method = "TMM")
    #
    # lcpm <- cpm(x, log=TRUE)
    # par(mfrow=c(1,2))
    #
    # cols = BM_colors[grps]
    # plotMDS(lcpm, labels = grps, col = cols)
    #
    # design <- model.matrix(~ 0 + as.factor(grps))
    # colnames(design) = c("CS", "VF")
    # contrast.matrix = makeContrasts(CS-VF, levels = design)
    #
    # par(mfrow=c(1,2))
    # v <- voom(x, design, plot=TRUE)
    # v
    #
    # vfit <- lmFit(v, design)
    # vfit <- contrasts.fit(vfit, contrasts=contrast.matrix)
    # efit <- eBayes(vfit)
    # plotSA(efit, main="Final model: Mean-variance trend")
    #
    # summary(decideTests(efit))

    cols = BM_colors[grps]
    plotMDS(dat_mat, labels = grps, col = cols)

    design <- model.matrix(~ 0 + as.factor(grps))
    colnames(design) = c("CS", "VF")
    rownames(design) = colnames(dat_mat)
    contrast.matrix = makeContrasts(CS-VF, levels = design)

    fit <- lmFit(dat_mat, design)
    fit2 <- contrasts.fit(fit, contrasts = contrast.matrix)
    efit <- eBayes(fit2)
    summary(decideTests(efit, adjust.method = "fdr", p.value = 0.10))

    de_gene = topTable(efit, coef = "CS - VF", adjust.method = "fdr", number = Inf) %>% rownames_to_column(var = "gene") %>% mutate(diffexpressed = ifelse(adj.P.Val<=0.1, "Yes", "No"), difflabel = ifelse(diffexpressed=="Yes", gene, NA))
    plot_volcano(de_gene)


#' #This source code is provided under the BSD license and is provided AS IS with no warranty or guarantee of fit for purpose.  See the project's LICENSE.txt for details.
#' #Copyright Thomson Reuters 2013. All rights reserved.

#' Assumes that the days on which some of the largest mcap companies didnt trade is not a valid trading day
#' @author Ian MacGillivray and Sameena Shah
#' @param start.date start.date in Y-m-d format
#' @param end.date end.date in Y-m-d format
#' @return trade.dates vector
#' @export
get.trading.dates.from.db <- function(start.date='2011-01-01', end.date='2011-02-01'){

# We will get price information for a number of big companies, any date with no price information is assumed not to be a trading day.
# seccode	ric
# 47922		MS.N
# 8352		BAC.N
# 30655		GS.N
# 29629		GE.N
# 8156		BAC.N
# 6027		AAPL.OQ
# 75538		TRI.N  -- we are assuming all these companies won't go bankrupt at the same time. But, now that TRI.N is in there, if they are all bankrupt then I don't need to worry about maintaining this code.

price.dates <- seq(as.Date(start.date),to=as.Date(seq(as.Date(end.date),by="1 day",length.out=30)[30]),by="1 day")
seccodes <- c(47922,8352,30655,29629,8156,6027,75538)
close.prices <- get.adj.daily.close(price.dates,seccodes,per.seccode=1)
dates.from.db <- rownames(close.prices[apply(is.na(close.prices),1,sum) < length(seccodes),])
trade.dates <- dates.from.db[dates.from.db < end.date]
	if(length(trade.dates) < length(dates.from.db))
		trade.dates <- c(trade.dates, dates.from.db[length(trade.dates)+1])

	return(trade.dates)
}


url <- "http://www.ats.ucla.edu/stat/paperexamples/atkins_mlm/Atkins_JFP_data.txt"
data <- read.table(url,  header=TRUE, sep="\t")
summary(data)
plot(data$TIME, data$DAS)


# Information about code:
# This code corresponds to a chapter in my MSc thesis for
# Chapter 3, the section on Determinants of taxonomic resources flow: visualisation
# @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

# Shiny App: Visualising resource flow - from taxonomist country of residence to type locality

# Libraries
library(shiny)
library(data.table)
library(networkD3)

# TODO: changes with time

# Constants / parameters
DEFAULT_THRESHOLD <- 0

# Read data (residing in data folder)
lu <- fread("data/lookup-country-codes.csv", encoding="UTF-8", na.strings="")
t <- fread("data/2019-09-22-flow-map-type-loc-des-country.csv", encoding="UTF-8", na.strings="")

# Create labels for countryInput
nodes_lab <- sort(paste0(lu$Country, ifelse(is.na(lu$Col_status), "", paste0(" (", lu$Col_status, ")")), " - ", lu$DL))

# Update data function
update <- function(threshold=DEFAULT_THRESHOLD, country=NA, typeInput=c()) {

  t2 <- t[no_flow == "FALSE"]; no_flow <- t[no_flow=="TRUE"]

  # Subset dataset
  if (is.na(country) | country == "All") {

    t2 <- t2[N>threshold]

  } else {

    if (all(c(1,2) %in% typeInput)) {
      t2 <- t2[N>threshold & (ori == country | des == country)]
    } else if (1 %in% typeInput) {
      t2 <- t2[N>threshold & (ori == country)]
    } else if (2 %in% typeInput) {
      t2 <- t2[N>threshold & (des == country)]
    } else if (length(typeInput) <= 0) {
      nodes <- data.frame(idx=integer(), label=character())
      t2 <- data.frame(ori=character(), des=character())
    }

  }

  # Create network dataset - indexing from 0
  if (dim(t2)[1] == 0) {

    nodes <- data.frame(idx=integer(), label=character())
    t2 <- data.frame(ori=character(), des=character())

  } else {

    nodes <- unique(data.frame(label=c(t2$ori, t2$des)))
    nodes <- data.table(nodes); nodes <- nodes[order(label)]
    nodes$idx <- seq(0, dim(nodes)[1]-1, 1)
    nodes <- merge(nodes, no_flow[, c("ori", "N")], by.x="label", by.y="ori", all.x=T, all.y=F)
    nodes <- merge(nodes, lu, by.x="label", by.y="DL")
    nodes$Econ_status <- factor(nodes$Econ_status, levels=c("High income",
                                                            "Upper middle income",
                                                            "Lower middle income",
                                                            "Low income",
                                                            "Unclassed"))

    t2 <- merge(t2, nodes[, c("label", "idx")], by.x="ori", by.y="label", all.x=T, all.y=F)
    t2 <- merge(t2, nodes[, c("label", "idx")], by.x="des", by.y="label", all.x=T, all.y=F, suffixes=c("_from", "_to"))
    # t2$Nodesize <- t2$N/threshold

  }

  list(t2=t2, nodes=nodes)

}

# UI component of shiny app
ui <- fluidPage(
  verticalLayout(
    inputPanel(
      sliderInput("thresholdInput", "Minimum threshold",
                  min=0, max=floor(sort(t$N)[length(t$N)-1]/10)*10,
                  value=DEFAULT_THRESHOLD, post=" N spp.",
                  step=5),
      selectInput("nodeColourInput", "Node colour by",
                  c("Country", "Colonialism", "Economic status"), selected=NULL, multiple=F),
      selectInput("countryInput", "Country", # sorted by Discover Life codes
                  c("All", nodes_lab), selected=NULL, multiple=F),
      conditionalPanel(
        condition = "input.countryInput != 'All'",
        checkboxGroupInput("typeInput", "Type (Source or Target)",
                          choices = list("Source" = 1, "Target" = 2),
                          selected = c(1, 2))
      )
    ),
    mainPanel(
      sidebarLayout(
        sidebarPanel(tableOutput("networkTable"),
                     "Legend:",
                     "Src = Source i.e., country of taxonomist",
                     "Tgt = Target i.e. country of type species",
                     "N = N species described",
                     width=2),
        mainPanel(forceNetworkOutput("network", height="500px"), width=10)
      ),
      width=12
    )
  )
)

# Server component of shiny app
server <- function(input, output) {

  # Update data
  update_data <- reactive({
    parsed_country <- unlist(strsplit(input$countryInput, " - "))[2]
    if(input$countryInput == "All") {
      updated <- update(input$thresholdInput, parsed_country)
    } else {
      updated <- update(input$thresholdInput, parsed_country, input$typeInput)
    }
    updated
  })

  # Output plots
  clickJS <- 'd3.selectAll(".node").on("click", function(d){ alert(d.name + ": " + d.nodesize + "spp."); })'
  output$network <- renderForceNetwork({

    updated <- update_data()

    if (dim(updated$t2)[1] == 0) {

    } else {

      grouping <- ifelse(input$nodeColourInput == "Country", "label",
        ifelse(input$nodeColourInput == "Colonialism", "Col_status",
          ifelse(input$nodeColourInput == "Economic status", "Econ_status", "")))

      legend_status <- ifelse(input$nodeColourInput == "Country", FALSE, TRUE)

      forceNetwork(
        Links = updated$t2, Nodes = updated$nodes,
        Source = "idx_from", Target = "idx_to", Value = "N",
        colourScale = JS("d3.scaleOrdinal(d3.schemeCategory10);"),
        NodeID = "label", Group=grouping, Nodesize="N", arrows=T, zoom=T, opacity=.8,
        radiusCalculation = JS("Math.sqrt(d.nodesize)"),
        linkWidth = JS("function(d) { return d.value == 1 ? 1 : Math.log(d.value, 2); }"),
        charge=-10000/((input$thresholdInput/200+1)), fontFamily="Calibri",
        fontSize=40, opacityNoHover = 1, clickAction=clickJS, legend=legend_status)
    }
  })

  output$networkTable <- renderTable({

    updated <- update_data()

    if(dim(updated$t2)[1] >=1) {
      tableshow <- updated$t2[,c("ori", "des", "N")]
      names(tableshow) <- c("Src", "Tgt", "N")
      tableshow
    } else { data.frame(Comment=c("No data")) }

  })

}

# Run app
shinyApp(ui = ui, server = server)


library(data.table)
library(pheatmap)
library(dplyr)
library(tidyverse)
library(ggplot2)
library(RColorBrewer)
library(fgsea)
library(GenomicRanges)

file <- "pacbio_rep2.hbv_huh1.taps.read.CG.details.xls"
meth <- read.delim(file, sep="\t", quote ="", stringsAsFactors = FALSE)
meth <- meth[,c(1,grep("pos.*seq",colnames(meth)))]
# assign TG|CA as methylation
for(i in 2:ncol(meth)){
  meth[,i] <- gsub("pos.*:","",meth[,i])
  meth[meth[,i]=="TG" | meth[,i]=="CA", i] <- 1
  meth[meth[,i]=="CG", i] <- 0
  meth[meth[,i]!="0" & meth[,i]!="1",i] <- NA
  meth[,i] <- as.numeric(meth[,i])
}

meth <- meth[order(apply(meth[,2:12],1,function(x){sum(x[!is.na(x)])})),-c(grep("pos885|pos1167|pos1328|pos1376|pos1423|pos1489|pos1534|pos1849|pos1942|pos1994|pos2497|pos2696|pos2802",colnames(meth)))]
# meth$cgi <- apply(meth[,2:12],1,function(x){sum(x[!is.na(x)])})
# methlist <- list()
# methlist[["pos2284"]] <- meth[meth$pos2284_seq==1,1]
# methrank <- meth$cgi
# names(methrank) <- meth[,1]
# fgseaRes <- fgsea(pathways = methlist,
#                   stats = methrank,
#                   minSize=15,
#                   maxSize=500,
#                   nperm=1000)
# write.table(meth,
#   "pacbio_rep2.hbv_huh1.taps.read.tmp",
#   sep = "\t",
#   quote = F,
#   row.names = F,
#   col.names = T
# )
# colnames(meth) <- gsub("_seq|pos","",colnames(meth))

pheatmap(meth[,-1],filename = "hbv.readmeth.pdf",cluster_rows=FALSE,cluster_cols = FALSE,show_rownames = FALSE, width=8, height=2.5, res=100,
         color = colorRampPalette(c("white", "steelblue"))(2))

cors <- c()
selmeth <- meth[,-c(1,41:51)]
for(i in 1:ncol(selmeth)){
  for(j in 1:ncol(selmeth)){
    n1 <- cor(selmeth[complete.cases(selmeth[,c(i,j)]),c(i,j)])[1,2]
    n2 <- phicoef(selmeth[complete.cases(selmeth[,c(i,j)]),i]==1, selmeth[complete.cases(selmeth[,c(i,j)]),j]==1)
    cors <- rbind(cors,
    c(colnames(selmeth)[i], colnames(selmeth)[j], n1,n2))
  }
}
cors <- as.data.frame(cors, stringAsFactor=FALSE)
colnames(cors) <- c("pos1","pos2","cor","phicoef")
cors$cor <- as.numeric(as.character(cors$cor))
cors$cor[cors$cor==1] <- 0
cors.w <- spread(cors[,-4],key=pos2,value=cor)
cors.w <- cors.w[order(as.numeric(as.character(gsub("pos|_seq","",cors.w$pos1)))),
                 c(1,order(as.numeric(as.character(gsub("pos|_seq","",colnames(cors.w))[-1])))+1)]
cors.w[,-1] <- apply(cors.w[,-1],2, function(x){as.numeric(as.character(x))})

pheatmap(cors.w[,-1],filename = "hbv.readmeth.cor.pdf",cluster_rows=FALSE,cluster_cols = FALSE,show_rownames = FALSE,
         color = colorRampPalette(c("steelblue","white", "salmon"))(100), breaks =seq(-0.65,0.65,0.013))

### only on selected regions ###

pheatmap( cor(meth[,-c(1,41:51)]),filename = "hbv.readmeth.cor.sel.pdf",cluster_rows=FALSE,cluster_cols = FALSE,show_rownames = FALSE,
         color = colorRampPalette(c("steelblue","white", "salmon"))(100), breaks =seq(-1,1,0.02))

counts <- c()
selmeth <- meth[,-c(1,41:51)]
for(i in 1:ncol(selmeth)){
  for(j in 1:ncol(selmeth)){
    n <- sum(selmeth[,i]=="1" & selmeth[,j]=="1", na.rm=TRUE)/nrow(selmeth[complete.cases(selmeth[,c(i,j)]),])
    counts <- rbind(counts,
    c(colnames(selmeth)[i], colnames(selmeth)[j], n))
  }
}
counts <- as.data.frame(counts)
colnames(counts) <- c("pos1","pos2","mC")
counts.w <- spread(counts,key=pos2,value=mC)
counts.w <- counts.w[order(as.numeric(as.character(counts.w$pos1))),
                     c(1,order(as.numeric(as.character(colnames(counts.w)[-1])))+1)]
counts.w[,-1] <- apply(counts.w[,-1],2, function(x){as.numeric(as.character(x))})
maxc <- max(as.numeric(as.character(counts$mC)))
pheatmap(counts.w[,-1],filename = "hbv.readmeth.sel.count.pdf",cluster_rows=FALSE,cluster_cols = FALSE,show_rownames = FALSE,
         color = colorRampPalette(c("white", "salmon"))(100), breaks =seq(0,maxc,maxc/100))


#' Plot age composition by fleet
#'
#' Compare observed and predicted age composition by year.
#' @param asap name of the variable that read in the asap.rdat file
#' @param fleet.names names of fleets
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @param liz.palette color definitions
#' @param is.catch.flag true means only catch plotted, false also plots discards (defaults to TRUE)
#' @export

PlotCatchAgeComp <- function(asap,fleet.names,save.plots,od,plotf,liz.palette,is.catch.flag=TRUE){
  par(mar=c(4,4,2,2), oma=c(1,1,1,1), mfcol=c(5,3)  )
  cc=0
  for (i in 1:asap$parms$nfleets) {
    acomp.obs <- as.data.frame(asap$catch.comp.mats[4*(i-1)+1] )
    acomp.pred <- as.data.frame(asap$catch.comp.mats[4*(i-1)+2] )
    catch.yrs = which(asap$fleet.catch.Neff.init[i,]>0)
    my.title <- "Catch"
    my.save <- "Catch.Age.Comp.F"
    if (!is.catch.flag){
      acomp.obs <- as.data.frame(asap$catch.comp.mats[4*(i-1)+3] )
      acomp.pred <- as.data.frame(asap$catch.comp.mats[4*(i-1)+4] )
      catch.yrs = which(asap$fleet.discard.Neff.init[i,]>0)
      my.title <- "Discards"
      my.save <- "Discard.Age.Comp.F"
    }
    if (length(catch.yrs)>0){
      cc=cc+1
      plot(1:10,1:10,type='n',axes='F',xlab="",ylab="")
      box()
      text(5,7,paste("Fleet ",i))
      text(5,5,fleet.names[i],cex=0.85)
      arrows(5,3,5,1,length=0.1)
      title (my.title, outer=T, line=0 )

      for (j in 1:length(catch.yrs)) {
        cc=cc+1
        plot(seq(asap$fleet.sel.start.age[i],asap$fleet.sel.end.age[i]), acomp.obs[catch.yrs[j],] ,
             type='p', col=liz.palette[i],
             pch=1, xlab="Age", ylab="Proportion at Age", ylim=c(0, 1.1 ) )
        lines(seq(asap$fleet.sel.start.age[i],asap$fleet.sel.end.age[i]), acomp.pred[catch.yrs[j],] ,
              col=liz.palette[i],  lwd=2)
        title(paste0("Year = ", as.numeric(names(catch.yrs[j]))), outer=F )
        if (cc%%15==0)  {
          title (my.title, outer=T, line=0 )
          if (save.plots) savePlot(paste0(od, my.save, i, ".p", (cc/15),"." , plotf), type=plotf)
        } #end cc test
      }  #end loop on nyears
    } # end catch.yrs test
  }  #end loop on nfleets
  if (cc>1) {
    title (my.title, outer=T, line=0 )
    if (save.plots) savePlot(paste0(od, my.save, i, ".p", ceiling(cc/15),"." , plotf), type=plotf)
  }
  par(mfcol=c(1,1))
  return()
}


########################################################
#####       Author: Diego Valle Jones
#####       Website: www.diegovalle.net
#####       Date Created: Sat Jan 23 21:10:55 2010
########################################################
#1. Bar chart of the homicide rate in 2008
#2. Map of the homicide rate
#3. Bar chart of the difference in homicide rate 2008-2006
#4. Map of the same
#5. Small multiples of the evolution of the murder rate 1990-2008

source("library/utilities.r")

#############################################
#Constants
kyears.start <- 1990
kyear.zoom <- 1994 #The data before 1994 is iffy
kyears <- kyears.start:2008
#############################################3

cleanHom <- function(type="Total") {
  hom <- read.csv(bzfile("states/data/homicide-mun-2008.csv.bz2"), skip=4)
  names(hom)[1:4] <- c("Code", "County", "Year.of.Murder", "Sex")
  hom$County <- iconv(hom$County, "windows-1252", "utf-8")
  hom$Code <- iconv(hom$Code, "windows-1252", "utf-8")
  hom <- hom[grep("=CONCATENAR", hom$Code),]
  hom <- hom[-grep("Extranjero", hom$County),]
  hom <- hom[grep(type, hom$Sex),]
  hom$Year.of.Murder <- as.numeric(as.numeric(gsub('[[:alpha:]]', '',
                                 hom$Year.of.Murder)))
  hom <- subset(hom, Year.of.Murder >= kyears.start)
  #Get rid of the commas in the numbers: 155,000 to 155000
  col2cvt <- 5:ncol(hom)
  hom[ ,col2cvt] <- lapply(hom[ ,col2cvt],
                          function(x){as.numeric(gsub(",", "", x))})
  hom[is.na(hom)] <- 0
  hom$Tot <- apply(hom[ , col2cvt], 1, sum)
  hom$Code <- as.numeric(gsub(".*,([[:digit:]]+).", "\\1", hom$Code))
  hom
}

cleanPop <- function(type = "Total") {
  if(type == "Mujer")
    pop <- read.csv("conapo-pop-estimates/conapo-states-f.csv")
  else
    pop <- read.csv("conapo-pop-estimates/conapo-states.csv")
  pop$Code <- c(1:33)
  pop$State <- iconv(pop$State, "windows-1252", "utf-8")
  pop
}

mergeHomPopYear <- function(hom, pop, year = 2008) {
  hom2008 <- merge(subset(hom, Year.of.Murder == year),
                   pop[ ,c(1,year-kyears.start+2,ncol(pop))],
                   by="Code", all.x = TRUE)
  names(hom2008)[ncol(hom) + 2] <- "popyear"
  #The per 100,000  murder rate
  hom2008$Rate <- hom2008$Tot / hom2008$popyear * 100000
  hom2008$County <- cleanNames(hom2008)
  hom2008$County <- factor(hom2008$County)
  hom2008
}

redScale <- function(rate) {
  #the second highest value (Sinaloa)
  obs <- round(range(rate)[2]) + 1
  if(obs > 70) {
    obs <- round(-sort(-rate)[2]) + 1
  }
  index <- round(rate) + 1
  clr.inc <- colorRampPalette(brewer.pal(8, "Reds"))
  vec <- clr.inc(obs)[index]
  #special color for Chihuahua since it resembles a war zone,
  #otherwise the colors for the rest of the country would be
  #too light
  vec[rate > 70] <- "#410101"
  vec
}

barPlot <- function(hom2008, year="") {
  hom2008$color <- redScale(hom2008$Rate)
  hom2008$County <- reorder(hom2008$County, hom2008$Rate)
  xmax <- range(hom2008$Rate)[2] + 5
  hom.mean <- wtd.mean(hom2008$Rate, hom2008$popyear)
  ggplot(data = hom2008, aes(County, Rate)) +
    geom_bar(stat = "identity", aes(fill = color)) +
    scale_y_continuous(limits = c(0, xmax)) +
    coord_flip() +
    labs(x = "", y = "Homicides per 100,000") +
    opts(title = paste(config$title.barplot, year)) +
    opts(legend.position = "none") +
    scale_fill_identity(aes(breaks = color)) +
    geom_text(aes(label=round(Rate, digits = 1)), hjust = -.05,
            color = "gray50") +
    geom_hline(yintercept = hom.mean, alpha=.1, linetype=2)
}

#We need to order the variables by name to match them with the map
mapOrder <- function(df, varname = "County.x"){
  #df2 <- df
  df$County <- cleanNames(df, varname)
  #df$County <- iconv(df$County, "windows-1252", "utf-8")
  df$Code <- pmatch(df$County, (iconv(mexico.shp$NAME_1,"windows-1252","utf-8")))
  df.merge <- merge(data.frame(iconv(mexico.shp$NAME_1,"windows-1252","utf-8"), Code = 1:32),
                    df, by="Code", all.x = TRUE)
  df.merge
}

plotMap <- function(mexico.shp, colors, plotclr, legend="", title="") {
  plot(mexico.shp, col = colors, border="black", lwd=2)
  title(main = title)
  if (legend !="") {
    legend("topright", legend = legend,
      fill = plotclr, cex=0.8, bty="n")
  }
  par(bg = "white")
}

#return a data frame with the change in homicide rates
getDiff <- function(hom, pop, year1, year2) {
  if(year1>year2){
        temp <- year2
        year2 <- year1
        year1 <- temp
     }
  hom2008 <- merge(subset(hom, Year.of.Murder == year2),
                   pop[ ,c(1,year2-kyears.start+2,ncol(pop))],
                   by="Code", all.x=T)
  names(hom2008)[ncol(hom)+2] <- "popyear2"
  hom2008$Rate2008 <- hom2008$Tot / hom2008[[ncol(hom)+2]] * 100000
  hom2006 <- merge(subset(hom, Year.of.Murder == year1),
                   pop[ ,c(1,year1-kyears.start+2,ncol(pop))],
                   by="Code", all.x=T)
  names(hom2006)[ncol(hom)+2] <- "popyear1"
  hom2006$Rate2006 <- hom2006$Tot / hom2006[[ncol(hom)+2]] * 100000
  hom.diff <- merge(hom2008,hom2006, by ="Code")
  hom.diff$Diff <- hom.diff$Rate2008 - hom.diff$Rate2006
  hom.diff$County.x <- factor(hom.diff$County.x)
  hom.diff
}

#orange-blue scale for the difference barplot
greenReds <- function(difference){
  clr.inc <- colorRampPalette(brewer.pal(5, "Oranges"))
  clr.dec <- colorRampPalette(brewer.pal(5, "Blues"))
  #I (heart) R
  colors <- difference
  obs <- abs(round(range(difference)[2])) + 1
  index <- abs(round(difference[difference >= 0])) + 1
  colors[difference >= 0] <- clr.inc(obs)[index]

  index <- abs(round(difference[difference < 0])) + 1
  colors[difference < 0] <- clr.dec(obs)[index]

  colors
}

#Based on code from:
#http://learnr.wordpress.com/2009/06/01/ggplot2-positioning-of-barplot-category-labels/
barDiff <- function(hom.diff, year1="", year2="") {
  hom.diff$color <- greenReds(hom.diff$Diff)
  hom.diff$hjust <- ifelse(hom.diff$Diff > 0, 1.1, -.1)
  hom.diff$text.pos <- ifelse(hom.diff$Diff > 0, -.05, 1)
  hom.diff$County.x <- cleanNames(hom.diff, "County.x")
  hom.diff$County.x <- factor(hom.diff$County.x)
  hom.diff$County.x <- reorder(hom.diff$County.x, hom.diff$Diff)
  xmin <- range(hom.diff$Diff)[1] - 2
  xmax <- range(hom.diff$Diff)[2] + 2
  hom.mean08 <- wtd.mean(hom.diff$Rate2008, hom.diff$popyear2)
  hom.mean06 <- wtd.mean(hom.diff$Rate2006, hom.diff$popyear1)
  ggplot(hom.diff, aes(x=County.x, y=Diff, label=County.x,
                        hjust = hjust)) +
    geom_text(aes(y = 0, size=3)) +
    geom_bar(stat = "identity",aes(fill = color)) +
    scale_y_continuous(limits = c(xmin, xmax)) +
    coord_flip() +
    labs(x = "", y = "Change in Rate per 100,000") +
    scale_x_discrete(breaks = NA) +
    opts(legend.position = "none") +
    opts(title = paste(config$title.bardiff,
                       year1, "-", year2, ")", sep = "")) +
    scale_fill_identity(aes(breaks = color)) +
    geom_text(aes(label=round(Diff, digits = 1), hjust = text.pos),
              color="gray50") +
    geom_hline(yintercept = hom.mean08 - hom.mean06, alpha=.1,
               linetype=2)
}

####################################################
#Small Multiples Plot of Murders by State
####################################################
totalHom <- function(hom){
  total.hom <- ddply(hom, .(Year.of.Murder), function(df) sum(df$Tot))
  total.hom$pop <- unlist(pop[33, 2:(ncol(pop)-1)])
  total.hom$Rate <- (total.hom$V1 / total.hom$pop) * 100000
  total.hom
}

mergeHomPopS <- function(hom){
  mpop <- melt(subset(pop, State != "Nacional"), id=c("Code", "State"))
  mpop$variable <- as.numeric(substring(mpop$variable, 2))
  mpop$Year.of.Murder <- mpop$variable
  hom.mpop <- merge(hom, mpop, by=c("Code","Year.of.Murder"),
                    all.y = TRUE)
  if(any(is.na(hom.mpop$Tot)))
    hom.mpop[is.na(hom.mpop$Tot), ]$Tot <- 0
  hom.mpop$Rate <- hom.mpop$Tot / hom.mpop$value * 100000
  hom.mpop$State <- cleanNames(hom.mpop, "State")
  hom.mpop$State <- factor(hom.mpop$State)
  hom.mpop
}

cluster <- function(hom.mpop, nclusters){
  #k-means clustering to order the facets
  t <- cast(hom.mpop[,c(26:27,29)], State ~ variable, value = "Rate")
  t[is.na(t)] <- 0
  cl <- kmeans(t[,2:ncol(t)], nclusters)
  t$Cluster <- cl$cluster
  t <- merge(ddply(t, .(Cluster), function(df) mean(df$"2008")),
        t, by = "Cluster")
  t <- t[,c(1,2,3)]
  hom.mpop <- merge(hom.mpop, t, by = "State")
  hom.mpop <- ddply(hom.mpop, .(State), transform,
                    max = Rate[length(Rate)])
  hom.mpop$order <- hom.mpop$V1^3 + hom.mpop$max
  hom.mpop$State <- reorder(hom.mpop$State, -hom.mpop$order)
  hom.mpop
}

smallMultiples <- function(hom, pop, nclusters = 8){
  total.hom <- totalHom(hom)
  hom.mpop <- mergeHomPopS(hom)
  hom.mpop <- cluster(hom.mpop, nclusters)
  p <- ggplot(hom.mpop, aes(Year.of.Murder, Rate)) +
      geom_line(aes(color = factor(Cluster)), size = 1)
  p + facet_wrap(~ State, as.table = TRUE,
                 scale="free_y") +
      labs(x = "", y = "Homicide Rate") +
      opts(title = config$title.sm) +
      scale_x_continuous(breaks = seq(kyears.start, 2008, by = 4)) +
      theme_bw() +
      geom_line(data = total.hom, aes(Year.of.Murder, Rate),
                color="gray70", linetype = 2, size =.5) +
      opts(legend.position = "none") +
      opts(axis.text.x=theme_text(angle=60, hjust=1.2 )) +
      coord_cartesian(xlim = c(kyear.zoom, 2008))

}

if(config$sex == "Female") {
  type <- "Mujer"
  config$title.sm <- config$states$ftitle.sm
  config$title.bardiff <- config$states$ftitle.bardiff
  config$title.barplot <- config$states$ftitle.barplot
  nclust <- 4
} else {
  type <- "Total"
  config$title.sm <- config$states$mtitle.sm
  config$title.bardiff <- config$states$mtitle.bardiff
  config$title.barplot <- config$states$mtitle.barplot
  nclust <- 8
}

##########################################################
#Read the data
##########################################################
hom <- cleanHom(type)
pop <- cleanPop(type)

########################################################
#Barplot with the homicide rate in 2008
########################################################
year <- config$states$year
hom.year <- mergeHomPopYear(hom, pop, year)
print(barPlot(hom.year, year))
dev.print(png, file = "states/output/2008-homicide-bars.png",
          width = 480, height = 480)

########################################################
#Map with the homicide rate in 2008
########################################################
load("maps/map_mx.RData") #load mexico.shp

hom.year.map <- mapOrder(hom.year, "County")

Cairo(file="states/output/2008-homicide-map.png", width=480, height=480)
print(plotMap(mexico.shp, redScale(hom.year.map$Rate)))
dev.off()

###################################################################
#Bar plot of the change in homicide rate from the start of the
#drug war at the end of 2006 till 2008
###################################################################
year1 <- config$states$year1
year2 <- config$states$year2
hom.diff <- getDiff(hom, pop, year1, year2)
print(barDiff(hom.diff, year1, year2))
dev.print(png, file="states/output/2006-2008-change-homicide.png",
          width=480, height=480)

########################################################
#Map of the change in homicide rates
########################################################
hom.diff.map <- mapOrder(hom.diff, "County.x")
Cairo(file="states/output/2006-2008-change-homicide-map.png", width=480, height=480)
print(plotMap(mexico.shp, greenReds(hom.diff.map$Diff)))
dev.off()

########################################################
#Small Multiples of each state
########################################################
#This is how you get anti-aliasing in R
Cairo(file="states/output/homicide-small-multiples.png",
      type="png", width=960, height=600)
print(smallMultiples(hom, pop, nclust))
dev.off()

#The graph for Chihuahua looks similar to the hockey stick
#of global temperatures
#Coincidence? or is global warming to blame