#source utility functions
source("./R/util.R")
source("./R/var_etl_surv.R")

require_libraries(c("tidyr",
                    "dplyr",
                    "magrittr",
                    "stringr",
                    "broom",
                    "Matrix",
                    "xgboost",
                    "ROCR",
                    "PRROC",
                    "ResourceSelection",
                    "knitr",
                    "kableExtra",
                    "ggplot2",
                    "openxlsx"))

# experimental design parameters
#----prediction ending point
pred_end<-7 #only collect data within 7 days since admission

#-----prediction point
pred_in_d_opt<-c(1,2)

#-----prediction tasks
pred_task_lst<-c("stg1up","stg2up","stg3")

#-----feature selection type
fs_type_opt<-c("no_fs","rm_scr_bun")
rm_key<-c('2160-0','38483-4','14682-9','21232-4','35203-9','44784-7','59826-8',
          '16188-5','16189-3','59826-8','35591-7','50380-5','50381-3','35592-5',
          '44784-7','11041-1','51620-3','72271-0','11042-9','51619-5','35203-9','14682-9',
          '12966-8','12965-0','6299-2','59570-2','12964-3','49071-4','72270-2',
          '11065-0','3094-0','35234-4','14937-7',
          '48642-3','48643-1', #eGFR
          '3097-3','44734-2','BUN_SCR')

#### Objective 2.1: Data Cleaning and Representation
#collect and format variables on daily basis
n_chunk<-4 #memory-efficient

tbl1<-readRDS("./data//Table1.rda") %>%
  dplyr::mutate(yr=as.numeric(format(strptime(ADMIT_DATE, "%Y-%m-%d %H:%M:%S"),"%Y")))

#--by chunks: encounter year
enc_yr<-tbl1 %>%
  dplyr::select(yr) %>%
  unique %>% arrange(yr) %>%
  filter(yr>2009) %>%
  dplyr::mutate(chunk=ceiling((yr-2009)/(n()/n_chunk)))

#--by variable type
var_type<-c("demo","vital","lab","dx","px","med")

for(pred_in_d in pred_in_d_opt){
  #--determine update time window
  tw<-as.double(seq(0,pred_end))
  if(pred_in_d>1){
    tw<-tw[-seq_len(pred_in_d-1)]
  }

  #--save results as array
  for(pred_task in pred_task_lst){
    start_tsk<-Sys.time()
    cat("Start variable collection for task",pred_task,".\n")
    #---------------------------------------------------------------------------------------------

    var_by_yr<-list()
    var_bm<-list()
    rsample_idx<-c()

    for(i in seq_len(n_chunk)){
      start_i<-Sys.time()
      cat("...start variable collection for year chunk",i,".\n")

      #--collect end_points
      yr_i<-enc_yr$yr[enc_yr$chunk==i]
      dat_i<-tbl1 %>% filter(yr %in% yr_i) %>%
        dplyr::select(ENCOUNTERID,yr,
                      NONAKI_SINCE_ADMIT,
                      AKI1_SINCE_ADMIT,
                      AKI2_SINCE_ADMIT,
                      AKI3_SINCE_ADMIT) %>%
        gather(y,dsa_y,-ENCOUNTERID,-yr) %>%
        filter(!is.na(dsa_y)) %>%
        dplyr::mutate(y=recode(y,
                               "NONAKI_SINCE_ADMIT"=0,
                               "AKI1_SINCE_ADMIT"=1,
                               "AKI2_SINCE_ADMIT"=2,
                               "AKI3_SINCE_ADMIT"=3)) %>%
        dplyr::mutate(y=as.numeric(y))

      if(pred_task=="stg1up"){
        dat_i %<>%
          dplyr::mutate(y=as.numeric(y>0)) %>%
          group_by(ENCOUNTERID) %>% top_n(n=1L,wt=dsa_y) %>% ungroup
      }else if(pred_task=="stg2up"){
        dat_i %<>%
          # filter(y!=1) %>% # remove stage 1
          dplyr::mutate(y=as.numeric(y>1)) %>%
          group_by(ENCOUNTERID) %>% top_n(n=1L,wt=dsa_y) %>% ungroup
      }else if(pred_task=="stg3"){
        dat_i %<>%
          # filter(!(y %in% c(1,2))) %>% # remove stage 1,2
          dplyr::mutate(y=as.numeric(y>2)) %>%
          group_by(ENCOUNTERID) %>% top_n(n=1L,wt=dsa_y) %>% ungroup
      }else{
        stop("prediction task is not valid!")
      }

      #--random sampling
      rsample_idx %<>%
        bind_rows(dat_i %>%
                    dplyr::select(ENCOUNTERID,yr) %>%
                    unique %>%
                    dplyr::mutate(cv10_idx=sample(1:10,n(),replace=T)))

      #--ETL variables
      X_surv<-c()
      y_surv<-c()
      var_etl_bm<-c()
      for(v in seq_along(var_type)){
        start_v<-Sys.time()

        #extract
        var_v<-readRDS(paste0("./data/AKI_",toupper(var_type[v]),".rda")) %>%
          semi_join(dat_i,by="ENCOUNTERID")

        if(var_type[v] != "demo"){
          if(var_type[v] == "med"){
            var_v %<>%
              transform(value=strsplit(value,","),
                        dsa=strsplit(dsa,",")) %>%
              unnest(value,dsa) %>%
              dplyr::mutate(value=as.numeric(value),
                            dsa=as.numeric(dsa))
          }
          var_v %<>% filter(dsa <= pred_end)
        }

        #transform
        var_v<-format_data(dat=var_v,
                           type=var_type[v],
                           pred_end=pred_end)

        Xy_surv<-get_dsurv_temporal(dat=var_v,
                                    censor=dat_i,
                                    tw=tw,
                                    pred_in_d=pred_in_d)

        #load
        X_surv %<>% bind_rows(Xy_surv$X_surv) %>% unique
        y_surv %<>% bind_rows(Xy_surv$y_surv) %>% unique

        lapse_v<-Sys.time()-start_v
        var_etl_bm<-c(var_etl_bm,paste0(lapse_v,units(lapse_v)))
        cat("\n......finished ETL",var_type[v],"for year chunk",i,"in",lapse_v,units(lapse_v),".\n")
      }
      var_by_yr[[i]]<-list(X_surv=X_surv,
                           y_surv=y_surv)

      lapse_i<-Sys.time()-start_i
      var_etl_bm<-c(var_etl_bm,paste0(lapse_i,units(lapse_i)))
      cat("\n...finished variabl collection for year chunk",i,"in",lapse_i,units(lapse_i),".\n")

      var_bm[[i]]<-data.frame(bm_nm=c(var_type,"overall"),
                              bm_time=var_etl_bm,
                              stringsAsFactors = F)
    }

    #--save preprocessed data
    saveRDS(rsample_idx,file=paste0("./data/preproc/",pred_in_d,"d_rsample_idx_",pred_task,".rda"))
    saveRDS(var_by_yr,file=paste0("./data/preproc/",pred_in_d,"d_var_by_yr_",pred_task,".rda"))
    saveRDS(var_bm,file=paste0("./data/preproc/",pred_in_d,"d_var_bm",pred_task,".rda"))

    #---------------------------------------------------------------------------------------------
    lapse_tsk<-Sys.time()-start_tsk
    cat("\nFinish variable ETL for task:",pred_task,"in",pred_in_d,"days",",in",lapse_tsk,units(lapse_tsk),".\n")
  }
}

#### Objective 2.2: Benchmark Model Validation
rm(list=c("X_surv","y_surv", "Xy_surv","dat_i","var_v",
          "rsample_idx","var_by_yr","var_bm"))
gc() #release some memory

# collect and format variables on daily basis
n_chunk<-4 #memory-efficient

for(pred_in_d in pred_in_d_opt){

  for(pred_task in pred_task_lst){
    start_tsk<-Sys.time()
    #---------------------------------------------------------------------------------------------
    var_by_task<-readRDS(paste0("./data/preproc/",pred_in_d,"d_var_by_yr_",pred_task,".rda"))

    for(fs_type in fs_type_opt){
      #--prepare testing set
      X_ts<-c()
      y_ts<-c()
      for(i in seq_len(n_chunk)){
        var_by_yr<-var_by_task[[i]]

        X_ts %<>% bind_rows(var_by_yr[["X_surv"]])
        y_ts %<>% bind_rows(var_by_yr[["y_surv"]])
      }

      #--pre-filter
      if(fs_type=="rm_scr_bun"){
        X_ts %<>%
          filter(!(key %in% c(rm_key,paste0(rm_key,"_change"))))
      }

      #--collect variables used in training
      ref_mod<-readRDS(paste0("./data/model_kumc/",pred_in_d,"d_",fs_type,"_",pred_task,".rda"))$model
      tr_key<-data.frame(key = ref_mod$feature_names,
                         stringsAsFactors = F)

      #--transform testing matrix
      y_ts %<>%
        arrange(ENCOUNTERID,dsa_y) %>%
        unite("ROW_ID",c("ENCOUNTERID","dsa_y")) %>%
        arrange(ROW_ID) %>%
        unique

      X_ts %<>%
        unite("ROW_ID",c("ENCOUNTERID","dsa_y")) %>%
        semi_join(y_ts,by="ROW_ID") %>%
        semi_join(tr_key,by="key")

      x_add<-tr_key %>%
        anti_join(data.frame(key = unique(X_ts$key),
                             stringsAsFactors = F),
                  by="key")

      #align with training
      if(nrow(x_add)>0){
        X_ts %<>%
          arrange(ROW_ID) %>%
          bind_rows(data.frame(ROW_ID = rep("0_0",nrow(x_add)),
                               dsa = -99,
                               key = x_add$key,
                               value = 0,
                               stringsAsFactors=F))
      }
      X_ts %<>%
        long_to_sparse_matrix(df=.,
                              id="ROW_ID",
                              variable="key",
                              val="value")
      if(nrow(x_add)>0){
        X_ts<-X_ts[-1,]
      }

      X_ts<-X_ts[,tr_key$key]

      #check alignment
      if (!all(row.names(X_ts)==y_ts$ROW_ID)){
        stop("row ids of testing set don't match!")
      }

      if (!all(ref_mod$feature_names==colnames(X_ts))){
        stop("feature names don't match!")
      }

      #--covert to xgb data frame
      dtest<-xgb.DMatrix(data=X_ts,label=y_ts$y)

      #--validation
      valid<-data.frame(y_ts,
                        pred = predict(ref_mod,dtest),
                        stringsAsFactors = F)

      #--save model and other results
      saveRDS(valid,file=paste0("./data/model_kumc/pred_in_",pred_in_d,"d_valid_gbm_",fs_type,"_",pred_task,".rda"))
      #-------------------------------------------------------------------------------------------------------------
      lapse_tsk<-Sys.time()-start_tsk
      cat("\nFinish validating benchmark models for task:",pred_task,"in",pred_in_d,"with",fs_type,",in",lapse_tsk,units(lapse_tsk),".\n")
    }
  }
}

#### Objective 2.3: Performance Evaluations for Benchmark Model
rm(list=ls()[!(ls() %in% c("pred_in_d_opt","fs_type_opt",
                           "get_perf_summ","get_calibr"))]);
gc() #release some memory

#-----performance meatrics
perf_metrics<-c("roauc",
                "prauc1",
                "opt_sens",
                "opt_spec",
                "opt_ppv",
                "opt_npv")

#-----boostrapping parameters
boots<-100

#------auxiliary table (for subgroup analysis)
tbl1<-readRDS("./data/Table1.rda") %>%
  dplyr::select(ENCOUNTERID,SERUM_CREAT_BASE) %>%
  inner_join(readRDS("./data/AKI_DEMO.rda") %>%
               filter(key=="AGE") %>%
               dplyr::select(ENCOUNTERID,key,value) %>%
               spread(key,value) %>%
               mutate(AGE=as.numeric(AGE)),
             by="ENCOUNTERID")

final_out<-list()

#### Task I: 24-hour advanced prediction
pred_in_d<-1

#Overall Prediction Performance and Subgroup Analysis*
perf_cutoff<-c()
perf_tbl<-c()
calib_tbl<-c()

for(pred_task in pred_task_lst){

  for(fs_type in fs_type_opt){

    valid_orig<-readRDS(paste0("./data/model_kumc/pred_in_",pred_in_d,"d_valid_gbm_",fs_type,"_",pred_task[i],".rda")) %>%
      mutate(ENCOUNTERID=gsub("_.*","",ROW_ID),
             day_at=as.numeric(gsub(".*_","",ROW_ID))) %>%
      left_join(tbl1,by="ENCOUNTERID") %>%
      dplyr::mutate(age=cut(AGE,breaks=c(0,45,65,Inf),include.lowest=T,right=F)) %>%
      mutate(admit_scr=cut(SERUM_CREAT_BASE,breaks=c(0,1,2,3,Inf),include.lowest=T,right=F))

    n<-nrow(valid_orig)

    perf_cutoff %<>%
      bind_rows(get_perf_summ(pred=valid_orig$pred,
                              real=valid_orig$y,
                              keep_all_cutoffs=T)$perf_at %>%
                  dplyr::mutate(pred_in_d=pred_in_d,
                                pred_task=pred_task,
                                fs_type=fs_type))

    for(b in 1:boots){
      #--bootstrapping
      idxset<-sample(1:n,n,replace=T)
      valid<-valid_orig %>% dplyr::slice(idxset)

      #--collect performance metrics
      #overall
      perf_overall<-get_perf_summ(pred=valid$pred,
                                  real=valid$y,
                                  keep_all_cutoffs=F)$perf_summ %>%
        dplyr::filter(overall_meas %in% perf_metrics) %>%
        dplyr::mutate(size=nrow(valid),
                      grp="Overall",
                      pred_task=pred_task)

      calib<-get_calibr(pred=valid$pred,
                        real=valid$y) %>%
        mutate(pred_in_d=pred_in_d,
               fs_type=fs_type,
               pred_task=pred_task)

      #subgroup-age
      subgrp_age<-c()
      grp_vec<-unique(valid$age)
      for(grp in seq_along(grp_vec)){
        valid_grp<-valid %>% filter(age==grp_vec[grp])
        grp_summ<-get_perf_summ(pred=valid_grp$pred,
                                real=valid_grp$y,
                                keep_all_cutoffs=F)$perf_summ %>%
          dplyr::filter(overall_meas %in% perf_metrics)

        subgrp_age %<>%
          bind_rows(grp_summ %>%
                      dplyr::mutate(size=nrow(valid_grp),
                                    grp=paste0("Subgrp_AGE:",grp_vec[grp]),
                                    pred_task=pred_task))
      }

      #subgroup-scr
      subgrp_scr<-c()
      grp_vec<-unique(valid$admit_scr)
      for(grp in seq_along(grp_vec)){
        valid_grp<-valid %>% filter(admit_scr==grp_vec[grp])
        grp_summ<-get_perf_summ(pred=valid_grp$pred,
                                real=valid_grp$y,
                                keep_all_cutoffs=F)$perf_summ %>%
          filter(overall_meas %in% perf_metrics)

        subgrp_scr %<>%
          bind_rows(grp_summ %>%
                      dplyr::mutate(size=nrow(valid_grp),
                                    grp=paste0("Subgrp_Scr_Base:",grp_vec[grp]),
                                    pred_task=pred_task))
      }

      perf_overall %<>%
        bind_rows(subgrp_age) %>%
        bind_rows(subgrp_scr) %>%
        dplyr::mutate(pred_in_d=pred_in_d,fs_type=fs_type) %>%
        dplyr::mutate(meas_val=round(meas_val,4))

      perf_tbl %<>%
        bind_rows(perf_overall %>% dplyr::mutate(boots=b))

      calib_tbl %<>%
        bind_rows(calib %>% dplyr::mutate(boots=b))
    }
  }
}

perf_tbl %<>%
  group_by(pred_in_d,pred_task,fs_type,grp,overall_meas) %>%
  dplyr::summarize(size=round(mean(size)),
                   meas_med=median(meas_val,na.rm=T),
                   meas_lb=quantile(meas_val,probs=0.025,na.rm=T),
                   meas_ub=quantile(meas_val,probs=0.975,na.rm=T)) %>%
  ungroup

calib_tbl %<>%
  gather(overall_meas,meas_val,-pred_in_d,-pred_task,-fs_type,-pred_bin,-boots) %>%
  group_by(pred_in_d,pred_task,fs_type,pred_bin,overall_meas) %>%
  dplyr::summarize(meas_med=median(meas_val,na.rm=T),
                   meas_lb=quantile(meas_val,probs=0.025,na.rm=T),
                   meas_ub=quantile(meas_val,probs=0.975,na.rm=T)) %>%
  ungroup

perf_tbl %<>%
  dplyr::select(pred_in_d,fs_type,grp,pred_task,overall_meas,meas_med,meas_lb,meas_ub) %>%
  dplyr::mutate(pred_task=recode(pred_task,
                                 `stg1up`="a.AKI>=1",
                                 `stg2up`="b.AKI>=2",
                                 `stg3`="c.AKI=3",
                                 `stg3up`="c.AKI=3"),
                meas_med=round(meas_med,4),
                meas_lb=round(meas_lb,4),
                meas_ub=round(meas_ub,4)) %>%
  dplyr::mutate(meas_ci = paste0(meas_med,"(",meas_lb,",",meas_ub,")"))

final_out[["pred24_summ"]]<-list(perf_cutoff=perf_cutoff,
                                 perf_tbl=perf_tbl,
                                 calib_tbl=calib_tbl)

perf_overall<-perf_tbl %>%
  dplyr::select(pred_in_d,fs_type,grp,pred_task,overall_meas,meas_ci) %>%
  dplyr::mutate(overall_meas=recode(overall_meas,
                                    roauc="1.ROAUC",
                                    prauc1="2.PRAUC",
                                    opt_sens="3.Optimal Sensitivity",
                                    opt_spec="4.Optimal Specificity",
                                    opt_ppv="5.Optimal Positive Predictive Value",
                                    opt_npv="6.Optimal Negative Predictive Value")) %>%
  spread(overall_meas,meas_ci)

row_grp_pos<-perf_overall %>%
  arrange(grp,pred_task) %>%
  mutate(rn=1:n()) %>%
  dplyr::mutate(root_grp=gsub(":.*","",grp)) %>%
  group_by(root_grp,pred_in_d) %>%
  dplyr::summarize(begin=rn[1],
                   end=rn[n()]) %>%
  ungroup

kable(perf_overall %>% arrange(grp,pred_task),
      caption="Table1 - 24-Hour Prediction of AKI1, AKI2, AKI3") %>%
  kable_styling("striped", full_width = F) %>%
  group_rows("Overall", row_grp_pos$begin[1],row_grp_pos$end[1]) %>%
  group_rows("Subgroup-Age", row_grp_pos$begin[2],row_grp_pos$end[2]) %>%
  group_rows("Subgroup-Scr_Base", row_grp_pos$begin[3],row_grp_pos$end[3])

#Full metric paths at various cutoff points*
#plot out sens, spec, ppv, npv on a scale of cutoff probabilities
brks<-unique(c(0,seq(0.001,0.01,by=0.001),seq(0.02,0.1,by=0.01),seq(0.2,1,by=0.1)))
pred24_cutoff_plot<-list()

for(fs_type in fs_type_opt){

  perf_cutoff_fs<-perf_cutoff %>%
    dplyr::filter(fs_type==fs_type) %>%
    dplyr::select(cutoff,rec_sens,spec,ppv,npv,pred_task) %>%
    mutate(bin=cut(cutoff,breaks=brks,include.lowest=T,label=F)) %>%
    group_by(bin,pred_task) %>%
    dplyr::summarise(cutoff=round(max(cutoff),3),
                     sens_l=quantile(rec_sens,0.025,na.rm=T),
                     sens=median(rec_sens,na.rm=T),
                     sens_u=quantile(rec_sens,0.975,na.rm=T),
                     spec_l=quantile(spec,0.025,na.rm=T),
                     spec=median(spec,na.rm=T),
                     spec_u=quantile(spec,0.975,na.rm=T),
                     ppv_l=quantile(ppv,0.025,na.rm=T),
                     ppv=median(ppv,na.rm=T),
                     ppv_u=quantile(ppv,0.975,na.rm=T),
                     npv_l=quantile(npv,0.025,na.rm=T),
                     npv=median(npv,na.rm=T),
                     npv_u=quantile(npv,0.975,na.rm=T)) %>%
    ungroup %>% dplyr::select(-bin) %>%
    gather(metric_type,metric_val,-cutoff,-pred_task) %>%
    mutate(metric_type2=ifelse(grepl("_l",metric_type),"low",
                               ifelse(grepl("_u",metric_type),"up","mid")),
           metric_type=gsub("_.*","",metric_type)) %>%
    spread(metric_type2,metric_val) %>%
    mutate(pred_task=recode(pred_task,
                            `stg1up`="a.AKI>=1",
                            `stg2up`="b.AKI>=2",
                            `stg3`="c.AKI=3"))

  pred24_cutoff_plot[[fs_type]]<-ggplot(perf_cutoff_fs %>% dplyr::filter(cutoff <=0.15),
                                        aes(x=cutoff,y=mid,color=metric_type,fill=metric_type))+
    geom_line()+ geom_ribbon(aes(ymin=low,ymax=up),alpha=0.3)+
    labs(x="cutoff probability",y="performance metrics",
         title=paste0("Figure",fs_type_i," - Metrics at different cutoff points:",fs_type))+
    facet_wrap(~pred_task,scales="free",ncol=3)

  final_out[[paste0("pred24_cutoff_",fs_type)]]<-perf_cutoff_fs
}

print(pred24_cutoff_plot[[1]])
print(pred24_cutoff_plot[[2]])

#Calibration Plots*
pred24_calib_plot<-list()

# plot calibration
for(fs_type in fs_type_opt){

  calib_tbl_fs<-calib_tbl %>%
    dplyr::filter(fs_type==fs_type) %>%
    mutate(pred_task=recode(pred_task,
                            `stg1up`="a.AKI>=1",
                            `stg2up`="b.AKI>=2",
                            `stg3`="c.AKI=3"))

  calib_tbl_fs_plot<-calib_tbl_fs %>%
    dplyr::filter(overall_meas=="y_p") %>%
    left_join(calib_tbl_fs %>%
                dplyr::filter(overall_meas=="pred_p") %>%
                dplyr::select(pred_in_d,pred_task,fs_type,pred_bin,meas_med) %>%
                dplyr::rename(pred_p=meas_med),
              by=c("pred_in_d","pred_task","fs_type","pred_bin"))

  pred24_calib_plot[[fs_type]]<-ggplot(calib_tbl_fs_plot,aes(x=pred_p,y=meas_med))+
    geom_point()+geom_abline(intercept=0,slope=1)+
    geom_errorbar(aes(ymin=meas_lb,ymax=meas_ub))+
    labs(x="Predicted Probability",y="Actual Probability",
         title=paste0("Figure",which(fs_type_opt==fs_type)+2," - Calibration:",fs_type))+
    facet_wrap(~pred_task,scales="free")

  final_out[[paste0("pred24_calibr_",fs_type)]]<-calib_tbl_fs
}
print(pred24_calib_plot[[1]])
print(pred24_calib_plot[[2]])


library(data.table)
library(purrr)
library(dplyr)

#: -----a function--------------
class_designation <- function(dt, varNames) {
  # @desc: ths logic is we have all character type columns in the beginning (regardless of column values),
  # if can coerce to numeric value, do it; otherwise(try and error/warning), coerce to factor. If error again, will stop,
  # then manually check is needed.
  #
  # @param dt: data.table object
  # @param varNames: string vector of colnames in the dt.
  # @return a modified dt[, varNames, with = FALSE] with coerced col class for each of the `varNames` specified.
  dt[ , map(.SD, ~try_catch(as.numeric(.),
                            .e = function(e) return(as.factor(.)),
                            .w = function(w) return(as.factor(.)))),
.SDcols = varNames]

}
# then manually assign the dt's varNames columns with returned new values (after type conversion)
##:----example code below----
##: execute `class_designation`
#replace_dt_part <- class_designation(joined_dt, varNames)
#
#joined_dt[ , (varNames) := replace_dt_part]

#: -----a function--------------
continuous_binnedCategorical <- function(dt, varNames, n_levels = 10,
                                         cut_func = c(ggplot2::cut_number, ggplot2::cut_interval)) {
  # @desc: ths logic is at first check if those cols of varNames are numeric and integer columns,
  # then decide if distinct value > n_levels, if so bin them to n_levels ordered factors, otherwise keep the levels asIs and coerce to ordered factors.
  #
  # @param dt: data.table object
  # @param varNames: string vector of colnames in the dt.
  # @param n_levels: an integer specifying how many levels you want.
  # @param cut_func: which cut function to use. `cut_interval` makes 'n' groups with equal range, `cut_number`
  #  makes 'n' groups with (approximately) equal numbers of observations.
  # @return a modified dt with numeric and integer columns coerced to ordered factors (might be binned)
  stop_if_not(dt[, map(.SD, ~(is.numeric(.)|is.integer(.))), .SDcols = varNames] %>% unlist %>% all,
              msg = "Provided `varNames` cols in `dt` are not all numeric or integer type!")

  #: DONT use `ifelse`, doesnt work for vector here.
  #dt[ , map_dfc(.SD, ~ifelse(n_distinct(.) <= n_levels, yes = as.factor(.), no = ggplot2::cut_number(., n = n_levels )))
  #  , .SDcols = varNames]

  #: use standard if-else syntax.
  dt[ , .SD, .SDcols = varNames] %>% map_dfc(., ~if(n_distinct(.) <= n_levels) { as.ordered(.)}
                                             else {
                                               #: if error or warning, use base::cut function to be safe.
                                               try_catch(cut_func(., n = n_levels, ordered_result = TRUE ),
                                                         .e = function(e) return( base::cut(., breaks = n_levels, ordered_result = TRUE) ),
                                                         .w = function(w) return(base::cut(., breaks = n_levels, ordered_result = TRUE)))
                                             })
  # or equivalently,
  #dt[ , map_dfc(.SD, ~if(n_distinct(.) <= n_levels) { as.factor(.)} else { ggplot2::cut_number(., n = n_levels )}), .SDcols = varNames]

}
# then manually assign the dt's varNames columns with returned new values (after type conversion)
###:----example code below----
##: execute `class_designation`
#varNames_continuousVars <- colClass_dt[ class == "numeric", varName ]
#
#foreach (n_l = seq(10,100,10)) %do% {
#
#      #: 1st, use `ggplot2::cut_number`
#      replace_dt_part <- continuous_binnedCategorical(joined_dt, varNames_continuousVars, n_levels = n_l, cut_func = ggplot2::cut_number )
#
#    #: create new columns in the dt
#    joined_dt[ , (sprintf( "equalSizeBinned_max%dlevels_%s", n_l, varNames_continuousVars)) := replace_dt_part]
#
#
#        #: 2nd, use `ggplot2::cut_interval` .
#        replace_dt_part <- continuous_binnedCategorical(joined_dt, varNames_continuousVars, n_levels = n_l, cut_func = ggplot2::cut_interval )
#
#        #: create new columns in the dt
#        joined_dt[ , (sprintf( "equalRangeBinned_max%dlevels_%s", n_l, varNames_continuousVars)) := replace_dt_part]
#
#            #: since above replace in place, so here dont return anything.
#            return(NULL)
#
#}
##: after `class_designation`, joined_dt may actually have same content columns (with different colnames though), libray 'digest' could produce hash tag on R object, same hash tag represents same contents columns, so can be removed to save memory (i.e., reduce the size of dt object).
#library(digest)
#
#dup_col_index <- duplicated(map_chr(joined_dt, digest))
#
#dup_col_index %>% mean
#
#joined_dt <- joined_dt[ , !dup_col_index, with = FALSE]
#
#catt("Expanded joined_dt dim is:", dim(joined_dt))
#


library(ggplot2)
library(plyr)
theme_set(theme_bw(18))
setwd("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/23_sinking-marbles-prior-sliders-exactly/results/")
source("rscripts/helpers.r")

load("data/r.RData")

# write dataset for mh's bayesian prior in the sky inference
# subjID, itemID, bin0, bin2, …, bin15
d = r[,c("workerid","Item","slider_id","normresponse")]
spreaded = d %>% spread(slider_id,normresponse)
write.table(spreaded,file="data/inferpriorinsky_binnedhistogram.txt",row.names=F,quote=F,sep="\t")

load("../../1_sinking-marbles-prior/results/data/priors.RData")
r = read.csv("data/sinking_marbles.csv", header=T)
nrow(r)
head(r)
r$trial = r$slide_number_in_experiment - 2
r = r[,c("assignmentid","workerid", "rt", "effect", "cause","language","gender.1","age","gender","other_gender", "response", "object","slider_id","num_objects","trial","enjoyment","asses","comments","Answer.time_in_minutes","slider_id","order")]
r$Item = as.factor(paste(r$effect,r$object))
table(r$Item)
table(r$Item,r$order)

## add old priors to data.frame
priorprobs = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/12_sinking-marbles-prior15/results/data/smoothed_15marbles_priors_withnames.txt",sep="\t", header=T, quote="")
head(priorprobs)
row.names(priorprobs) = paste(priorprobs$effect,priorprobs$object)
mpriorprobs = melt(priorprobs, id.vars=c("effect", "object"))
head(mpriorprobs)
row.names(mpriorprobs)= paste(mpriorprobs$variable, mpriorprobs$effect,mpriorprobs$object)
head(mpriorprobs)

r$PriorProbability = mpriorprobs[paste(paste("X",r$slider_id,sep=""),as.character(r$Item), sep=" "),]$value

# compute normalized probabilities
nr = ddply(r, c("workerid","trial"), summarise,
           sumresponse=sum(response))
row.names(nr) = paste(nr$workerid, nr$trial)

r$normresponse = r$response/nr[paste(r$workerid, r$trial),]$sumresponse

# test: sums should add to 1
sums = ddply(r, .(workerid,trial), summarise, sum(normresponse))
colnames(sums) = c("workerid","trial","sum")
summary(sums)
sums[is.na(sums$sum),]

save(r, file="data/r.RData")

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

ggplot(aes(x=gender.1), data=r) +
  geom_histogram()

ggplot(aes(x=rt), data=r) +
  geom_histogram() +
  scale_x_continuous(limits=c(0,50000))

ggplot(aes(x=age), data=r) +
  geom_histogram()

ggplot(aes(x=age,fill=gender.1), data=r) +
  geom_histogram()

ggplot(aes(x=enjoyment), data=r) +
  geom_histogram()

ggplot(aes(x=asses), data=r) +
  geom_histogram()

ggplot(aes(x=Answer.time_in_minutes), data=r) +
  geom_histogram()

ggplot(aes(x=age,y=Answer.time_in_minutes,color=gender.1), data=unique(r[,c("assignmentid","age","Answer.time_in_minutes","gender.1")])) +
  geom_point() +
  geom_smooth()

unique(r$comments)

## write to file for use in models
head(r)
towrite = r[,c("Item","workerid","normresponse","slider_id")] %>% spread(slider_id, normresponse)
head(towrite)
str(towrite)
towrite$Item = as.factor(gsub(" ","_", towrite$Item))
towrite[,3:18] = towrite[,3:18] + .000000001
towrite = na.omit(towrite)

for (item in levels(towrite$Item)) {
  write.table(towrite[towrite$Item == item,3:18], file=paste("data/priors/",item,".txt",sep=""),quote=F,row.names=F,col.names=F)
}

# histogram of number of cases for each item
ggplot(as.data.frame(table(towrite$Item)),aes(x=Freq)) +
  geom_histogram()
ggsave("graphs/histogram_cases_per_item.pdf")


#set where we are working
setwd('/Users/Cam/Desktop/ds_practice/hockey_dat')

library('plyr')
library('stringr')
library('tidyverse')
library('magrittr')
library('scatterplot3d')
library('xgboost')
library('dummies')
library('randomForest')

save.image('hockey_salary')
#load in the data we generated in the random forest tutorial
#data is now successfully loaded in to dtest and dtrain
load('hockey_salary')

# Read in the data
train = read.csv('train.csv')
head(train)
test_x = read.csv('test.csv')
head(test_x)
test_y = read.csv('test_salaries.csv')
head(test_y)

#data cleaning
#impute missing data and fix problem categorical columns
#to do this we merge the train and test data into a single set

#add train/test column
test_x$TrainTest = "test"
train$TrainTest =  "train"

test = cbind(test_y, test_x)
all_data = rbind(train,test)

# make new column for undrafted
all_data$undrafted = is.na(all_data$DftRd)

#fill the Pr.St column with 'INT' for international players
all_data$Pr.St = mapvalues(all_data$Pr.St, from = "", to="INT")

#Make team boolean columns
#get the unique list of team acronymns
teams = c()
for( i in levels(all_data$Team)){
	x = strsplit(i, "/")
	for(y in x){
		teams = c(teams, y)
	}
}
teams = unique(teams)

# add columns with the team names as the header and 0 as values
for(team in teams){
	all_data[,team] = 0
}

#iterate through and record the teams for each player
for(i in 1:length(all_data$Team)){
	teams_of_person = strsplit(as.character(all_data$Team[i]), "/")[[1]]
	for(x in teams_of_person){
		all_data[,x][i] = 1
	}
}

#Make position boolean columns
pos = c()
for( i in levels(all_data$Position)){
	x = strsplit(i, "/")
	for(y in x){
		pos = c(pos, y)
	}
}
pos = unique(pos)

# add columns with the pos names as the header and 0 as values
for(position in pos){
	all_data[,position] = 0
}

#iterate through and record the position(s) for each player
for(i in 1:length(all_data$Position)){
	pos_of_person = strsplit(as.character(all_data$Position[i]), "/")[[1]]
	for(x in pos_of_person){
		all_data[,x][i] = 1
	}
}

#turn the born column into
# an age column
# 3 integer columns year:month:date

bday_parts = str_split_fixed(all_data$Born, "-",3)

#adjust year column to account for missing digits
table(birth_year)
birth_year = c()
for(year in bday_parts[,1]){
	if(as.numeric(year) < 10){
		yr = paste("20", year, sep="")
		birth_year = c(birth_year, yr)
	}else{
		yr = paste("19",year, sep="")
		birth_year = c(birth_year, yr)
	}
}

all_data$birth_year = as.numeric(birth_year)
all_data$birth_month = as.numeric(bday_parts[,2])
all_data$birth_day = as.numeric(bday_parts[,3])

#split Cntry and Nat to boolean columns

birth_country = levels(all_data$Cntry)
# add columns with the country of birth options
# note the Estonia for Uncle Leo
for(country in birth_country){
	c = paste("born", country, sep="_")

	all_data[,c] = 0
}

#iterate through and record the birth country of each player
for(i in 1:length(all_data$Cntry)){
	birth_country = all_data$Cntry[i]
	c = paste("born", birth_country, sep="_")
	all_data[,c][i] = 1
}

nationality = levels(all_data$Nat)
for(country in nationality){
	c = paste("nation", country, sep="_")
	all_data[,c] = 0
}

#iterate through and record the birth country of each player
for(i in 1:length(all_data$Nat)){
	nationality = all_data$Nat[i]
	c = paste("nation", nationality, sep="_")
	all_data[,c][i] = 1
}

# impute the missing value's median for numerical columns

#fill median values
#loop through the dataframe, filling each column with the median of
#the existing values for the entire dataset
#where are there still missing values?

all_missing_list =  colnames(all_data)[colSums(is.na(all_data)) > 0]
length(all_missing_list) == 0
#if above true all values are imputed!

for( i in 1:length(all_missing_list)){
	#get the global median
	median_all = median(all_data[,all_missing_list[i]], na.rm =TRUE)
	#imput the missing values with the column's median
	all_data[,all_missing_list[i]][is.na(all_data[,all_missing_list[i]])] = median_all
}

all_data = all_data[, !(colnames(all_data) %in% c("Last.Name","First.Name","Cntry","Nat","Born","Team","City","Position"))]
head(all_data)

train_dat = all_data[all_data$TrainTest == "train",]

test_dat = all_data[all_data$TrainTest == "test",]
#we lose anyone?
length(test_dat$TrainTest) + length(train_dat$TrainTest) == length(all_data$TrainTest)

#drop the train/test split columns
train_dat = train_dat[, !(colnames(train_dat) %in% c("TrainTest"))]
test_dat = test_dat[, !(colnames(test_dat) %in% c("TrainTest"))]

y_column = c("Salary")
all_columns = names(train_dat)
predictor_columns = all_columns[all_columns != y_column]
predictor_columns

###################################
###################################
#New XGBoost code
###################################
###################################
#Additional XGBoost Cleaning
#need to make these into dummy variables before passing into xgb.DMatrix

train_in = select(train_dat,one_of(predictor_columns))
test_in = select(test_dat,one_of(predictor_columns))

names(train_df)[4:length(names(train_df))]
head(train_in)

#change undrafted to 0 and 1
train_in$undrafted = as.numeric(train_in$undrafted)
test_in$undrafted = as.numeric(test_in$undrafted)
#change the hand to two booleans
train_in = cbind(train_in ,dummy(train_in$Hand))
test_in = cbind(test_in ,dummy(test_in$Hand))

# Pr.St check if the pr.st are same in each
levels(train_in$Pr.St) == levels(test_in$Pr.St)
#same. therefore we can conduct the dummy creation
train_in = cbind(train_in ,dummy(train_in$Pr.St))
test_in = cbind(test_in ,dummy(test_in$Pr.St))

#drop the pre dummies
train_in = train_in[, !(colnames(train_in) %in% c("Hand","Pr.St"))]
test_in = test_in[, !(colnames(test_in) %in% c("Hand","Pr.St"))]

tail(test_in)
#now there are no string to worry about and we can load in the numeric matrix
#note label args below different, see if syntax for one or both work.
dtrain = xgb.DMatrix(data =  as.matrix(train_in), label = train_dat$Salary)
dtest = xgb.DMatrix(data =  as.matrix(test_in), label = test_dat[,y_column])

watchlist = list(train=dtrain, test=dtest)
bst = xgb.train(data=dtrain, max.depth=8, eta=0.3, nthread = 2, nround=1000, watchlist=watchlist, objective = "reg:linear", early_stopping_rounds = 50)
#48rounds on standard

XGBoost_importance = xgb.importance(feature_names = names(train_in), model = bst)
XGBoost_importance[1:10]

#top predictors == xGF and DrftYr

#graph the XGboost top predictors in 2 and 3 dimensions, compare and contrast with the random forest top predictors

color.gradient <- function(x, colors=c("green", "yellow", "red"), colsteps=100) {
  return( colorRampPalette(colors) (colsteps) [ findInterval(x, seq(min(x),max(x), length.out=colsteps)) ] )
}

sd3 = scatterplot3d(graph_all_data$xGF, graph_all_data$DftYr,  graph_all_data$Salary, # x y and z
                 pch=19,
                 type="h",
			cex.axis=0.5,
			las=1,
			lty.hplot=2,
                	color=color.gradient(all_data$Salary,c("black","salmon")),
			main="Interaction of age, goals and salary",
                 zlab="Salary",
                xlab="xGF:",
			ylab="Draft Year",
			grid=TRUE)

sd3.coords = sd3$xyz.convert(graph_all_data$xGF, graph_all_data$DftYr,  graph_all_data$Salary) # convert 3D coords to 2D projection
text(sd3.coords$x, sd3.coords$y,labels= graph_all_data$Last.Name,cex=.5, pos=4)


histo <- read.delim("output/protocol_size_histogram/part-r-00000", header=F)

pdf(file="output/protocol_size_histogram/plot.pdf")

plot(histo)


snp.sq <- function(i, j, ld, write.ld.val, color, polygon.par, cex.ld) {
  if(i == j) return(); # pas de plot d'un SNP avec lui même
  if(j < i) { tmp <- j; j <- i; i <- tmp } # i < j
  d <- (j-i)/2
  cx <- i+d
  cy <- -d
  do.call(polygon, c(list(x = cx+c(-1,0,1,0)/2, y = cy + c(0,1,0,-1)/2, col = color), polygon.par))
  if(write.ld.val) text(cx, cy, ld, cex = cex.ld)
}

LD.plot <- function(LD, snp.positions, max.dist = Inf, depth = nrow(LD), graphical.par = list(mar = c(0,0,0,0)),
                    cex.ld, cex.snp, polygon.par = list(border = "white"),
                    color.scheme = function(ld) rgb(1,1-abs(ld),1-abs(ld)),
                    write.snp.id = TRUE, write.ld = function(ld) sprintf("%.2f", ld),
                    draw.chr = TRUE,
                    above.space = 1 + 2*write.snp.id + draw.chr, below.space = 1,
                    pdf.file, finalize.pdf = TRUE) {

  n <- nrow(LD)
  positions <- if(missing(snp.positions)) rep(0,n) else snp.positions
  # dry run to get graph depth
  graph.depth <- 0
  for(i in seq(1,n-1))
    for(j in seq(i+1, min(n,i+depth))) {
      if(positions[j] - positions[i] > max.dist) next;
      graph.depth <- max(graph.depth, (j-i)/2)
    }

  if(!missing(pdf.file))
    pdf(pdf.file, width = n/2, height = (graph.depth + above.space + below.space)/2)

  do.call(par, graphical.par)
  write.ld.val <- ifelse(is.null(write.ld), FALSE, TRUE)
  plot( 0,0, xlim=c(0.5,n+0.5), ylim=c(-graph.depth-below.space,above.space), type="n",
        asp = 1, xaxt="n", yaxt="n", bty="n", xlab = "", ylab = "")
  ld <- ""

  if(missing(cex.ld) & write.ld.val)
    cex.ld = 0.7*par("cex") / max(strwidth(sapply(LD, write.ld)))

  for(i in seq(1,n-1))
    for(j in seq(i+1, min(n,i+depth))) {
      if(positions[j] - positions[i] > max.dist) next;
      if(write.ld.val) ld <- write.ld(LD[i,j])
      snp.sq(i, j, ld, write.ld.val, color.scheme(LD[i,j]), polygon.par, cex.ld)
    }
  if(write.snp.id) {
    rs.h <- strheight(rownames(LD))
    if(missing(cex.snp)) cex.snp <- 0.25*par("cex")/max(rs.h)
    text( 1:n, 0, rownames(LD), srt = 90, cex = cex.snp, adj = c(0,0.5))
  }
  if(!missing(snp.positions) & draw.chr) {
    if(write.snp.id)
      a <- max( strwidth(rownames(LD), cex = cex.snp) )
    else
      a <- 0
    pos <- 1.5 + (n-2)*(snp.positions - snp.positions[1])/diff(range(snp.positions))
    segments( 1:n, a+0.25,  pos, a + 1.5 )
    rect(1.5, a+1.5, n-0.5, a+1.75)
    segments( pos, a+1.5,  pos, a + 1.75 )
  }
  if(!missing(pdf.file) & finalize.pdf) dev.off()
}


library(seqinr)
library(MASS)
library(ggplot2)
library(ggpubr)

sieve <- function(n) {
  n <- as.integer(n)
  if(n > 1e6) stop("n too large")
  primes <- rep(TRUE, n)
  primes[1] <- FALSE
  last.prime <- 2L
  for(i in last.prime:floor(sqrt(n)))
  {
    primes[seq.int(2L*last.prime, n, last.prime)] <- FALSE
    last.prime <- last.prime + min(which(primes[(last.prime+1):n]))
  }
  which(primes)
}

seqList <- function(x, type) {
  if (type == "DNA") {
    as.list(read.fasta(x,
                       as.string = FALSE,
                       seqtype="DNA",
                       seqonly = FALSE,
                       strip.desc = TRUE))
  }
  else {
    if (type == "AA") {
      as.list(read.fasta(x,
                         as.string = FALSE,
                         seqtype="AA",
                         seqonly = FALSE,
                         strip.desc = TRUE))
    }
    else {
      NULL
    }
  }
}

createRandomSequencesBasedOnDistr <- function(count, length, prob=c(0.25,0.25,0.25,0.25), fileNameRandSeqs) {

  sink(fileNameRandSeqs)
  set.seed(seedValuesList[1])
  for (i in 1:count) {
    cat(">Seq", i, "\n", sep = "")
    seqX <- sample(c("A","C","G","T"), length, rep=TRUE, prob)
    cat(paste(seqX,collapse=""), "\n", sep = "")
  }
  sink()
}

createRandomSequenceValues <- function(seedList, type) {

  if ( type == "DNA" ) {
    results <- matrix(, nrow = length(seedList), ncol = 4)
  }
  else if ( type == "AA" ) {
    results <- matrix(, nrow = length(seedList), ncol = 23)
  }

  for (i in 1:length(seedList)) {
    set.seed(seedValuesList[i])
    if ( type == "DNA" ) {
      results[i,] <- sample(seq(from = 1, to = 4, by = 1), size = 4, replace = FALSE)
    }
    else if ( type == "AA" ) {
      results[i,] <- sample(seq(from = 1, to = 23, by = 1), size = 23, replace = FALSE)
    }
  }
  return(results)
}

assignSets <- function(randSequenceValues, type) {

  stringValues <- ""

  if (type == "DNA") {
    #DNA Set
    cat("Sequence Values: (")

    for (i in 1:4) {
      stringValues <- paste(stringValues, randSequenceValues[i], ", ")
    }
    cat(stringValues)
    cat(")\n")
    assign("a", randSequenceValues[1], envir = .GlobalEnv)
    assign("t", randSequenceValues[2], envir = .GlobalEnv)
    assign("g", randSequenceValues[3], envir = .GlobalEnv)
    assign("c", randSequenceValues[4], envir = .GlobalEnv)
  }
  else if ( type == "AA") {
    # AA Set 1
    cat("Sequence Values: (")
    for (i in 1:23) {
      stringValues <- paste(stringValues, randSequenceValues[i], ", ")
    }
    cat(stringValues)
    cat(")\n")
    assign("A", randSequenceValues[1], envir = .GlobalEnv) # alanine, ala
    assign("R", randSequenceValues[2], envir = .GlobalEnv) # arginine, arg
    assign("N", randSequenceValues[3], envir = .GlobalEnv) # asparagine, asn
    assign("D", randSequenceValues[4], envir = .GlobalEnv) # aspartic acid, asp
    assign("B", randSequenceValues[5], envir = .GlobalEnv) # sparagine or aspartic acid, asx
    assign("C", randSequenceValues[6], envir = .GlobalEnv) # cysteine, cys
    assign("E", randSequenceValues[7], envir = .GlobalEnv) # glutamic acid, glu
    assign("Q", randSequenceValues[8], envir = .GlobalEnv) # glutamine, gln
    assign("Z", randSequenceValues[9], envir = .GlobalEnv) # glutamine or glutamic acid, glx
    assign("G", randSequenceValues[10], envir = .GlobalEnv) # glycine, gly
    assign("H", randSequenceValues[11], envir = .GlobalEnv) # histidine, his
    assign("I", randSequenceValues[12], envir = .GlobalEnv) # isoleucine, ile
    assign("L", randSequenceValues[13], envir = .GlobalEnv) # leucine, leu
    assign("K", randSequenceValues[14], envir = .GlobalEnv) # lysine, lys
    assign("M", randSequenceValues[15], envir = .GlobalEnv) # methionine, met
    assign("F", randSequenceValues[16], envir = .GlobalEnv) # phenylalanine, phe
    assign("P", randSequenceValues[17], envir = .GlobalEnv) # proline, pro
    assign("S", randSequenceValues[18], envir = .GlobalEnv) # serine, ser
    assign("T", randSequenceValues[19], envir = .GlobalEnv) # threonine, thr
    assign("W", randSequenceValues[20], envir = .GlobalEnv) # tryptophan, trp
    assign("Y", randSequenceValues[21], envir = .GlobalEnv) # tyrosine, tyr
    assign("V", randSequenceValues[22], envir = .GlobalEnv) # valine, val
    assign("X", randSequenceValues[23], envir = .GlobalEnv) # undetermined
  }

  stringValues
}

godelStatistics <- function(x) {

  if (logOutput) {
    cat(paste("  Min  : ", summary(x)[1], "\n"))
    cat(paste("1st Qu.: ", summary(x)[2], "\n"))
    cat(paste("Median : ", summary(x)[3], "\n"))
    cat(paste(" Mean  : ", summary(x)[4], "\n"))
    cat(paste("3rd Qu.: ", summary(x)[5], "\n"))
    cat(paste("  Max  : ", summary(x)[6], "\n"))
    cat(paste("St. Dev: ", sd(x), "\n"))
  }

  results <- list(minG = summary(x)[1], firstQG = summary(x)[2],
       medianG = summary(x)[3], meanG = summary(x)[4],
       thirdQG = summary(x)[5], maxG = summary(x)[6],
       stdG = sd(x))

  return(results)
}

primes <- sieve(20000) # length of primes should be >= max sequence length
logOutput <- FALSE     # debug output
numberOfPoints <- 4;   # number of different assignments of letters for Godel numbers
replicate <- FALSE     # if we need to set specific seed numbers

if (replicate == FALSE) {
  seedValuesList <- sample(seq(from = 1, to = 1000, by = 1), size = numberOfPoints, replace = FALSE)
  for (i in 1:numberOfPoints) {
    cat(paste(seedValuesList[i], ", "))
  }
} else {
  seedValuesList <- as.numeric(unlist(read.csv(file="seeds.csv", header = FALSE)))
  numberOfPoints <- length(seedValuesList)
}

type <- "DNA"
# The following values should execute within 6 minutes with a good enough resolution
seqLengthLimit <- 361
numberOfArtificialSeqs <- 821     # "A","C","G","T"
# amend the following line for your particular distribution on nucloetide presence.
createRandomSequencesBasedOnDistr(numberOfArtificialSeqs, seqLengthLimit, c(0.25,0.25,0.25,0.25), "data/artificialSeqs.fasta")
ompGene.list <- seqList("data/artificialSeqs.fasta", type)
# ompGene.list <- seqList("data/realSeqs.fasta", type)
ompGene.list.raw <- ompGene.list

randValues <- createRandomSequenceValues(seedValuesList, type)

randValues

# Do not run this cell if you want to check for all nucleotides and not just for A
# randValues[1,] <- c(3, 2, 1, 4)
randValues

ompGene.list <- ompGene.list.raw[which(getLength(ompGene.list.raw) >= 1)]
sizeExp <- length(ompGene.list)
selectedSequences <- c(1:sizeExp)

godelValuePoints <- data.frame(matrix(0, ncol = numberOfPoints, nrow = sizeExp))
namesList <- list()
for (i in 1:numberOfPoints) {
  namesList[i] <- paste('godel_log_pos', i, sep = '')
}
godelValuePoints <- setNames(godelValuePoints, namesList)
godelValuePoints$seqNames <- unlist(attributes(ompGene.list)$name)

stringAssignValues <- vector(mode="character", length=numberOfPoints)

for (indexPos in 1:numberOfPoints) {
  stringAssignValues[indexPos] <- assignSets(randValues[indexPos,], type)

  godel.value.exp <- list()
  godel.value.log <- list()

  for (indexSeq in selectedSequences) {

    godel.value.exp[[indexSeq]] <- 1
    godel.value.log[[indexSeq]] <- 0

    if (logOutput) {
      cat("Sequence length  ")
      cat(indexSeq)
      cat("  :")
      cat(length(ompGene.list[indexSeq][[1]]))
      cat("\n")
    }

    for (i in 1:length(ompGene.list[indexSeq][[1]])) {

      prime <- as.numeric(primes[i])
      alpha <- as.numeric(get(as.character(ompGene.list[[indexSeq]])[i]))

      godel.value.exp[[indexSeq]] <- godel.value.exp[[indexSeq]] * prime ** alpha
      godel.value.log[[indexSeq]] <- godel.value.log[[indexSeq]] + alpha*log(prime)
    }

  }

  godelValuePoints[, paste('godel_log_pos', indexPos, sep = '')] <- unlist(godel.value.log)
}

statsPos <- data.frame(matrix(0, ncol = 7, nrow = numberOfPoints))
statsPos <- setNames(statsPos, c("minG", "firstQG", "medianG", "meanG", "thirdQG", "maxG", "stdG"))
for (indexPos in 1:numberOfPoints) {
  statsPos[indexPos, ] <- godelStatistics(godelValuePoints[, paste('godel_log_pos', indexPos, sep = '')])
}

statsPos

P1 <- sum(log(primes[1:seqLengthLimit]))
P2 <- sum((log(primes[1:seqLengthLimit]))^2)

theoreticalMeanEqual <- P1*2.5
theoreticalStdEqual <- sqrt(P2*1.25)

theoreticalMeanEqual
theoreticalStdEqual

para <- matrix(nrow=numberOfPoints, ncol = 2)
for (indexPos in 1:numberOfPoints) {
  fit <- fitdistr(godelValuePoints[, indexPos], "normal")
  para[indexPos, 1] <- fit$estimate["mean"]
  para[indexPos, 2] <- fit$estimate["sd"]
}

statsPos$stringAssignValues <- as.factor(stringAssignValues)
statsPos$fit_estimate <- ((para[,1]-theoreticalMeanEqual)/para[,1])*100
statsPos$fit_sd <- ((para[,2]-theoreticalStdEqual)/para[,2])*100

mean(statsPos$fit_estimate)
mean(statsPos$fit_sd)

indexPos = 10

binwidthPlot = 5

ggplot(godelValuePoints, aes(x=godelValuePoints[, indexPos]), environment = environment()) +
  geom_histogram(aes(y=..density..), colour="black", fill="white", binwidth=binwidthPlot)+
  geom_density(alpha=.2, fill="#FF6666") +
  stat_function(fun = dnorm, args = list(mean = para[indexPos, 1], sd = para[indexPos, 2]), color = "darkred", size = 2, linetype = "dotdash") +
  labs(title= "Histogram and Density plot of Godel numbers",x="Godel numbers", y = "Density")+
  scale_color_brewer(palette="Accent") +
  theme_minimal()

p1 <- ggplot(statsPos, aes(x = reorder(stringAssignValues, fit_estimate), y = fit_estimate, group=1)) +
  geom_point() +
  geom_line() +
  theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
  labs(title= "Difference between theoretical and observed value of Mean (%)",x="Assignments", y = "Difference in mean (%)")

p2 <- ggplot(statsPos, aes(x = reorder(stringAssignValues, fit_estimate), y = fit_sd, group=1)) +
  geom_point() +
  geom_line() +
  theme(axis.text.x = element_text(angle = 90, hjust = 1)) +
  labs(title= "Difference between theoretical and observed value of standard deviation (%)",x="Assignments", y = "Difference in  standard deviation (%)")

ggarrange(p1 + rremove("x.text"), p2,
          labels = c("A", "B"),
          ncol = 1, nrow = 2)

# a t g c
lapply(which(statsPos$maxG == min(statsPos$maxG)),
       function(x) assignSets(randValues[x,], "DNA"))
# artificial dataset: 4 , 1 , 3 , 2 (min of meanG)
# artificial dataset: 4 , 2 , 1 , 3 (min of minG)
# artificial dataset: 2 , 1 , 3 , 4 (min of maxG)

# a t g c
lapply(which(statsPos$maxG == max(statsPos$maxG)),
       function(x) assignSets(randValues[x,], "DNA"))
# artificial dataset: 1 , 4 , 2 , 3 (max of meanG)
# artificial dataset: 4 , 3 , 2 , 1 (max of minG)
# artificial dataset: 1 , 3 , 4 , 2 (max of maxG)


a<-Read.consum_ab()
head(a)
ftable(round(tapply(a$parameter,list(paste(formatC(a$Species.n,width=2,flag='0'),a$Species),a$Quarter,a$ab),sum),3))


## bp_km_wrap.R
# Function wrapping of the bp_km

bp_km_wrap <- function(list_Ss, sessions,
                       path_read,
                       rp_index = c(1, 11)) {

  last_n_list <- last_n_ses(list_Ss = list_Ss,
                            n = sessions,
                            path_read = path_read)

  df_1 <-  lapply(last_n_list, function(k){

    df_2 <- read_sep_by_lever(k, 1) %>%
      as.data.frame()

    if (!is_empty(df_2)) {

      df_2 <- df_2[df_2$evento %in% rp_index, ]
      # print(k)
      df_2$bins <- get_bins(df_2$cum_dt, 1, 180, 1)

      cde <- unique(df_2$cde)
      subj <- unique(df_2$sujeto)
      sess <- unique(df_2$sesion)
      met2 <- data.frame()
      met3 <- data.frame()

      tcheck <- unique(df_2$trial)

      if (length(tcheck) > 0) {
        if (length(cde) > 1) {
          for (l in cde) {
            l <- cde[l]
            df_3 <- df_2[df_2$cde == l, ]
            trials <- unique(df_3$trial)

            for (j in 1:length(trials)) {

              df_4 <- df_3[df_3$trial == j, ]
              r_times <- df_4$bins

              if (length(r_times) > 9) {
                print(paste(k,l,j)) # for debugging
                met <- bp_km(r_times)
                met$trial <- j
                met$cde <- l
                met$sujeto <- subj
                met$sesion <- sess

              } else {
                met <- data.frame()
              }
              met2 <- bind_rows(met, met2)
            }
          }
        }
        met2
      }
    }
  }) %>% bind_rows()
  df_1
}


#' Generate one set of weekly boxplots
#'
#' Generate a single set of boxplots of factors by week for a range of weeks
#'
#' @param this_factor Numeric vector of factors from weekly seasonal adjustment.
#' @param this_week Numeric vector; Week of the year to match.
#' @param first_week Numeric scalar; First week to be included in the plot.
#' @param last_week Numeric scalar; Last week to be included in the plot.
#' @param forecast Numeric scalar; Number of forecasts. Default: 0.
#' @param this_range Numeric scalar; Range of the seasonal factors to be plotted. Default: range taken from the observations being plotted.
#' @return Generate a plot of seasonal factors by week. User can specify limits for the weeks plotted in order to generate a multi-panel plot.
#' @examples
#' par(mfrow = c(3, 2), mar = c(3.1, 2.1, 0.5, 0.5), oma = c(0, 0, 3, 0))
#' sf_range <- range(ic_sf)
#' plot_boxplot_single(ic_sf, ic_week,  1,  9, this_range = sf_range)
#' plot_boxplot_single(ic_sf, ic_week, 10, 18, this_range = sf_range)
#' plot_boxplot_single(ic_sf, ic_week, 19, 27, this_range = sf_range)
#' plot_boxplot_single(ic_sf, ic_week, 28, 36, this_range = sf_range)
#' plot_boxplot_single(ic_sf, ic_week, 37, 45, this_range = sf_range)
#' plot_boxplot_single(ic_sf, ic_week, 46, 53, this_range = sf_range)
#' @import stats
#' @import graphics
#' @export
plot_boxplot_single <- function(this_factor, this_week, first_week, last_week, forecast = 0, this_range = NULL) {
    # Author: Brian C. Monsell (OEUS), Version 1.8, 1/12/2022

    # generate number of factors not including forecasts
    fac <- this_factor[1:(length(this_factor) - forecast)]

    # generate filter for the range of weeks being plotted
    this_filter <- this_week == first_week
    for (this_freq in seq((first_week + 1),last_week)) {
        this_filter <- this_filter | this_week == this_freq
    }

    # generate boxplots of factors
    if (!is.null(this_range)) {
        boxplot(fac[this_filter] ~ this_week[this_filter], ylim = this_range)
    } else {
        boxplot(fac[this_filter] ~ this_week[this_filter])
    }

}


# Scatterplot faceted by payee, colored by account
p <- qplot(date, amount, data = ledger_data, geom = "point", colour = payee, alpha = I(1/2)) + facet_wrap(~account)

ggsave(file = "scatter-amount-vs-date-by-payee-facet-account.svg", plot = p, width = 10, height = 10)


# Script to perform data visualisation
# All visualise stored in dataVisualisation/Plots

# Load required libraries
library(wordcloud)
library(ggplot2)
library(SnowballC)
library(plyr)
library(RColorBrewer)
library(sentimentr)
library(tm)
library(data.table)
library(ggrepel)

# ***Functions***
# Sentiment Analysis
# return sentiment
sentimentAnalysis = function(data_frame, column1, column2) {
  sentiment=with(data_frame, sentiment_by(data_frame$column1, list(data_frame$column2)))
  png('dataVisualisation/Plots/sentiment.png')
  plot(sentiment)
  dev.off()
  return()
}

# Wordcloud
corpusFunction = function(data_frame) {
  c = Corpus(VectorSource(data_frame))
  return(c)

}

# Word Frequency
wordFreq = function(corpus) {
  tdm = TermDocumentMatrix(corpus)
  m = as.matrix(tdm)
  #Calculate frequency
  v = sort(rowSums(m), decreasing = TRUE)
  d = data.frame(word = names(v), freq = v)
  d$word = gsub("-", "", d$word)
  png('dataVisualisation/Plots/wordcloud.png')
  wordcloud(words = d$word, freq = d$freq, min.freq = 50,
            max.words = 500, random.order = FALSE,
            rot.per = 0.2, colors = brewer.pal(8, "Dark2"))
  dev.off()
}

# Number of words
wordsNO = function(corpus) {
  tdm = TermDocumentMatrix(corpus)
  wordsNO = data.frame(rowSums(as.matrix(tdm)))
  return(wordsNO)
}

# ***Call Functions***
# Sentiment Analysis
sentiment = sentimentAnalysis(dfData, Documents, Summaries)

# Corpus Documents
corpusDoc = corpusFunction(dfData$Documents)

# Wordcloud Documents
wordcloudDoc = wordFreq(corpusDoc)

# Number of words (Prepare subset)
numWCorpus = corpusFunction(dfData$Documents)
numW = wordsNO(numWCorpus)
numW = setDT(numW, keep.rownames = TRUE)[]
setnames(numW, old = c('rn', 'rowSums.as.matrix.tdm..'), new = c('Words', 'Frequency'))
allWords=sum(numW$Frequency)

# Visualise Top 10 words
top_word = numW[order(numW$Frequency, decreasing = TRUE)]
top_word_10 = head(top_word, 10)
d = ggplot(top_word_10)
d = d + aes(Words, Frequency)
d = d + geom_bar(stat = "identity")
png('dataVisualisation/Plots/wordFrequency.png')
d
dev.off()


#' #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.
#' @author Sameena Shah
#' @param start.date start.date in Y-m-d format
#' @param end.date end.date in Y-m-d format
#' @param from.curr set of currencies to be converted
#' @param to.curr which currency to be converted to
#' @param rate.type SPOT or which forward contract etc
#' @return data.frame
#' @export
get.currency.rates  	<- 	function(start.date='2011-01-01',end.date='2011-02-01',from.curr='all',to.curr='USD',rate.type='SPOT'){
	conn <- get.qad.connection()

  if(from.curr=='all'){
    query <- sprintf( "SELECT ExRateDate AS date, MidRate AS mid_rate, BidRate AS bid_rate,OfferRate AS offer_rate,FromCurrCode AS from_curr_code,ToCurrCode AS to_curr_code ,RateTypeCode AS rate_type_code FROM Ds2FxRate rate JOIN Ds2FxCode code ON rate.ExRateIntCode = code.ExRateIntCode WHERE ToCurrCode = '%s' AND ExRateDate BETWEEN '%s' AND '%s' AND RateTypeCode ='%s'", to.curr, start.date, end.date, rate.type )
    currency.rates <- sqlQuery(conn,query)
  }
  else {
      currency.rates <- data.frame()
      i <- 1
      while(i<=length(from.curr)){

        query <- sprintf( "SELECT ExRateDate AS date, MidRate AS mid_rate, BidRate AS bid_rate,OfferRate AS offer_rate,FromCurrCode AS from_curr_code,ToCurrCode AS to_curr_code ,RateTypeCode AS rate_type_code FROM Ds2FxRate rate JOIN Ds2FxCode code ON rate.ExRateIntCode = code.ExRateIntCode WHERE ToCurrCode = '%s' AND FromCurrCode = '%s' AND ExRateDate BETWEEN '%s' AND '%s' AND RateTypeCode = '%s'", to.curr, from.curr[i],  start.date, end.date, rate.type )
        temp <- sqlQuery(conn,query)
        currency.rates <- rbind(currency.rates,temp)
        i <- i +1
      }
}
  return(currency.rates)

}


#!/usr/bin/env Rscript

# To be run on atlas

library(data.table)
library(ggplot2)
library(plyr)
library(reshape2)

# functions
seq_order_fun  <- function(x) {
  seq_along(x)
}
to_numeric <- function(data, feature){
  data[[feature]] <- as.factor(data[[feature]])
  data[[feature]]<- mapvalues(data[[feature]], from=levels(data[[feature]]),
                              to = 1:length(levels(data[[feature]])))
  return(data)
}

dynamic_dt_prep <- function(data, seq_length, nm=nms){
  length_dst <- as.data.frame(table(data$sessionId))
  sequences_long <- subset(length_dst, Freq>=seq_length)$Var1
  dt_long <- subset(data, sessionId %in% sequences_long)
  dt_longg <- dt_long[,-c('accountId',nm[-1],'gcName'),with=F]
  dt_long <- ddply(dt_longg, .(sessionId), mutate, seq_order = seq_order_fun(sessionId))
  dt_long_frst <- subset(dt_long, seq_order<=seq_length)
  dt_long_frst <- as.data.table(dt_long_frst)
  for(i in c("gcCause", "gcAction")){
    dt_long_frst <- to_numeric(dt_long_frst, i)
  }
  suppressWarnings(for (i in seq_along(dt_long_frst)) set(dt_long_frst, i=which(dt_long_frst[[i]]==-1), j=i, value=0))
  dt_wide <- dcast.data.table(dt_long_frst, sessionId ~ seq_order, value.var=colnames(dt_long_frst)[-c(1,2,21)], fill=NaN)
  return(dt_wide)
}

dt  <- fread("/gpfs/hpchome/etais/hpc_anna1985/Research/Generative-Models-in-Classification/Data/corrected_dt.txt", header=FALSE)
nms <- as.character(c("accountId, sessionId, javaVersion,cpuCoreCount,maxAvailableMemory,timestamp,duration,gcCause,gcAction,gcName,PS Perm Gen used before,PS Perm Gen max before,PS Eden Space used before,PS Eden Space max before,
PS Old Gen used before,PS Old Gen max before,PS Survivor Space used before,PS Survivor Space max before,PS Perm Gen used after,PS Perm Gen max after,PS Eden Space used after,PS Eden Space max after,
PS Old Gen used after,PS Old Gen max after,PS Survivor Space used after,PS Survivor Space max after,allocationRate,promotionRate,maturityRate"))
nms <- strsplit(nms, split = ",")[[1]]
corrected_names <- gsub(" ", "", nms, fixed = TRUE)
setnames(dt, corrected_names)

dt$duration <- as.numeric(dt$duration)
dt$sessionId <- as.factor(dt$sessionId)
dt$timestamp <- as.numeric(dt$timestamp)
gc_overhead <- ddply(dt, .(sessionId), summarize, gc_overhead=sum(duration)/(max(timestamp)-min(timestamp)))
gc_overhead$gc_overhead <- ifelse(is.finite(gc_overhead$gc_overhead)!=T, 0, gc_overhead$gc_overhead)
gc_overhead <- subset(gc_overhead, gc_overhead<=1)

# labels
gc_overhead$label <- ifelse(gc_overhead$gc_overhead>=0.05,1,0)
gc_overhead$index <- c(1:nrow(gc_overhead))

# static
nms <- as.character(c("sessionId, javaVersion, cpuCoreCount, maxAvailableMemory, PSPermGenmaxbefore, PSOldGenmaxbefore, PSPermGenmaxafter, PSOldGenmaxafter"))
nms <- strsplit(nms, split = ", ")[[1]]

dt_static <- dt[,nms, with=F]
dt_static_agg <- dt_static[!duplicated(dt_static$sessionId), ]
dt_static <- merge(dt_static_agg, gc_overhead[,c("sessionId","index")], by="sessionId")
dt_static$javaVersion <- ifelse(dt_static$javaVersion==1.7,1,2)
dt_static$PSPermGenmaxbefore <- ifelse(dt_static$PSPermGenmaxbefore==-1,0,dt_static$PSPermGenmaxbefore)
dt_static$PSPermGenmaxafter <- ifelse(dt_static$PSPermGenmaxafter==-1,0,dt_static$PSPermGenmaxafter)

dt$maturityRate <- NULL
dt_wide <- dynamic_dt_prep(dt, seq_length=10) # very slow
dt_wide <- merge(dt_wide, gc_overhead[,c(1,4)], by="sessionId")
dt_dynamic <- dt_wide[order(dt_wide$index, decreasing=F),]

#only those that are smaller than pre-defined length are kept

dt_static <- subset(dt_static, sessionId %in% dt_dynamic$sessionId)

gc_overhead <- subset(gc_overhead, sessionId %in% dt_dynamic$sessionId)

#balancing
positive <- subset(gc_overhead, label==1)
negative <- subset(gc_overhead, label==0)

neg_idx <- negative[sample(nrow(negative), nrow(positive))]$index
pos_idx <- positive$index

gc_overhead_balanced <- rbind.data.frame(positive, subset(negative, index %in% neg_idx))

dt_dynamic_balanced <- rbind.data.frame(subset(dt_dynamic, index %in% pos_idx), subset(dt_dynamic, index %in% neg_idx))
dt_dynamic_balanced$index <- NULL
dt_dynamic_balanced$sessionId <- NULL

dt_static_balanced <- rbind.data.frame(subset(dt_static, index %in% pos_idx), subset(dt_static, index %in% neg_idx))
dt_static_final <- dt_static_balanced[,-c("sessionId","index"),with=F]

# writing results
write.table(as.data.frame(gc_overhead_balanced$label), "/gpfs/hpchome/etais/hpc_anna1985/Research/Generative-Models-in-Classification/Data/labels_piper.txt",
            col.names=F, row.names=F, sep=',',quote=F)

write.table(dt_static_final, "/gpfs/hpchome/etais/hpc_anna1985/Research/Generative-Models-in-Classification/Data/static_piper.txt",
            col.names=F, row.names=F, sep=',',quote=F)

write.table(dt_dynamic_balanced, "/gpfs/hpchome/etais/hpc_anna1985/Research/Generative-Models-in-Classification/Data/dynamic_piper.txt",
            col.names=F, row.names=F, sep=',',quote=F)


 TestTrainSplit<-function(input.file,output.file,response.col="ResponseBinary",trainProp=.7,RatioPresAbs=NULL){

#Description:
#this code takes as input an mds file with the first line being the predictor or
#response name, the second line an indicator of predictors to include and the
#third line being paths where tif files can be found.   An output file and a
#response column must also be specified.  Given a training proportion, a new
#column is created indicating whether each observation should be assigned to the
#test or training split with the correct proportion.
#trainProp=#obs to be assigned to training split/total sample size
#his will be balanced with respect to the response in that the training
#proportion will be matched as close as possible for each level of the response.
#An optional parameter, RatioPresAbs, can be used to specify if there is a certain
#ratio of presence to absence points that should be used this ensures the given
#ratio for all data used in both the test and train split.  For categorical data,
#all responses greater than or equal to 1 will be used to meet this ratio.
#This option reduces the sample size as some data must be thrown away to meet
#the constraint of having the desired proportion.  Background points are ignored
#by this module (they are read in, written out, but not assigned to either the
#test or training split).  Output is written to a csv that can be used by the
#SAHM R modules.

#Written by Marian Talbert 3/23/2011
#Modified 5/10/2011 to handle count data

     if(trainProp<=0 | trainProp>1) stop("Train Proportion (trainProp) must be a number between 0 and 1 excluding 0")
    if(!is.null(RatioPresAbs)) {
    if(RatioPresAbs<=0) stop("The ratio of presence to absence (RatioPresAbs) must be a \ngreater than 0")}

   #Read input data and remove any columns to be excluded
          dat.in<-read.csv(input.file,header=FALSE,as.is=TRUE)
          dat<-as.data.frame(dat.in[4:dim(dat.in)[1],])
          names(dat)<-dat.in[1,]

        response<-dat[,match(tolower(response.col),tolower(names(dat)))]

          if(sum(as.numeric(response)==0)==0 && !is.null(RatioPresAbs)) stop("The ratio of presence to absence cannot be set with only presence data")

      #Ignoring background data that might be present in the mds

          bg.dat<-dat[response==-9999,]

          if(dim(bg.dat)[1]!=0){
            dat<-dat[-c(which(response==-9999,arr.ind=TRUE)),]
            dat.in<-dat.in[-c(which(response==-9999,arr.ind=TRUE)+3),]
            response<-response[-c(which(response==-9999,arr.ind=TRUE))]
            bg.dat$TrainSplit=""
            }

         temp<-if(!is.null(RatioPresAbs))(sum(response>=1)/sum(response==0)==RatioPresAbs)
         if(is.null(temp)) temp<-FALSE
       if(is.null(RatioPresAbs)| temp){
        #Randomly sample presesce absence or counts as close to the size of the training proportion as possible

          #iterate through each unique response and randomly assign the trainProp to be in the training split
          TrainSplit<-numeric()
          for(i in sort(as.numeric(unique(response)))){
           TrainSplit<-c(TrainSplit,sample(which(response==i,arr.ind=TRUE),size=round(sum(response==i)*trainProp)))
            }

        #Take everything not in the training set for the test set
          TestSplit=which(!(seq(1:length(response)))%in%TrainSplit,arr.ind=TRUE)

          dat$TrainSplit[seq(1:length(response))%in%TrainSplit]<-"train"
          dat$TrainSplit[seq(1:length(response))%in%TestSplit]<-"test"

         #inserting data must be done in 3 steps because dat.in isn't a proper dataframe in that
         #not all elements in a column are of the same type
          dat.in<-dat.in[c(1:3,rownames(dat)),] #removing rows that weren't selected for the test train split
          dat.in[4:(dim(dat.in)[1]),(dim(dat.in)[2]+1)]<-dat$TrainSplit
          dat.in[c(1,3),(dim(dat.in)[2])]<-c("Split","")
          dat.in[2,(dim(dat.in)[2])]<-1

          } else {  #now considering if there is a desired ratio of presence to absence points
                if(sum(response>=1)/sum(response==0)>=RatioPresAbs){

                   #first determine how many presence points to remove
                     TotToRmv<-(sum(response>=1)-RatioPresAbs*sum(response==0))
                     # if(TotToRmv/sum(response>=1)>.5) {
                     #   warning("******************************************\n**** Over 50% of the
                     #  presence points were removed to meet the desired ratio of presence to absence \n******************************************")}
                  #determine the number of each count to remove weighted by the reponse and then remove these
                     EachToRmv<-round(TotToRmv*table(response[response!=0])/sum(response!=0))
                     ByCount<-split(cbind(which(response!=0,arr.ind=TRUE)),f=response[response!=0])

                     #sampling one from a vector of size 1 actually samples a sequence from 1 to the value in the vector
                     #so correcting this here
                     sam<-function(x,size){if(length(x)==1 & size==1) return(x)
                                            else sample(x=x,size=size)}

                     RmvIndx<-as.vector(unlist(mapply(sam,x=ByCount,size=EachToRmv)))
                     KeepIndx<-seq(1:length(response))[-c(RmvIndx)]
                     Response<-response[KeepIndx]
                     names(Response)<-KeepIndx

                     #now break these into a train an test split while
                    TrainSplit<-numeric()

                      for(i in sort(as.numeric(unique(Response)))){
                        TrainSplit<-c(TrainSplit,sample(names(Response[Response==i]),size=round(sum(Response==i)*trainProp)))
                      }
                       TrainSplit<-as.numeric(TrainSplit)
                      #Take everything not in the training set or in the remove list for the test set
                      TestSplit<-seq(from=1,to=length(response))[-c(c(TrainSplit,RmvIndx))]

                     dat$TrainSplit[seq(1:length(response))%in%TrainSplit]<-"train"
                     dat$TrainSplit[seq(1:length(response))%in%TestSplit]<-"test"

               }

               if(sum(response>=1)/sum(response==0)<RatioPresAbs){
                  browser()
               #first ballance all responses greater than 1
               TrainSplit<-numeric()
                for(i in sort(as.numeric(unique(response[response!=0])))){
                  TrainSplit<-c(TrainSplit,sample(which(response==i,arr.ind=TRUE),size=round(sum(response==i)*trainProp)))
                  }
                #  if((sum(response==0)-sum(response>=1)/RatioPresAbs)/sum(response==0)>.5) {
                #        warning("******************************************\n**** Over 50% of the
                #        absence points were removed to meet the desired ratio of presence to absence \n******************************************")}
                  #now sampling the right number of absence points for the train split
                  TrainSplit<-c(TrainSplit,sample(which(response==0,arr.ind=TRUE),size=round(sum(response>=1)*(1/RatioPresAbs)*trainProp)))

                      #Take everything not in the training set for the test set
                      TestSplit=which(!(seq(1:length(response)))%in%TrainSplit,arr.ind=TRUE)

                      #now sample some points to remove so we have the correct proportion
                      temp<-sample(which(TestSplit%in%which(response==0,arr.ind=TRUE),arr.ind=TRUE),
                        size=round(sum(TestSplit%in%which(response==0,arr.ind=TRUE))-(1-trainProp)*sum(response>=1)*(1/RatioPresAbs)))
                      TestSplit<-TestSplit[-c(temp)]

                     dat$TrainSplit[seq(1:length(response))%in%TrainSplit]<-"train"
                     dat$TrainSplit[seq(1:length(response))%in%TestSplit]<-"test"

               }

               dat<-dat[c(TrainSplit,TestSplit),]

               dat.in<-dat.in[c(1:3,rownames(dat)),] #removing rows that weren't selected for the test train split
               dat.in[4:(dim(dat.in)[1]),(dim(dat.in)[2]+1)]<-dat$TrainSplit
               dat.in[c(1,3),(dim(dat.in)[2])]<-c("Split","")
               dat.in[2,(dim(dat.in)[2])]<-1

              }

              if(dim(bg.dat)[1]!=0) {
                names(bg.dat)<-names(dat.in)
                dat.in<-rbind(dat.in,bg.dat)}

              #write output files for R modules
             write.table(dat.in,file=output.file,row.names=FALSE,col.names=FALSE,sep=",",quote=FALSE)

    }

 #Reading in command line arguments
 Args <- commandArgs(T)
    print(Args)
    #assign default values

    responseCol <- "responseBinary"
    trainProp=.7
    RatioPresAbs=NULL
    #replace the defaults with passed values
    for (arg in Args) {
    	argSplit <- strsplit(arg, "=")
    	argSplit[[1]][1]
    	argSplit[[1]][2]
    	if(argSplit[[1]][1]=="p") trainProp <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="m") RatioPresAbs <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="o") output.file <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="i") infil <- argSplit[[1]][2]
    	if(argSplit[[1]][1]=="rc") responseCol <- argSplit[[1]][2]
    }

    RatioResAbs<-as.numeric(RatioPresAbs)
    trainProp<-as.numeric(trainProp)

	#Run the Test training split with these parameters
	TestTrainSplit(input.file=infil,output.file=output.file,response.col=responseCol,
  trainProp=trainProp,RatioPresAbs=RatioPresAbs)


#-----------------------------------------------------------------------------------------------------------------------------------------------------------

#------------------------------------------ Forest risk mapping models: Fig 1D-F code - 05/11/21 ----------------------------------------------

#-----------------------------------------------------------------------------------------------------------------------------------------------------------
# Author: William Anderegg (anderegg@utah.edu), University of Utah

library(rworldmap)
library(MASS)
library(SDMTools)
library(raster)
library(RNetCDF)
library(scales)
library(car)
library(RColorBrewer)
library(betareg)
library(pgirmess)
library(geosphere)
library(ape)

#---------------------------------- Pull in FIA mort data -------------------------------------
dir <- ""
fianew <- read.csv(paste(dir, "FIA-TerraClim-Wide-v17-04-14-2021.csv", sep = ""), header = T)
fialonga <- read.csv(paste(dir, "FIA-TerraClim-Long-1990.1999-v17-04-14-2021.csv", sep = ""), header = T)
fialongb <- read.csv(paste(dir, "FIA-TerraClim-Long-2000.2009-v17-04-14-2021.csv", sep = ""), header = T)
fialongc <- read.csv(paste(dir, "FIA-TerraClim-Long-2010.2019-v17-04-14-2021.csv", sep = ""), header = T)
FTpred_ins <- read.csv(paste(dir, "Insect_ForTypToPredict_04-21-2021.csv", sep = ""), header = T)
FTpred_drt <- read.csv(paste(dir, "Drought_ForTypToPredict_04-21-2021.csv", sep = ""), header = T)
# FTs that meet the minimum 20 mortality threshold and cross-validated AUC>0.6

# Processing projection and a useful logical function
proj2 <- CRS("+proj=longlat +datum=WGS84 +ellps=WGS84")
"%!in%" <- function(x, y) !("%in%"(x, y))

# Get functional trait data from Trugman et al. (2020) PNAS
p50a <- open.nc(paste(dir, "CWM_P50_025Deg.nc", sep = ""))
p50m <- var.get.nc(p50a, "CWM_P50")
dim(p50m)
p50r <- var.get.nc(p50a, "mean_range_within_site")
dim(p50r)
lat.tr <- var.get.nc(p50a, "lat")
dim(lat.tr)
lon.tr <- var.get.nc(p50a, "lon")
dim(lon.tr)

# Screen FIA data to remove fire, human disturbance, timber cutting, CONDPROP>0.3
fianew1 <- fianew[which(fianew[, 8] >= 0.3 & fianew[, 59] != "True" & fianew[, 63] != "True" & fianew[, 71] != "True" & fianew[, 18] > 1), ]

# Extract trait data for all FIA CONDs
traitdata <- array(dim = c(102453, 2))
for (i in 1:102453) {
  lati <- fianew1[i, 1]
  loni <- fianew1[i, 2]
  latcell <- which.min(abs(lati - lat.tr))
  loncell <- which.min(abs(loni - lon.tr))
  traitdata[i, 1] <- p50m[latcell, loncell]
  traitdata[i, 2] <- p50r[latcell, loncell]
}

traitlong <- array(dim = c(498410, 2))
for (i in 1:498410) {
  lati <- fialonga[i, 1]
  loni <- fialonga[i, 2]
  latcell <- which.min(abs(lati - lat.tr))
  loncell <- which.min(abs(loni - lon.tr))
  traitlong[i, 1] <- p50m[latcell, loncell]
  traitlong[i, 2] <- p50r[latcell, loncell]
}

#------------------------------------------- Processing FIA data --------------------------------------------
# For Obs, build a clean data-frame with dependent variable, predictor variables, FORTYP, lat/lon
fianew1[is.na(fianew1[, 23]) == "TRUE", 23] <- 0 # Impute 0s where no mort was measured
fianew1[is.na(fianew1[, 27]) == "TRUE", 27] <- 0 # Impute 0s where no mort was measured for insect mort
fianew1[which(fianew1[, 151] < -16), 151] <- -16 # Set lower PDSI bounds
fianew1[which(fianew1[, 151] > 16), 151] <- 16 # Set upper PDSI bounds
fianew1[which(fianew1[, 152] < -16), 152] <- -16 # Set lower PDSI bounds
fianew1[which(fianew1[, 152] > 16), 152] <- 16 # Set upper PDSI bounds
fianew1[which(fianew1[, 153] < -16), 153] <- -16 # Set lower PDSI bounds
fianew1[which(fianew1[, 153] > 16), 153] <- 16 # Set upper PDSI bounds

# Combine all cond data and variables into a dataframe with columns: MortDrt, MortIns, 18 clim vars, 2 age vars, 8 traits, lat,lon, FORTYP
fia.newm <- as.data.frame(cbind(
  (fianew1[, 23] / fianew1[, 18]) / (fianew1[, 15] - fianew1[, 14]), fianew1[, 27] * (fianew1[, 23] / fianew1[, 18]) / (fianew1[, 15] - fianew1[, 14]),
  scale(fianew1[, 127]), scale(fianew1[, 128]), scale(fianew1[, 129]), scale(fianew1[, 139]), scale(fianew1[, 140]), scale(fianew1[, 141]),
  scale(fianew1[, 151]), scale(fianew1[, 152]), scale(fianew1[, 153]), scale(fianew1[, 163]), scale(fianew1[, 164]), scale(fianew1[, 165]),
  scale(fianew1[, 175]), scale(fianew1[, 176]), scale(fianew1[, 177]), scale(fianew1[, 187]), scale(fianew1[, 188]), scale(fianew1[, 189]),
  scale(fianew1[, 3]^2), scale(fianew1[, 3]),
  scale(traitdata[, 1]), scale(traitdata[, 2]),
  (fianew1[, 19] - fianew1[, 18]), (fianew1[, 15] - fianew1[, 14]),
  fianew1[, 1], fianew1[, 2], fianew1[, 4], fianew1[, 18]
))

# Second, screen out NaN values that will mess up the model
fia2 <- fia.newm[which(fia.newm[, 1] != "NaN" & fia.newm[, 5] != "NaN" & fia.newm[, 3] != "NaN" & fia.newm[, 9] != "NaN" & fia.newm[, 29] != "NaN" & fia.newm[, 21] != "NaN" & fia.newm[, 23] != "NaN" & fia.newm[, 1] < 1.01 & is.na(fia.newm[, 2]) == "FALSE"), ]

# Third, scale up to 0.25x0.25 degree for model fitting
dummy <- raster(ncols = 244, nrows = 100, xmn = -126, xmx = -65, ymn = 25, ymx = 50, crs = proj2) # 0.25 degree dummy raster
fia.g1 <- array(dim = c(0, 30))
for (i in 1:112) {
  ftype <- unique(fia2[, 29])[i]
  d1 <- data.frame(fia2[which(fia2[, 29] == ftype), ])
  v1 <- rasterize(d1[, c(28, 27)], dummy, d1[, 1], fun = mean, background = NA, mask = FALSE, na.rm = T)
  v1i <- rasterize(d1[, c(28, 27)], dummy, d1[, 2], fun = mean, background = NA, mask = FALSE, na.rm = T)
  v1b <- rasterToPoints(v1)
  v1bi <- (as.matrix(as.vector(v1i)))[is.na(as.matrix(as.vector(v1i))) == "FALSE"]
  stack <- array(dim = c(length(v1bi), 0))
  for (j in 1:24) {
    varh <- rasterize(d1[, c(28, 27)], dummy, d1[, (j + 2)], fun = mean, background = NA, mask = FALSE, na.rm = T)
    var1 <- (as.matrix(as.vector(varh)))[is.na(as.matrix(as.vector(varh))) == "FALSE"]
    stack <- cbind(stack, var1)
  }
  ba <- rasterize(d1[, c(28, 27)], dummy, d1[, 30], fun = sum, background = NA, mask = FALSE, na.rm = T)
  ba0 <- (as.matrix(as.vector(ba)))[is.na(as.matrix(as.vector(ba))) == "FALSE"]
  fia.out <- cbind(v1b[, 3], v1bi, stack, v1b[, 1:2], rep(ftype, length(v1bi)), ba0)
  fia.g1 <- rbind(fia.g1, fia.out)
}

#------------------------------------------- Fit mortality functions --------------------------------------------------
# GLM control parameters - bump up maxit to help with convergence
gm.ctl <- glm.control(epsilon = 1e-8, maxit = 500, trace = FALSE)

mod_insect_proj <- function(fitdata, minthres, ftypcol, preddata) {
  colnames(preddata) <- c("V1", "V2", "V3", "V4", "V5", "V6", "V7", "V8", "V9", "V10", "V11", "V12", "V13")
  colnames(fitdata) <- c("V1", "V2", "V3", "V4", "V5", "V6", "V7", "V8", "V9", "V10")
  mod1 <- array(dim = c(0, 7))
  for (i in 1:112) {
    ftype <- unique(fitdata[, ftypcol])[i]
    non_zero <- ifelse(fitdata[which(fitdata[, ftypcol] == ftype), 1] > 0, 1, 0)
    d1 <- data.frame(fitdata[which(fitdata[, ftypcol] == ftype), ], non_zero) # Historical mortality data
    preddata1 <- data.frame(preddata[which(preddata[, 10] == ftype), ]) # Projection data
    # Set up the output matrix
    drt.out <- array(dim = c(dim(preddata1)[1], 7))
    drt.out[, 1] <- ftype # FORTYPCD
    drt.out[, 2] <- preddata1[, 12] # lat
    drt.out[, 3] <- preddata1[, 11] # lon
    drt.out[, 7] <- preddata1[, 13] # BAlive0 for the FORTYP

    # If FORTYP has non-meaningful historical model, set future projections == mean historical
    if (ftype %!in% FTpred_ins[, 1]) drt.out[, 6] <- mean(d1[, 1], na.rm = T) # Predicted mort = mean historical where Nmort<minthres
    if (ftype %!in% FTpred_ins[, 1]) mod1 <- rbind(mod1, drt.out)
    if (ftype %!in% FTpred_ins[, 1]) print(paste("FORTYP prediction skipped due inadequate historical model: ", ftype, sep = ""))
    if (ftype %!in% FTpred_ins[, 1]) next

    # If FORTYP has Nmort<minthres, set future projections == mean historical
    if (sum(d1[, 11], na.rm = T) < minthres) drt.out[, 6] <- mean(d1[, 1], na.rm = T) # Pred mort = mean hist where Nmort<minthres
    if (sum(d1[, 11], na.rm = T) < minthres) mod1 <- rbind(mod1, drt.out)
    if (sum(d1[, 11], na.rm = T) < minthres) print(paste("FORTYP prediction skipped due Nmort<minthres: ", ftype, sep = ""))
    if (sum(d1[, 11], na.rm = T) < minthres) next

    # For FORTYPs with adequate historical models
    if (sum(non_zero, na.rm = T) > 0) d1 <- d1[which(d1[, 1] < quantile(d1[, 1], 0.995)), ]
    if (dim(d1)[1] == 0) d1 <- data.frame(fitdata[which(fitdata[, ftypcol] == ftype), ], non_zero)

    # Construct historical mortality model
    m1 <- glm(non_zero ~ V2 + V3 + V4 + V5 + V6 + V7 + V8, data = d1, family = binomial(link = logit), control = gm.ctl)
    m2 <- betareg(V1 ~ V2 + V3 + V4 + V5 + V6 + V7 + V8, data = subset(d1, non_zero == 1))

    # Predict with future climate projections
    pred1 <- predict(m1, newdata = preddata1[, 2:8], se = TRUE, type = "response")
    pred2 <- predict(m2, newdata = preddata1[, 2:8], se = TRUE, type = "response")
    pred1a <- ifelse(pred1$fit >= 0.5, 1, 0)
    pred3 <- pred2 * pred1a
    pred4 <- pred2 * pred1$fit
    # 		Store model output
    drt.out[, 5] <- pred3
    drt.out[, 6] <- pred4 # Predicted (expected value) mort frac
    mod1 <- rbind(mod1, drt.out)
  }
  print(paste("FORTYPs projected: ", length(unique(mod1[which(mod1[, 5] != "NA"), 1])), sep = ""))
  print(paste("FORTYPs completed: ", i, sep = ""))
  return(mod1)
}

insect_histmodel <- function(fitdata, minthres, ftypcol) {
  colnames(fitdata) <- c("V1", "V2", "V3", "V4", "V5", "V6", "V7", "V8", "V9", "V10", "V11", "V12", "V13")
  mod1 <- array(dim = c(0, 7))
  for (i in 1:112) {
    ftype <- unique(fitdata[, ftypcol])[i]
    non_zero <- ifelse(fitdata[which(fitdata[, ftypcol] == ftype), 1] > 0, 1, 0)
    d1 <- data.frame(fitdata[which(fitdata[, ftypcol] == ftype), ], non_zero)

    drt.out <- array(dim = c(dim(d1)[1], 7))
    drt.out[, 1] <- d1[, ftypcol] # FORTYPCD
    drt.out[, 2] <- d1[, 12] # lat
    drt.out[, 3] <- d1[, 11] # lon
    drt.out[, 4] <- d1[, 1] # Obs mort frac
    drt.out[, 7] <- d1[, 13] # BAlive0 for the FORTYP

    # If FORTYP has non-meaningful historical model, set future projections == mean historical
    if (ftype %!in% FTpred_ins[, 1]) drt.out[, 6] <- mean(d1[, 1], na.rm = T) # Predicted mort = mean historical where Nmort<minthres
    if (ftype %!in% FTpred_ins[, 1]) mod1 <- rbind(mod1, drt.out)
    if (ftype %!in% FTpred_ins[, 1]) print(paste("FORTYP prediction skipped due inadequate historical model: ", ftype, sep = ""))
    if (ftype %!in% FTpred_ins[, 1]) next

    # If FORTYP has Nmort<minthres, set future projections == mean historical
    if (sum(d1[, 14], na.rm = T) < minthres) drt.out[, 6] <- mean(d1[, 1], na.rm = T) # Predicted mort = mean historical where Nmort<minthres
    if (sum(d1[, 14], na.rm = T) < minthres) mod1 <- rbind(mod1, drt.out)
    if (sum(d1[, 14], na.rm = T) < minthres) print(paste("FORTYP prediction skipped due Nmort<minthres: ", ftype, sep = ""))
    if (sum(d1[, 14], na.rm = T) < minthres) next

    # For FORTYPs with adequate historical models, remove outliers
    if (sum(non_zero, na.rm = T) > 0) d1 <- d1[which(d1[, 1] < quantile(d1[, 1], 0.995)), ]
    if (dim(d1)[1] == 0) d1 <- data.frame(fitdata[which(fitdata[, ftypcol] == ftype), ], non_zero)

    m1 <- glm(non_zero ~ V2 + V3 + V4 + V5 + V6 + V7 + V8, data = d1, family = binomial(link = logit), control = gm.ctl)
    m2 <- betareg(V1 ~ V2 + V3 + V4 + V5 + V6 + V7 + V8, data = subset(d1, non_zero == 1))

    pred1 <- predict(m1, newdata = d1[, 2:8], se = TRUE, type = "response")
    pred2 <- predict(m2, newdata = d1[, 2:8], se = TRUE, type = "response")
    pred1a <- ifelse(pred1$fit >= 0.5, 1, 0)
    pred3 <- pred1$fit
    pred4 <- pred2 * pred1$fit

    if (dim(drt.out)[1] != dim(d1)[1]) drt.out <- array(dim = c(dim(d1)[1], 7))
    drt.out[, 1] <- d1[, ftypcol] # FORTYPCD
    drt.out[, 2] <- d1[, 12] # lat
    drt.out[, 3] <- d1[, 11] # lon
    drt.out[, 4] <- d1[, 1] # Obs mort frac
    drt.out[, 7] <- d1[, 13] # BAlive0 for the FORTYP

    drt.out[, 5] <- pred3
    drt.out[, 6] <- pred4 # Predicted (expected value) mort frac
    mod1 <- rbind(mod1, drt.out)
  }
  print(paste("FORTYPs modeled: ", length(unique(mod1[which(mod1[, 5] != "NA"), 1])), sep = ""))
  print(paste("FORTYPs completed: ", i, sep = ""))
  return(mod1)
}

#----------------- FIAlong climate data preprocessing function
prepclim <- function(histclim, climdata, histcols, futcols) {
  climdata[which(climdata[, 6] < -16), 6] <- -16 # Set lower PDSI bounds
  climdata[which(climdata[, 6] > 16), 6] <- 16 # Set upper PDSI bounds
  climdata[which(climdata[, 13] < -16), 13] <- -16 # Set lower PDSI bounds
  climdata[which(climdata[, 13] > 16), 13] <- 16 # Set upper PDSI bounds
  histclim[which(histclim[, 25] < -16), 25] <- -16
  histclim[which(histclim[, 25] > 16), 25] <- 16
  histclim[which(histclim[, 26] < -16), 26] <- -16
  histclim[which(histclim[, 26] > 16), 26] <- 16
  print(histclim[1, histcols])
  print(climdata[1, futcols])
  # Get historical mean and SD for drought models
  hist1 <- array(dim = c(6, 2))
  for (i in 1:6) {
    hist1[i, 1] <- mean(histclim[, histcols[i]], na.rm = T)
    hist1[i, 2] <- sd(histclim[, histcols[i]], na.rm = T)
  }
  fia.futa <- as.data.frame(cbind(rep(1, 498410), (climdata[, futcols[1]] - hist1[1, 1]) / hist1[1, 2], (climdata[, futcols[2]] - hist1[2, 1]) / hist1[2, 2], (climdata[, futcols[3]] - hist1[3, 1]) / hist1[3, 2], (climdata[, futcols[4]] - hist1[4, 1]) / hist1[4, 2], (climdata[, futcols[5]] - hist1[5, 1]) / hist1[5, 2], (climdata[, futcols[6]] - hist1[6, 1]) / hist1[6, 2], scale(fialong[, 3]), scale(traitlong[, 2]), fialong[, 7], fialong[, 1], fialong[, 2], fialong[, 4]))
  finalclim <- fia.futa[which(fia.futa[, 1] != "NaN" & fia.futa[, 5] != "NaN" & fia.futa[, 3] != "NaN" & fia.futa[, 7] != "NaN" & fia.futa[, 10] != "NaN" & fia.futa[, 8] != "NaN" & is.na(fia.futa[, 2]) == "FALSE"), ]
  return(finalclim)
}

# Function when both inputs are FIAlong
prepclim1 <- function(histclim, climdata, histcols, futcols) {
  climdata[which(climdata[, 25] < -16), 25] <- -16 # Set lower PDSI bounds
  climdata[which(climdata[, 25] > 16), 25] <- 16 # Set upper PDSI bounds
  climdata[which(climdata[, 26] < -16), 26] <- -16 # Set lower PDSI bounds
  climdata[which(climdata[, 26] > 16), 26] <- 16 # Set upper PDSI bounds
  histclim[which(histclim[, 25] < -16), 25] <- -16
  histclim[which(histclim[, 25] > 16), 25] <- 16
  histclim[which(histclim[, 26] < -16), 26] <- -16
  histclim[which(histclim[, 26] > 16), 26] <- 16
  print(histclim[1, histcols])
  print(climdata[1, futcols])
  # Get historical mean and SD for drought models
  hist1 <- array(dim = c(6, 2))
  for (i in 1:6) {
    hist1[i, 1] <- mean(histclim[, histcols[i]], na.rm = T)
    hist1[i, 2] <- sd(histclim[, histcols[i]], na.rm = T)
  }
  fia.futa <- as.data.frame(cbind(rep(1, 498410), (climdata[, futcols[1]] - hist1[1, 1]) / hist1[1, 2], (climdata[, futcols[2]] - hist1[2, 1]) / hist1[2, 2], (climdata[, futcols[3]] - hist1[3, 1]) / hist1[3, 2], (climdata[, futcols[4]] - hist1[4, 1]) / hist1[4, 2], (climdata[, futcols[5]] - hist1[5, 1]) / hist1[5, 2], (climdata[, futcols[6]] - hist1[6, 1]) / hist1[6, 2], scale(fialonga[, 3]), scale(traitlong[, 2]), fialonga[, 7], fialonga[, 1], fialonga[, 2], fialonga[, 4]))
  finalclim <- fia.futa[which(fia.futa[, 1] != "NaN" & fia.futa[, 5] != "NaN" & fia.futa[, 3] != "NaN" & fia.futa[, 7] != "NaN" & fia.futa[, 10] != "NaN" & fia.futa[, 8] != "NaN" & is.na(fia.futa[, 2]) == "FALSE"), ]
  return(finalclim)
}

#-------------------- Function to rasterize and weight model mortality projections by observed/current BA
weight.proj1 <- function(raster1, grid, mortcol) {
  mort.bafi <- rasterize(raster1[which(raster1[, 1] == unique(raster1[, 1])[1]), c(2, 3)], grid, raster1[which(raster1[, 1] == unique(raster1[, 1])[1]), 7], fun = mean, background = NA, mask = FALSE, na.rm = TRUE)
  mort.predfi <- rasterize(raster1[which(raster1[, 1] == unique(raster1[, 1])[1]), c(2, 3)], grid, raster1[which(raster1[, 1] == unique(raster1[, 1])[1]), mortcol], fun = mean, background = NA, mask = FALSE, na.rm = TRUE)
  for (i in 2:length(unique(raster1[, 1]))) {
    mort.predfi <- addLayer(mort.predfi, rasterize(raster1[which(raster1[, 1] == unique(raster1[, 1])[i]), c(2, 3)], grid, raster1[which(raster1[, 1] == unique(raster1[, 1])[i]), mortcol], fun = mean, background = NA, mask = FALSE, na.rm = TRUE))
    mort.bafi <- addLayer(mort.bafi, rasterize(raster1[which(raster1[, 1] == unique(raster1[, 1])[i]), c(2, 3)], grid, raster1[which(raster1[, 1] == unique(raster1[, 1])[i]), 7], fun = mean, background = NA, mask = FALSE, na.rm = TRUE))
  }
  mort.predwi <- weighted.mean(mort.predfi, mort.bafi, na.rm = T)
  return(mort.predwi)
}

#-------------------------------- Run model and create figures
# Fig 1E
insect.hist <- insect_histmodel(fia.g1[, c(2, 5, 6, 11, 13, 15, 20, 22, 24, 29, 28, 27, 30)], 20, 10)

# Scale up by basal area
insect.obs <- weight.proj1(insect.hist, dummy, 4)

# writeRaster(insect.obs, paste(dir, "Fig1E_InsectModel_FIAwide-ObsMort_05-08-2021", sep=""),  format='GTiff')

# Fig 1F models
histcols6 <- c(19, 23, 25, 30, 32, 34)
insect.outa <- mod_insect_proj(fia.g1[, c(2, 5, 6, 11, 13, 15, 20, 22, 24, 29)], 20, 10, prepclim1(fialonga, fialonga, histcols6, histcols6))
insect.outb <- mod_insect_proj(fia.g1[, c(2, 5, 6, 11, 13, 15, 20, 22, 24, 29)], 20, 10, prepclim1(fialongb, fialongb, histcols6, histcols6))
insect.outc <- mod_insect_proj(fia.g1[, c(2, 5, 6, 11, 13, 15, 20, 22, 24, 29)], 20, 10, prepclim1(fialongc, fialongc, histcols6, histcols6))

# Make Fig 1F
insect1 <- insect.outa
insect1[, 6] <- rowMeans(cbind(insect.outa[, 6], insect.outb[, 6], insect.outc[, 6])) # Average modeled mortality across 3 baselines
mort.insects.modlong1 <- weight.proj1(insect1, dummy, 6)

# writeRaster(mort.insects.modlong1, paste(dir, "Fig1F_InsectModel_ModeledFIAlongEnsembleHistMort_05-08-2021", sep=""),  format='GTiff')

#-------------------------------------------- DROUGHT MODELS (Fig 1C/D)
mod_drought_proj <- function(fitdata, minthres, ftypcol, preddata) {
  colnames(preddata) <- c("V1", "V2", "V3", "V4", "V5", "V6", "V7", "V8", "V9", "V10", "V11", "V12", "V13")
  colnames(fitdata) <- c("V1", "V2", "V3", "V4", "V5", "V6", "V7", "V8", "V9", "V10")
  mod1 <- array(dim = c(0, 7))
  for (i in 1:112) {
    ftype <- unique(fitdata[, ftypcol])[i]
    non_zero <- ifelse(fitdata[which(fitdata[, ftypcol] == ftype), 1] > 0, 1, 0)
    d1 <- data.frame(fitdata[which(fitdata[, ftypcol] == ftype), ], non_zero) # Historical mortality data
    preddata1 <- data.frame(preddata[which(preddata[, 10] == ftype), ]) # Projection data

    # Set up the output matrix
    drt.out <- array(dim = c(dim(preddata1)[1], 7))
    drt.out[, 1] <- ftype # FORTYPCD
    drt.out[, 2] <- preddata1[, 12] # lat
    drt.out[, 3] <- preddata1[, 11] # lon
    drt.out[, 7] <- preddata1[, 13] # Biomass for the FORTYP

    # If FORTYP has non-meaningful historical model, set future projections == mean historical
    if (ftype %!in% FTpred_drt[, 1]) drt.out[, 6] <- mean(d1[, 1], na.rm = T) # Predicted mort = mean historical where Nmort<minthres
    if (ftype %!in% FTpred_drt[, 1]) mod1 <- rbind(mod1, drt.out)
    if (ftype %!in% FTpred_drt[, 1]) print(paste("FORTYP prediction skipped due inadequate historical model: ", ftype, sep = ""))
    if (ftype %!in% FTpred_drt[, 1]) next

    # If FORTYP has Nmort<minthres, set future projections == mean historical
    if (sum(d1[, 11], na.rm = T) < minthres) drt.out[, 6] <- mean(d1[, 1], na.rm = T) # Pred mort = mean hist where Nmort<minthres
    if (sum(d1[, 11], na.rm = T) < minthres) mod1 <- rbind(mod1, drt.out)
    if (sum(d1[, 11], na.rm = T) < minthres) print(paste("FORTYP prediction skipped due Nmort<minthres: ", ftype, sep = ""))
    if (sum(d1[, 11], na.rm = T) < minthres) next

    # For FORTYPs with adequate historical models, outlier screen
    if (sum(non_zero, na.rm = T) > 0) d1 <- d1[which(d1[, 1] < quantile(d1[, 1], 0.995)), ]
    if (dim(d1)[1] == 0) d1 <- data.frame(fitdata[which(fitdata[, ftypcol] == ftype), ], non_zero)

    # Construct historical mortality model
    m1 <- glm(non_zero ~ V2 + V3 + V4 + V5 + V6 + V7 + V8 + V9, data = d1, family = binomial(link = logit), control = gm.ctl)
    m2 <- betareg(V1 ~ V2 + V3 + V4 + V5 + V6 + V7 + V8 + V9, data = subset(d1, non_zero == 1))

    # Predict with future climate projections
    pred1 <- predict(m1, newdata = preddata1[, 2:9], se = TRUE, type = "response")
    pred2 <- predict(m2, newdata = preddata1[, 2:9], se = TRUE, type = "response")
    pred1a <- ifelse(pred1$fit >= 0.5, 1, 0)
    pred3 <- pred2 * pred1a
    pred4 <- pred2 * pred1$fit

    # 		Store model output
    drt.out[, 5] <- pred3
    drt.out[, 6] <- pred4 # Predicted (expected value) mort frac
    mod1 <- rbind(mod1, drt.out)
  }
  print(paste("FORTYPs projected: ", length(unique(mod1[which(mod1[, 5] != "NA"), 1])), sep = ""))
  print(paste("FORTYPs completed: ", i, sep = ""))
  return(mod1)
}

drought_histmodel <- function(fitdata, minthres, ftypcol) {
  colnames(fitdata) <- c("V1", "V2", "V3", "V4", "V5", "V6", "V7", "V8", "V9", "V10", "V11", "V12", "V13")
  mod1 <- array(dim = c(0, 7))
  for (i in 1:112) {
    ftype <- unique(fitdata[, ftypcol])[i]
    non_zero <- ifelse(fitdata[which(fitdata[, ftypcol] == ftype), 1] > 0, 1, 0)
    d1 <- data.frame(fitdata[which(fitdata[, ftypcol] == ftype), ], non_zero)

    drt.out <- array(dim = c(dim(d1)[1], 7))
    drt.out[, 1] <- d1[, ftypcol] # FORTYPCD
    drt.out[, 2] <- d1[, 12] # lat
    drt.out[, 3] <- d1[, 11] # lon
    drt.out[, 4] <- d1[, 1] # Obs mort frac
    drt.out[, 7] <- d1[, 13] # BAlive0 for the FORTYP

    # If FORTYP has non-meaningful historical model, set modeled values == mean historical
    if (ftype %!in% FTpred_drt[, 1]) drt.out[, 6] <- mean(d1[, 1], na.rm = T) # Predicted mort = mean historical where Nmort<minthres
    if (ftype %!in% FTpred_drt[, 1]) mod1 <- rbind(mod1, drt.out)
    if (ftype %!in% FTpred_drt[, 1]) print(paste("FORTYP prediction skipped due inadequate historical model: ", ftype, sep = ""))
    if (ftype %!in% FTpred_drt[, 1]) next

    # If FORTYP has Nmort<minthres, set modeled values == mean historical
    if (sum(d1[, 14], na.rm = T) < minthres) drt.out[, 6] <- mean(d1[, 1], na.rm = T) # Predicted mort = mean historical where Nmort<minthres
    if (sum(d1[, 14], na.rm = T) < minthres) mod1 <- rbind(mod1, drt.out)
    if (sum(d1[, 14], na.rm = T) < minthres) print(paste("FORTYP prediction skipped due Nmort<minthres: ", ftype, sep = ""))
    if (sum(d1[, 14], na.rm = T) < minthres) next

    # For FORTYPs with adequate historical models, remove outliers
    if (sum(non_zero, na.rm = T) > 0) d1 <- d1[which(d1[, 1] < quantile(d1[, 1], 0.995)), ]
    if (dim(d1)[1] == 0) d1 <- data.frame(fitdata[which(fitdata[, ftypcol] == ftype), ], non_zero)

    # Build models
    m1 <- glm(non_zero ~ V2 + V3 + V4 + V5 + V6 + V7 + V8 + V9, data = d1, family = binomial(link = logit), control = gm.ctl)
    m2 <- betareg(V1 ~ V2 + V3 + V4 + V5 + V6 + V7 + V8 + V9, data = subset(d1, non_zero == 1))

    pred1 <- predict(m1, newdata = d1[, 2:9], se = TRUE, type = "response")
    pred2 <- predict(m2, newdata = d1[, 2:9], se = TRUE, type = "response")
    pred1a <- ifelse(pred1$fit >= 0.5, 1, 0)
    pred3 <- pred1$fit
    pred4 <- pred2 * pred1$fit

    if (dim(drt.out)[1] != dim(d1)[1]) drt.out <- array(dim = c(dim(d1)[1], 7))
    drt.out[, 1] <- d1[, ftypcol] # FORTYPCD
    drt.out[, 2] <- d1[, 12] # lat
    drt.out[, 3] <- d1[, 11] # lon
    drt.out[, 4] <- d1[, 1] # Obs mort frac
    drt.out[, 7] <- d1[, 13] # BAlive0 for the FORTYP

    drt.out[, 5] <- pred3
    drt.out[, 6] <- pred4 # Predicted (expected value) mort frac
    mod1 <- rbind(mod1, drt.out)
  }
  print(paste("FORTYPs modeled: ", length(unique(mod1[which(mod1[, 5] != "NA"), 1])), sep = ""))
  print(paste("FORTYPs completed: ", i, sep = ""))
  return(mod1)
}

#-------------------------------- Run model and create figures
# Fig 1C
drought.hist <- drought_histmodel(fia.g1[, c(1, 5, 7, 11, 13, 17, 18, 22, 24, 29, 28, 27, 30)], 20, 10)

# Scale up by basal area
drought.obs <- weight.proj1(drought.hist, dummy, 4)

# writeRaster(drought.obs, paste(dir, "Fig1C_DroughtModel_FIAwide-ObsMort_05-08-2021", sep=""),  format='GTiff')

# Fig 1D
histcols1a <- c(19, 24, 25, 30, 31, 35)
drought.outa <- mod_drought_proj(fia.g1[, c(1, 5, 7, 11, 13, 17, 18, 22, 24, 29)], 20, 10, prepclim1(fialonga, fialonga, histcols1a, histcols1a))
drought.outb <- mod_drought_proj(fia.g1[, c(1, 5, 7, 11, 13, 17, 18, 22, 24, 29)], 20, 10, prepclim1(fialongb, fialongb, histcols1a, histcols1a))
drought.outc <- mod_drought_proj(fia.g1[, c(1, 5, 7, 11, 13, 17, 18, 22, 24, 29)], 20, 10, prepclim1(fialongc, fialongc, histcols1a, histcols1a))

# Make Fig 1D
drought1 <- drought.outa
drought1[, 6] <- rowMeans(cbind(drought.outa[, 6], drought.outb[, 6], drought.outc[, 6])) # Average modeled mortality across 3 baselines
mort.drought.modlong1 <- weight.proj1(drought1, dummy, 6)

# writeRaster(mort.drought.modlong1, paste(dir, "Fig1D_DroughtModel_ModeledFIAlongEnsembleHistMort_05-08-2021", sep=""),  format='GTiff')

#-------------------------------------- First-order reversal estimates
# Historical reversals for drought and insects in FIA data
drt.rev <- rep(0, 102453)
drt.rev[which(fianew1[, 27] < 0.01 & fianew1[, 19] < fianew1[, 18] & fianew1[, 31] < 0.01 & fianew1[, 35] < 0.01 & fianew1[, 39] < 0.01 & fianew1[, 47] < 0.01 & fianew1[, 55] == "False" & fianew1[, 59] == "False" & fianew1[, 63] == "False" & fianew1[, 71] == "False" & fianew1[, 75] == "False" & fianew1[, 79] == "False" & fianew1[, 83] == "False" & fianew1[, 151] < -2 & fianew1[, 67] == "False" & ((fianew1[, 19] - fianew1[, 18]) / -fianew1[, 18]) > 0.1)] <- 1

ins.rev <- rep(0, 102453)
ins.rev[which(fianew1[, 27] > 0.5 & fianew1[, 19] < fianew1[, 18] & ((fianew1[, 19] - fianew1[, 18]) / -fianew1[, 18]) > 0.1)] <- 1

# Calculated annualized drought and insect p(rev)
revhist1 <- array(dim = c(102453, 2))
for (i in 1:102453) {
  ftrev <- fianew1[i, 4]
  revhist1[i, 1] <- drt.rev[i] / mean(fianew1[which(fianew1[, 4] == ftrev), 15] - fianew1[which(fianew1[, 4] == ftrev), 14], na.rm = T)
  revhist1[i, 2] <- ins.rev[i] / mean(fianew1[which(fianew1[, 4] == ftrev), 15] - fianew1[which(fianew1[, 4] == ftrev), 14], na.rm = T)
}

# Calculate 100-year integrated risk %s of constant historical reversal annual probabilities
100 * dbinom(1, 100, mean(revhist1[, 1], na.rm = T)) # Drought
100 * dbinom(1, 100, mean(revhist1[, 2], na.rm = T)) # Insects

# Simulate 100-year integrated risk %s with Fig 2 multi-model mean CMIP6 projections
out <- array(dim = c(1000, 0))
perc1 <- c(1, 1.022, 1.063, 1.148, 1.151, 1.230, 1.380, 1.384, 1.799, 1.846) # Percent changes in BAmortfrac/yr from drought models compared to 1990-2010 baselines
for (i in 1:10) {
  dec1 <- rbinom(1000, 10, 0.002457 * perc1[i]) # Draw 1000 10-year draws with observed probability
  out <- cbind(out, dec1)
  sumout <- rowSums(out)
  sumout1 <- sum(ifelse(sumout > 0, 1, 0))
}
100 * sumout1 / 1000

# Insects
out <- array(dim = c(1000, 0))
perc2 <- c(1, 1.049, 1.042, 1.193, 1.0231, 1.136, 1.289, 1.197, 1.622, 1.701) # Percent changes in BAmortfrac/yr from insect models compared to 1990-2010 baselines
for (i in 1:10) {
  dec1 <- rbinom(1000, 10, 0.00250982 * perc2[i]) # Draw 1000 10-year draws with observed probability
  out <- cbind(out, dec1)
  sumout <- rowSums(out)
  sumout1 <- sum(ifelse(sumout > 0, 1, 0))
}
100 * sumout1 / 1000

# Fire
out <- array(dim = c(1000, 0))
hist1 <- read.csv(paste(dir, "historical_fire.csv", sep = ""), header = T)
histave <- mean(hist1[17:35, 2])
fut1 <- read.csv(paste(dir, "future_fire.csv", sep = ""), header = T)
perc3 <- c(rep(1, 19), (fut1[50:130, 3] - histave) / histave + 1)
for (i in 1:100) {
  dec1 <- rbinom(1000, 1, histave * perc3[i]) # Draw 1000 1-year draws with observed probability
  out <- cbind(out, dec1)
  sumout <- rowSums(out)
  sumout1 <- sum(ifelse(sumout > 0, 1, 0))
}
100 * sumout1 / 1000