#' Surrogate profiles
#'
#' Fill in a data matrix rank, when your data is low n, high p. Fill in rank with surrogate profiles.
#' @param data - Data matrix with observations as rows, features as columns.
#' @param std - The level of variability (standard deviation) around each feature's
#'             mean you want to add in surrogate profiles.
#' @param useMnDiseaseProfile - Boolean. For disease cohorts not showing homogeneity, mean
#'             across disease profiles and generate disease surrogates around this mean.
#' @param addHealthyControls - Boolean. Add healthy control profiles to data?
#' @return data_mx - Data matrix with added surrogate profiles.
#' @export data.surrogateProfiles
data.surrogateProfiles = function(data, std=1, useMnDiseaseProfile=FALSE, addHealthyControls=TRUE, ref_data=NULL) {
  if (!is.null(ref_data)) {
    ref_data = ref_data[which(rownames(ref_data) %in% rownames(data)),]
    data = data[which(rownames(data) %in% rownames(ref_data)), ]
  } else {
    if (addHealthyControls) {
      print("Changing addHealthyControls to FALSE because no reference data was provided.")
      addHealthyControls = FALSE
    }
  }

  # Generate disease surrogates first
  if (useMnDiseaseProfile==TRUE) {
    mn_data = apply(data, 1, function(i) mean(na.omit(i)))
    names(mn_data) = rownames(data)
    data = as.matrix(mn_data)
    colnames(data) = "mn_data"
    # Generate disease surrogates
    if (addHealthyControls) {
      rpt = ceiling(nrow(data)/ncol(data)/2)
    } else {
      rpt = ceiling(nrow(data)/ncol(data))
    }
    data_surr = matrix(NA, nrow=nrow(data), ncol=ncol(data)+ncol(data)*rpt)
    c_col = ncol(data)+1
    for (pt in 1:ncol(data)) {
      data_surr[,pt] = data[,pt]
      for (rrpt in 1:rpt) {
        rr = rnorm(nrow(data), mean=0, sd=std)
        data_surr[,c_col] = as.numeric(data[,pt])+rr
        c_col = c_col+1
      }
    }
    colnames(data_surr) = c(colnames(data), sprintf("disease_surr%d", 1:(ncol(data_surr)-ncol(data))))
    rownames(data_surr) = rownames(data)
    dim(data_surr)
  } else {
    # Generate disease surrogates for each "flavor" of disease profiles.
    if (addHealthyControls) {
      rpt = ceiling(nrow(data)/ncol(data)/2)
    } else {
      rpt = ceiling(nrow(data)/ncol(data))
    }
    data_surr = matrix(NA, nrow=nrow(data), ncol=ncol(data)+ncol(data)*rpt)
    c_col = ncol(data)+1
    for (pt in 1:ncol(data)) {
      data_surr[,pt] = data[,pt]
      for (rrpt in 1:rpt) {
        rr = rnorm(nrow(data), mean=0, sd=std)
        data_surr[,c_col] = as.numeric(data[,pt])+rr
        c_col = c_col+1
      }
    }
    colnames(data_surr) = c(colnames(data), sprintf("disease_surr%d", 1:(ncol(data_surr)-ncol(data))))
    rownames(data_surr) = rownames(data)
    dim(data_surr)
  }

  # Next, if addHealthyControls is TRUE, generate reference profile surrogates.
  if (addHealthyControls) {
    numSurr = ceiling(nrow(data)/2)
    if (numSurr > ncol(ref_data)) {
      # Generate control surrogates from real control samples.
      rpt = ceiling(nrow(data)/ncol(ref_data)/2)
      control_surr = matrix(NA, nrow=nrow(ref_data), ncol=ncol(ref_data)+ncol(ref_data)*rpt)
      c_col = ncol(ref_data)+1
      for (pt in 1:ncol(ref_data)) {
        control_surr[,pt] = ref_data[,pt]
        for (rrpt in 1:rpt) {
          rr = rnorm(nrow(ref_data), mean=0, sd=std)
          control_surr[,c_col] = as.numeric(ref_data[,pt])+rr
          c_col = c_col+1
        }
      }
      colnames(control_surr) = c(colnames(ref_data), sprintf("control_surr%d", 1:(ncol(control_surr)-ncol(ref_data))))
      rownames(control_surr) = rownames(ref_data)
      dim(control_surr)
    } else {
      ind = sample(1:ncol(ref_data), numSurr)
      control_surr = ref_data[,ind]
      colnames(control_surr) = colnames(control_surr)[ind]
      rownames(control_surr) = rownames(ref_data)
      dim(control_surr)
    }
    data_mx = cbind(data_surr, control_surr)
  } else {
    data_mx = data_surr
  }

  # Remove metabolites that are NA for all samples in data_mx
  rmThese = c()
  for (r in 1:nrow(data_mx)) {
    if (all(is.na(as.numeric(data_mx[rownames(data_mx)[r],])))) {
      rmThese = c(rmThese, r)
    } else {
      if (addHealthyControls) {
        data_mx[r, which(is.na(data_mx[r, ]))] = min(na.omit(as.numeric(ref_data[rownames(data_mx)[r],])))
      } else {
        data_mx[r, which(is.na(data_mx[r, ]))] = min(na.omit(as.numeric(data_mx[rownames(data_mx)[r],])))
      }
    }
  }
  if (length(rmThese) > 0) { data_mx = data_mx[-rmThese, ] }
  any(is.na(data_mx))
  any(is.infinite(unlist(data_mx)))

  var.met = apply(data_mx, 1, sd)
  if (length(which(var.met == 0)) > 0) { data_mx = data_mx[-which(var.met == 0), ] }
  rownames(data_mx) = tolower(rownames(data_mx))
  data_mx = apply(data_mx, c(1, 2), as.numeric)
  dim(data_mx)

  return(data_mx)
}


#' Horizontal error bars
#'
#' A rotated version of [geom_errorbar()].
#'
#' @eval rd_aesthetics("geom", "errorbarh")
#' @inheritParams layer
#' @inheritParams geom_point
#' @export
#' @examples
#' df <- data.frame(
#'   trt = factor(c(1, 1, 2, 2)),
#'   resp = c(1, 5, 3, 4),
#'   group = factor(c(1, 2, 1, 2)),
#'   se = c(0.1, 0.3, 0.3, 0.2)
#' )
#'
#' # Define the top and bottom of the errorbars
#'
#' p <- ggplot(df, aes(resp, trt, colour = group))
#' p +
#'   geom_point() +
#'   geom_errorbarh(aes(xmax = resp + se, xmin = resp - se))
#'
#' p +
#'   geom_point() +
#'   geom_errorbarh(aes(xmax = resp + se, xmin = resp - se, height = .2))
geom_errorbarh <- function(mapping = NULL, data = NULL,
                           stat = "identity", position = "identity",
                           ...,
                           na.rm = FALSE,
                           show.legend = NA,
                           inherit.aes = TRUE) {
  layer(
    data = data,
    mapping = mapping,
    stat = stat,
    geom = GeomErrorbarh,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomErrorbarh <- ggproto("GeomErrorbarh", Geom,
  default_aes = aes(colour = "black", size = 0.5, linetype = 1, height = 0.5,
    alpha = NA),

  draw_key = draw_key_path,

  required_aes = c("xmin", "xmax", "y"),

  setup_data = function(data, params) {
    data$height <- data$height %||%
      params$height %||% (resolution(data$y, FALSE) * 0.9)

    transform(data,
      ymin = y - height / 2, ymax = y + height / 2, height = NULL
    )
  },

  draw_panel = function(data, panel_params, coord, height = NULL, lineend = "butt") {
    GeomPath$draw_panel(new_data_frame(list(
      x = as.vector(rbind(data$xmax, data$xmax, NA, data$xmax, data$xmin, NA, data$xmin, data$xmin)),
      y = as.vector(rbind(data$ymin, data$ymax, NA, data$y,    data$y,    NA, data$ymin, data$ymax)),
      colour = rep(data$colour, each = 8),
      alpha = rep(data$alpha, each = 8),
      size = rep(data$size, each = 8),
      linetype = rep(data$linetype, each = 8),
      group = rep(1:(nrow(data)), each = 8),
      row.names = 1:(nrow(data) * 8)
    )), panel_params, coord, lineend = lineend)
  }
)


#' ---
#' title: "Pollutant inventory spatialization"
#' author:
#'    - "Milan Kilibarda"
#'    - "Dragutin Protic"
#' date: "`r format(Sys.time(), '%d %B %Y')`"
#' output:
#'    html_document:
#'      keep_md: true
#'      theme: "simplex"
#'      highlight: tango
#'      toc: true
#'      toc_depth: 5
#'      toc_float: true
#'      fig_caption: yes
#' ---
#'
#+ include = FALSE
# <img src="Logo-Trans.png" align="center" alt="logo" width="2000" height = "3000" style = "border: none; float: right;">
#' This document provides the maps regarding the spatialization of pollutation inventory.
#'
#'
#+ include = TRUE, echo = FALSE, results = 'hide', warning = FALSE, message = FALSE
library(tidyverse)
library(sf)
library(readxl)
library(ggpubr)
library(ggfortify)
library(here)
library(knitr)
library(kableExtra)
library(DT)
library(mapview)
library(rgdal)
library(SerbianCyrLat)
library(stringr)
library(classInt)
library(viridis)
library(gridExtra)
library(magrittr)
library(ggmap)
library(leaflet)
library(xlsx)
library(data.table)
library(mapview)
library(mapedit)
library(matlib)
library(nngeo)
library(writexl)
library(here)
library(MASS)
#'
#'
#'
#'
#'
#+ include = FALSE
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::
# Read surveyer functions
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::
source("./R/simulation_funs.r")
source("./R/functions.r")
#'
#'
#'
#+ include = FALSE
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::
# Boskovic/Milovanovic
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::

mreza_sim <- read_surveynet(file = paste("C:/Users/geoinz/Documents/IG/Projektovanje_2020/Boskovic_Milovanovic/Mreza_Boskovic_Milovanovic.xlsx"))

mreza_adj <- adjust.snet(adjust = FALSE, survey.net = mreza_sim, dim_type = "2D", sd.apriori = 1,  all = FALSE, prob = 0.95, maxiter = 1, ellipse.scale = 3)

ggplot() +
  geom_sf(data = mreza_adj[[1]]$net.points, aes(fill = sp)) +
  geom_sf(data = mreza_adj[[1]]$ellipse.net) +
  ggtitle("Mean area by group") +
  theme_bw()

#'
#'
#'
#+ include = FALSE
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::
# Koncarevic/Radovic
# :::::::::::::::::::::::::::::::::::::::::::::::::::::::

mreza_sim <- read_surveynet(file = paste("C:/Users/geoinz/Documents/IG/Projektovanje_2020/Koncarevic_Radovic/Mreza.xlsx"))

mreza_adj <- adjust.snet(adjust = FALSE, survey.net = mreza_sim, dim_type = "2D", sd.apriori = 1,  all = FALSE, prob = 0.95, maxiter = 1, ellipse.scale = 3)

ggplot() +
  geom_sf(data = mreza_adj[[1]]$net.points, aes(fill = sp)) +
  geom_sf(data = mreza_adj[[1]]$ellipse.net) +
  ggtitle("Mean area by group") +
  theme_bw()


library(reprtree)
library(caret)
library(randomForest)

args <- commandArgs(TRUE)
parseArgs <- function(x) {
  res = strsplit(sub("^--", "", x), "=")
  if(length(unlist(res))==1) res[[1]][2]=""
  return(res)
}
argsL <- as.list(as.character(as.data.frame(do.call("rbind", parseArgs(args)))$V2))
names(argsL) <- as.data.frame(do.call("rbind", parseArgs(args)))$V1
args <- argsL;rm(argsL)

if(is.null(args$help)) {help=FALSE} else {help=TRUE}

if(is.null(args$train_table) | help) {
  cat("

      Method: add features to each variant of a table to be used in the classifier

      Mandatory arguments:
      --train_table=file_name     - table output from add_calling_features.r
      Optional arguments:
      --output_folder             - folder to save the models (default: .)
      --help                      - print this text

      example: compute_model.r --train_table=table_for_training.txt \n\n")
  q(save="no")
}

if(is.null(args$output_folder)) {output_folder="."} else {output_folder=args$output_folder}

set.seed(123) # here I fix the seed of the random generator to have the same random numbers if re-run

train_table_all = read.table(args$train_table, quote="\"", stringsAsFactors=F, sep="\t", header=T)

train_table_all$IoD = 1 + train_table_all$SIG * 10^(train_table_all$ERR)

# keep only SNVs
for(type in c("snv","indel")){
  if(type=="snv") train_table = train_table_all[which(train_table_all$TYPE_INFO=="snv"),]
  if(type!="snv") train_table = train_table_all[which(train_table_all$TYPE_INFO!="snv"),]

  train_table[which(is.infinite(train_table$MIN_DIST)),"MIN_DIST"] = 1000000000
  train_table[which(is.infinite(train_table$MaxRatioWin)),"MaxRatioWin"] = 1000000000

  propTP = as.numeric(table(train_table$status)["TP"] / nrow(train_table))
  propFP = as.numeric(table(train_table$status)["FP"] / nrow(train_table))

  my_features=c("status","RVSB", "QVAL","AF","ERR_INFO","DP", "medianDP_INFO",
                "FS", "MIN_DIST", "AO", "QUAL", "MaxRatioWin", "NbVarWin", "IoD", "HpLength", "N_QVAL_20_50_INFO")

  rf = randomForest(as.factor(status) ~ .,
                    data = train_table[,my_features],
                    importance = TRUE, # to allow us to inspect variable importance
                    ntree = 500, sampsize = as.numeric(table(train_table$status)["TP"], probs=T) #classwt = c(propTP, propFP), # weighted FP by propTP and TP by propFP
                    # ,maxnodes=10, nodesize=20
  )
  assign(paste("rf_",type,sep=""), rf)
  save(list=paste("rf_",type,sep=""), file = paste(output_folder,"/RF_model_",type,".Rdata",sep=""))
}


#' Import NWIS Daily Data for EGRET analysis
#'
#' Imports data from NWIS web service. This function gets the data from here: \url{http://waterservices.usgs.gov/}
#' A list of parameter codes can be found here: \url{http://nwis.waterdata.usgs.gov/nwis/pmcodes/}
#' A list of statistic codes can be found here: \url{http://nwis.waterdata.usgs.gov/nwis/help/?read_file=stat&format=table}
#'
#' @param siteNumber character USGS site number.  This is usually an 8 digit number
#' @param parameterCd character USGS parameter code.  This is usually an 5 digit number.
#' @param startDate character starting date for data retrieval in the form YYYY-MM-DD.
#' @param endDate character ending date for data retrieval in the form YYYY-MM-DD.
#' @param interactive logical Option for interactive mode.  If true, there is user interaction for error handling and data checks.
#' @param convert logical Option to include a conversion from cfs to cms (35.314667). The default is TRUE,
#' which is appropriate for using NWIS data in the EGRET package.  Set this to FALSE to not include the conversion. If the parameter code is not 00060 (NWIS discharge),
#' there is no conversion applied.
#' @keywords data import USGS WRTDS
#' @export
#' @import dataRetrieval
#' @return A data frame 'Daily' with the following columns:
#' \tabular{lll}{
#' Name \tab Type \tab Description \cr
#' Date \tab Date \tab Date \cr
#' Q \tab numeric \tab Discharge in m^3/s\cr
#' Julian \tab integer \tab Number of days since Jan. 1, 1850\cr
#' Month \tab integer \tab Month of the year [1-12] \cr
#' Day \tab integer \tab Day of the year [1-366] \cr
#' DecYear \tab numeric \tab Decimal year \cr
#' MonthSeq \tab integer \tab Number of months since January 1, 1850 \cr
#' Qualifier \tab character \tab Qualifying code \cr
#' i \tab integer \tab Index of days, starting with 1 \cr
#' LogQ \tab numeric \tab Natural logarithm of Q  \cr
#' Q7 \tab numeric \tab 7 day running average of Q \cr
#' Q30 \tab numeric \tab 30 day running average of Q \cr
#' }
#' @seealso \code{\link[dataRetrieval]{readNWISdv}}, \code{\link{populateDaily}}
#' @examples
#' \dontrun{
#'
#' Daily <- readNWISDaily('01594440','00060', '1985-01-01', '1985-03-31')
#' DailySuspSediment <- readNWISDaily('01594440','80154', '1985-01-01', '1985-03-31',convert=FALSE)
#' }
readNWISDaily <- function (siteNumber,parameterCd="00060",
                           startDate="",endDate="",interactive=TRUE,convert=TRUE){

#   data <- readNWISdv(siteNumber,parameterCd,startDate,endDate)
#   #  need to setup conversion factor because the NWIS data are in cfs but we store in cms
#   names(data) <- c('agency', 'site', 'dateTime', 'tz_cd','code', 'value')  # do a merge instead?
#
#   data$dateTime <- as.Date(data$dateTime)
  ##################################
  url <- dataRetrieval::constructNWISURL(siteNumber,parameterCd,startDate,endDate,"dv",statCd="00003", format = "tsv")

  data <- dataRetrieval::importRDB1(url, asDateTime=FALSE)
  if(nrow(data)>0){
    names(data) <- c('agency', 'site', 'dateTime', 'value', 'code')
    data$dateTime <- as.Date(data$dateTime)
  }

  #####################################
  qConvert <- ifelse("00060" == parameterCd, 35.314667, 1)
  qConvert<- ifelse(convert,qConvert,1)

  localDaily <- populateDaily(data,qConvert,interactive=interactive)
  return (localDaily)
}


pdf("output.insertion_profile.pdf")
read_pos=c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31,32,33,34,35,36,37,38,39,40,41,42,43,44,45,46,47,48,49,50)
insert_count=c(0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0)
noninsert_count= 40 - insert_count
plot(read_pos, insert_count*100/(insert_count+noninsert_count),col="blue",main="Insertion profile",xlab="Position of read",ylab="Insertion %",type="b")
dev.off()


basicA (steps<factor)

           value  ------------- Distribution ------------- count
          <= -16 |@@@                                      164
              -8 |@@@                                      180
              -4 |@@@@@                                    285
              -2 |@@@@                                     195
              -1 |@@                                       99
               0 |@@                                       100
               1 |@@                                       101
               2 |@@@@                                     205
               4 |@@@@@@                                   315
               8 |@@@@                                     220
           >= 16 |@@@@                                     236

basicB (steps==factor)

           value  ------------- Distribution ------------- count
          <= -16 |@@@                                      164
             -12 |@@                                       88
              -8 |@@                                       92
              -4 |@@@@@                                    285
              -3 |@@                                       97
              -2 |@@                                       98
              -1 |@@                                       99
               0 |@@                                       100
               1 |@@                                       101
               2 |@@                                       102
               3 |@@                                       103
               4 |@@@@@@                                   315
               8 |@@                                       108
              12 |@@                                       112
           >= 16 |@@@@                                     236

basicC (steps>factor)

           value  ------------- Distribution ------------- count
          <= -16 |@@@                                      164
             -14 |                                         0
             -12 |@@                                       88
             -10 |                                         0
              -8 |@@                                       92
              -6 |@@                                       94
              -4 |@@@@                                     191
              -3 |@@                                       97
              -2 |@@                                       98
              -1 |@@                                       99
               0 |@@                                       100
               1 |@@                                       101
               2 |@@                                       102
               3 |@@                                       103
               4 |@@@@                                     209
               6 |@@                                       106
               8 |@@                                       108
              10 |                                         0
              12 |@@                                       112
              14 |                                         0
           >= 16 |@@@@                                     236

basicD (steps>factor and bigger lmag)

           value  ------------- Distribution ------------- count
       <= -16384 |                                         6
          -15872 |                                         8
          -15360 |                                         0
          -14848 |                                         0
          -14336 |                                         0
          -13824 |                                         0
          -13312 |                                         0
          -12800 |                                         0
          -12288 |                                         0
          -11776 |                                         0
          -11264 |                                         0
          -10752 |                                         0
          -10240 |                                         0
           -9728 |                                         16
           -9216 |                                         96
           -8704 |                                         384
           -8192 |@@                                       1536
           -7680 |@                                        1024
           -7168 |                                         0
           -6656 |                                         0
           -6144 |                                         0
           -5632 |                                         0
           -5120 |                                         0
           -4608 |@@@@@@                                   6144
           -4096 |                                         0
           -3968 |                                         0
           -3840 |                                         0
           -3712 |                                         0
           -3584 |                                         0
           -3456 |                                         0
           -3328 |                                         0
           -3200 |                                         0
           -3072 |                                         0
           -2944 |                                         0
           -2816 |                                         0
           -2688 |                                         0
           -2560 |@@                                       2048
           -2432 |@@@@                                     4096
           -2304 |                                         0
           -2176 |                                         0
           -2048 |                                         0
           -1920 |                                         0
           -1792 |                                         0
           -1664 |                                         0
           -1536 |                                         0
           -1408 |                                         0
           -1280 |                                         0
           -1152 |                                         0
           -1024 |@@                                       2048
            -992 |                                         0
            -960 |                                         0
            -928 |                                         0
            -896 |                                         0
            -864 |                                         0
            -832 |                                         0
            -800 |                                         0
            -768 |                                         0
            -736 |                                         0
            -704 |                                         0
            -672 |                                         0
            -640 |                                         0
            -608 |                                         0
            -576 |                                         0
            -544 |                                         0
            -512 |                                         0
            -480 |                                         0
            -448 |                                         0
            -416 |                                         0
            -384 |                                         0
            -352 |@                                        1024
            -320 |@                                        512
            -288 |                                         0
            -256 |                                         256
     abs() < 256 |                                         130
             256 |                                         256
             288 |                                         0
             320 |@                                        512
             352 |@                                        1024
             384 |                                         0
             416 |                                         0
             448 |                                         0
             480 |                                         0
             512 |                                         0
             544 |                                         0
             576 |                                         0
             608 |                                         0
             640 |                                         0
             672 |                                         0
             704 |                                         0
             736 |                                         0
             768 |                                         0
             800 |                                         0
             832 |                                         0
             864 |                                         0
             896 |                                         0
             928 |                                         0
             960 |                                         0
             992 |                                         0
            1024 |@@                                       2048
            1152 |                                         0
            1280 |                                         0
            1408 |                                         0
            1536 |                                         0
            1664 |                                         0
            1792 |                                         0
            1920 |                                         0
            2048 |                                         0
            2176 |                                         0
            2304 |                                         0
            2432 |@@@@                                     4096
            2560 |@@                                       2048
            2688 |                                         0
            2816 |                                         0
            2944 |                                         0
            3072 |                                         0
            3200 |                                         0
            3328 |                                         0
            3456 |                                         0
            3584 |                                         0
            3712 |                                         0
            3840 |                                         0
            3968 |                                         0
            4096 |                                         0
            4608 |@@@@@@                                   6144
            5120 |                                         0
            5632 |                                         0
            6144 |                                         0
            6656 |                                         0
            7168 |                                         0
            7680 |@                                        1024
            8192 |@@                                       1536
            8704 |                                         384
            9216 |                                         96
            9728 |                                         16
           10240 |                                         0
           10752 |                                         0
           11264 |                                         0
           11776 |                                         0
           12288 |                                         0
           12800 |                                         0
           13312 |                                         0
           13824 |                                         0
           14336 |                                         0
           14848 |                                         0
           15360 |                                         0
           15872 |                                         8
        >= 16384 |                                         6

zero

           value  ------------- Distribution ------------- count
               0 |                                         0
               1 |                                         0
               2 |                                         0

zeroB (lmag==0 && steps>factor)

           value  ------------- Distribution ------------- count
               0 |                                         0
               1 |                                         0
               2 |                                         0

posvals

           value  ------------- Distribution ------------- count
               0 |                                         0
               1 |@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@ 1
               2 |                                         0

negvals

           value  ------------- Distribution ------------- count
               1                                         | 0
               2 @@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@| -1
            >= 4                                         | 0

allvals

           value  ------------- Distribution ------------- count
               0                     |                     0
               1                     |@@@@@@@@@@           1
               2           @@@@@@@@@@|                     -1
            >= 4                     |                     0

singlerangeA

           value  ------------- Distribution ------------- count
           <= -4 |@@@@                                     96
              -3 |@@@@                                     97
              -2 |@@@@                                     98
              -1 |@@@@                                     99
               0 |@@@@                                     100
               1 |@@@@                                     101
               2 |@@@@@                                    102
               3 |@@@@@                                    103
            >= 4 |@@@@@                                    104

singlerangeB

           value  ------------- Distribution ------------- count
           <= -4 |@@@@                                     96
              -3 |@@@@                                     97
              -2 |@@@@                                     98
              -1 |@@@@                                     99
               0 |@@@@                                     100
               1 |@@@@                                     101
               2 |@@@@@                                    102
               3 |@@@@@                                    103
            >= 4 |@@@@@                                    104

straightlog

           value  ------------- Distribution ------------- count
       <= -10000 |@@@@@@                                   200316
           -1000 |@@@                                      100308
            -100 |@@@                                      100408
             -10 |@@@                                      100508
              -1 |@@@                                      100608
               0 |@@@                                      100708
               1 |@@@                                      100808
              10 |@@@                                      100908
             100 |@@@                                      101008
            1000 |@@@                                      101108
        >= 10000 |@@@@@@                                   202516

shift

           value  ------------- Distribution ------------- count
           <= -4 |                                         0
              -2 |@@@@@@@@@@@@@@@@@@@@                     1
              -1 |                                         0
               0 |                                         0
               1 |                                         0
               2 |@@@@@@@@@@@@@@@@@@@@                     1
            >= 4 |                                         0

ghostbin (lmag==0 && steps>factor); check ghost-bin problem

           value  ------------- Distribution ------------- count
              -2 |                                         0
              -1 |@@@@@@@@@@@@@@@@@@@@                     1
               0 |                                         0
               1 |@@@@@@@@@@@@@@@@@@@@                     1
               2 |                                         0


#!/usr/bin/env Rscript
## Takes a .genome file from PLINK as ARGV 1 and outputs a

args = commandArgs(trailingOnly=TRUE)
if (length(args)==0) {
      stop("At least one argument must be supplied (input file).n", call.=FALSE)
}

data1<- read.table (args[1], header = T)
data2<-sort(data1$PI_HAT, decreasing = TRUE)

output<-paste( "IBS_proportion_",args[1], ".pdf" , sep ="")
pdf(output)

plot(data2, cex=0.8, pch = 20, col="aquamarine4")
title("IBS_proportion")


#' Indexing diffnet objects (on development)
#'
#' Access and assign (replace) elements from the adjacency matrices or the vertex
#' attributes data frames.
#'
#' @param x A diffnet class object.
#' @param name String vector. Names of the vertices attributes.
#' @param i Index of the i-th row of the adjacency matrix (see details).
#' @param j Index of the j-th column of the adjacency matrix (see details)
#' @param k Index of the k-th slice of the adjacency matrix (see details).
#' @param value Value to assign (see details)
#' @param drop Logical scalar. When \code{TRUE} returns an adjacency matrix, otherwise
#' a filtered diffnet object.
#' @param as.df Logical scalar. When \code{TRUE} returns a data frame, otherwise
#' a list of length \eqn{T}.
#' @details
#' The \code{[[.diffnet} methods provides access to the diffnet attributes
#' data frames, static and dynamic. By providing the \code{name} of the corresponding
#' attribute, depending on whether it is static or dynamic the function will return
#' either a data frame--static attributes--or a list of these--dynamic attributes.
#' For the assigning method, \verb{[[<-.diffnet}, the function will infer what
#' kind of attribute is by analyzing the dimensions of \code{value}, in particular
#' we have the following possible cases:
#'
#' \tabular{llr}{
#' \strong{Class}    \tab \strong{Dimension}   \tab \strong{Inferred} \cr
#' \code{matrix}     \tab \eqn{n\times T}{n*T} \tab Dynamic           \cr
#' \code{matrix}     \tab \eqn{n\times 1}{n*1} \tab Static            \cr
#' \code{matrix}     \tab \eqn{(n\times T)\times 1}{(n*T)*1} \tab Dynamic            \cr
#' \code{data.frame} \tab \eqn{n\times T}{n*T} \tab Dynamic           \cr
#' \code{data.frame} \tab \eqn{n\times 1}{n*1} \tab Static            \cr
#' \code{data.frame} \tab \eqn{(n\times T)\times 1}{(n*T)*1} \tab Dynamic            \cr
#' \code{vector}     \tab \eqn{n}              \tab Static            \cr
#' \code{vector}     \tab \eqn{n\times T}{n*T} \tab Dynamic           \cr
#' \code{list}*      \tab \eqn{T} data.frames/matrices/vectors\tab Dynamic    \cr
#' }
#' *: With \eqn{n\times 1}{n * 1} \code{data.frame}/\code{matrix} or \eqn{n} length vector.
#'
#' Other cases will return with error.
#'
#' In the case of the slices index \code{k}, either an
#' integer vector with the positions, a character vector with the labels of the
#' time periods or a logical vector of length \code{T} can be used to specify
#' which slices to retrieve. Likewise, indexing vertices works in the same way
#' with the only difference that, instead of time period labels and a logical vector
#' of length \code{T}, vertices ids labels and a logical vector of length \code{n}
#' should be provided.
#'
#' When subsetting slices, the function modifies the \code{toa} vector as well as the
#' \code{adopt} and \code{cumadopt} matrices collapsing network tinmming. For example,
#' if a network goes from time 1 to 20 and we set \code{k=3:10}, all individuals
#' who adopted prior to time 3 will be set as adopters at time 3, and all individuals
#' who adopted after time 10 will be set as adopters at time 10, changing the
#' adoption and cumulative adoption matrices. Importantly, \code{k} have no
#' gaps, and it should be within the graph time period range.
#'
#' @return In the case of the assigning methods, a diffnet object. Otherwise,
#' for \code{[[.diffnet} a vector extracted from one of the attributes data frames,
#' and for \code{[.diffnet} a list of length \code{length(k)} with the corresponding
#' \code{[i,j]} elements from the adjacency matrix.
#' @name diffnet_index
#' @family diffnet methods
#' @author George G. Vega Yon
#' @examples
#'
#' # Creating a random diffusion network ---------------------------------------
#' set.seed(111)
#' graph <- rdiffnet(50,4)
#'
#' # Accessing to a static attribute
#' graph[["real_threshold"]]
#'
#' # Accessing to subsets of the adjacency matrix
#' graph[1,,1:3, drop=TRUE]
#' graph[,,1:3, drop=TRUE][[1]]
#'
#' # ... Now, as diffnet objects (the default)
#' graph[1,,1:3, drop=FALSE]
#' graph[,,1:3, drop=FALSE]
#'
#' # Changing values in the adjacency matrix
#' graph[1, , , drop=TRUE]
#' graph[1,,] <- -5
#' graph[1, , , drop=TRUE]
#'
#' # Adding attributes (dynamic) -----------------------------------------------
#' # Preparing the data
#' set.seed(1122)
#' x <- rdiffnet(30, 4, seed.p.adopt=.15)
#'
#' # Calculating exposure, and storing it diffe
#' expoM <- exposure(x)
#' expoL <- lapply(seq_len(x$meta$nper), function(x) expoM[,x,drop=FALSE])
#' expoD <- do.call(rbind, expoL)
#'
#' # Adding data (all these are equivalent)
#' x[["expoM"]] <- expoM
#' x[["expoL"]] <- expoL
#' x[["expoD"]] <- expoD
#'
#' # Lets compare
#' identical(x[["expoM"]], x[["expoL"]]) # TRUE
#' identical(x[["expoM"]], x[["expoD"]]) # TRUE
NULL

# @export
# @rdname diffnet_index
diffnet.subset.slices <- function(graph, k) {

  if (!inherits(graph, "diffnet")) stop("-graph- must be a 'diffnet' object")

  # Subset must be of length 2 (at least)
  if (length(k) < 2)
    stop("-k- is a vector of length ",length(k),
         ". It must be at least of length 2.")

  # Analyzing class
  uses_labels <- ifelse(inherits(k, "character"), TRUE, FALSE)
  if (uses_labels) {
    k <- as.integer(k)
  }

  # If logical vector
  if (inherits(k, "logical")) {
    k <- which(k)
  }

  # Subset must be continuous...
  test <- (k[-1] - k[-length(k)]) > 1
  if (any(test))
    stop("-k- must represent a range without gaps.")

  # Ordering
  k  <- sort(k)
  nslices <- length(k)
  pers    <- graph$meta$pers

  # Checking k
  test <- if (!uses_labels) !(k %in% seq_len(graph$meta$nper))
  else !(k %in% pers)

  if (any(test))
    stop("The specified -k- (",
         paste0(k[test], collapse = ", "),
         ") are invalid.")

  # Recomputing in terms of indexes
  if (uses_labels) k <- which(pers %in% as.character(k))

  # Removing not included k
  graph$graph            <- graph$graph[k]
  graph$vertex.dyn.attrs <- graph$vertex.dyn.attrs[k]

  # Changing adoption matrices

  beforeslice <- which(graph$toa < pers[k][1])
  afterslice  <- which(graph$toa > pers[k][nslices])

  graph$adopt[beforeslice,k[1]] <- 1
  graph$adopt[afterslice ,k[nslices]] <- 1
  graph$adopt    <- graph$adopt[,k]

  graph$cumadopt[beforeslice,k] <- 1
  graph$cumadopt[afterslice,k[nslices]] <- 1
  graph$cumadopt <- graph$cumadopt[,k]

  # Changing toa mat (truncating it)
  graph$toa[beforeslice] <- pers[k][1]
  graph$toa[afterslice]  <- pers[k][nslices]

  # Changing meta
  graph$meta$nper <- nslices
  graph$meta$pers <- pers[k]

  graph
}

#' Infer whether \code{value} is dynamic or static.
#'
#' Intended for internal use only, this function is used in \code{\link{diffnet_index}}
#' methods.
#'
#' @param value Either a matrix, data frame or a list. Attribute values.
#' @param meta A list. A diffnet object's meta data.
#'
#' @return The value object either as a data frame (if static) or as a list
#' of data frames (if dynamic). If \code{value} does not follows the permitted
#' types of \code{\link{diffnet_index}}, then returns with error.
#'
#' @export
diffnet_check_attr_class <- function(value, meta) {
  # Processing meta
  n <- meta$n
  t <- meta$nper

  if (inherits(value, "matrix") | inherits(value, "data.frame")) {
    # Static case
    vdim <- dim(value)
    if (all(vdim == c(n, t)))    { # Dynamic Matrix

      # Coercing into a list
      value <- lapply(seq_len(t), function(x) value[, x, drop=TRUE])
      return(value)

    } else if (all(vdim == c(n, 1L))) { # Static Matrix

      # Coercing into a vector
      return(value[,1,drop=TRUE])

    } else if (all(vdim == c(n*t, 1L))) { # Dynamic Matrix

      # Coercing into a list
      value <- lapply(seq_len(t), function(x)
        value[((x-1)*n + 1):(x*n),,drop=TRUE]
        )
      return(value)

    } else {
      stop("-value- data.frame/matrix has incorrect size (", vdim[1], " x ", vdim[2],"). ",
           "Please refer to the manual to see accepted values.")
    }

  } else if (inherits(value, "list")) {

    # Checking classes of the elements
    isdf <- sapply(value, inherits, what="data.frame")
    # Which ones aren't either
    test <- !isdf & !sapply(value, inherits, what="matrix")

    # If no data.frame/matrix, then no vector?
    test <- which(ifelse(!test, test, !is.vector(value)))

    if (length(test)) {
      stop("Not all the elements in the list are data.frame/matrix or vector:\n\t",
           paste0(test, collapse=", "), ".")
    }

    # Checking the dimensions of the elements
    test <- which(sapply(value, function(x) {
      if (is.vector(x)) {
        length(x) != n
      }
      else {
        !all(dim(x) == c(n,1))
      }
      }))

    if (length(test)) {
      stop("Not all elements in the list have the right dimension (",n," elements):\n\t",
           paste0(test, collapse=", "), ".")
    }

    # Corecing non df to dfs, and then coercing into vectors
    value[!isdf] <- lapply(value[!isdf], as.data.frame)
    value <- lapply(value, "[[", 1)

    return(value)

  } else if (is.vector(value)) {
    # Checking the length
    vdim <- length(value)

    if (vdim == n) {# Checking static

      # Returning asis (ideal case?)
      return(value)

    } else if (vdim == (n*t)) { # Checking dynamic

      # Coercing into a list
      value <- lapply(seq_len(t), function(x)
        value[((x-1)*n + 1):(x*n)]
      )

      return(value)

    } else {
      stop("-value- vector has incorrect size (", vdim, "). ",
           "Please refer to the manual to see accepted values.")
    }

  } else stop("-value- must be either a list, a data frame or a matrix.")
}

#' @export
#' @rdname diffnet_index
`[[.diffnet` <- function(x, name, as.df=FALSE) {

  # Checking names
  if (name %in% colnames(x$vertex.static.attrs)) {
    x <- x$vertex.static.attrs[[name]]
    if (as.df) x <- as.data.frame(setNames(list(x), list(name)))
    return(x)
  } else if (name %in% colnames(x$vertex.dyn.attrs[[1]])) {

    x <- lapply(x$vertex.dyn.attrs, "[[", name)
    if (as.df) {
      x <- as.data.frame(do.call(c, x))
      colnames(x) <- name
      return(x)
    } else return(x)

  } else {
    stop("No dynamic or static attribute with such name.")
  }

}

#' @export
#' @rdname diffnet_index
`[[<-.diffnet` <- function(x, i, j, value) {
  # If j index is specified, then the addition is made to a subset
  if (missing(j)) j <- seq_len(x$meta$n)

  # Checking and preparing the data
  meta <- x$meta
  if (length(j) < meta$n) meta$n <- length(j)
  if (length(value)) value <- diffnet_check_attr_class(value, meta)
  else {

    if (i %in% colnames(x$vertex.static.attrs)) {

      # Static case
      tokeep <- colnames(x$vertex.static.attrs)
      tokeep <- tokeep[which(tokeep != i)]
      x$vertex.static.attrs <- subset(x$vertex.static.attrs, select=tokeep)
      return(x)

    } else if (i %in% colnames(x$vertex.dyn.attrs[[1]])) {

      # Dynamic case
      tokeep <- colnames(x$vertex.dyn.attrs[[1]])
      tokeep <- tokeep[which(tokeep != i)]
      x$vertex.dyn.attrs <-
        lapply(x$vertex.dyn.attrs, function(y) subset(y, select=tokeep))
      return(x)
    } else {

      # Nothing case
      warning('There is no attribute called -',i,'-. Returning the diffnet intact.')
      return(x)
    }

  }

  # Adding the attribute
  if (!inherits(value, "list")) {
    x$vertex.static.attrs[[i]][j] <- value
  } else {
    # Checking if is empty or not
    for (l in 1:meta$nper)
      x$vertex.dyn.attrs[[l]][[i]][j] <- value[[l]]
  }
  x
}

.indexing <- function(i, ids) {

  ans <- seq_len(length(ids))
  names(ans) <- ids
  ans[i]
}

#' @export
#' @rdname diffnet_index
`[.diffnet` <- function(x, i, j, k, drop=FALSE) {

  # Checking drop
  if (drop) { # So it requires the adjmat
    # Checking ids
    if (missing(i)) i <- seq_len(x$meta$n)
    if (missing(j)) j <- seq_len(x$meta$n)
  } else { # So its subsetting the diffnet
    if      (missing(i)  & missing(j) ) i <- j <- seq_len(x$meta$n)
    else if (missing(i)  & !missing(j)) i <- j
    else if (!missing(i) & missing(j) ) j <- i
    else if (!missing(i) & !missing(j))
      if (!identical(i, j))
        stop("Whe subsetting a diffnet and -i- and -j- are provided these should,",
             "be identical.")
  }

  # Slices
  if (missing(k)) k <- seq_len(x$meta$nper)

  # Adding names
  i <- .indexing(i, x$meta$ids)
  j <- .indexing(j, x$meta$ids)
  k <- .indexing(k, x$meta$pers)

  # Subsetting
  if (drop) return(lapply(x$graph[k], "[", i=i, j=j, drop=FALSE))
  else {
    x <- diffnet.subset.slices(x, k)
    x$graph <- lapply(x$graph, "[", i=i, j=j, drop=FALSE)

    # Subsetting
    # 1.0: graph and attributes
    for (l in 1:x$meta$nper)
       x$vertex.dyn.attrs[[l]] <- x$vertex.dyn.attrs[[l]][i,,drop=FALSE]

    # 2.0: Matrices
    x$adopt               <- x$adopt[i,,drop=FALSE]
    x$cumadopt            <- x$cumadopt[i,,drop=FALSE]
    x$vertex.static.attrs <- x$vertex.static.attrs[i,,drop=FALSE]
    x$toa                 <- x$toa[i]

    # 3.0: Attrubytes
    x$meta$ids <- x$meta$ids[i] #rownames(x$adopt)#x$meta$ids[i]
    x$meta$n   <- length(x$meta$ids)

    return(x)
  }
}

#' @export
#' @rdname diffnet_index
`[<-.diffnet` <- function(x, i, j, k, value) {
  # Checking ids
  if (missing(i)) i <- seq_len(x$meta$n)
  if (missing(j)) j <- seq_len(x$meta$n)
  if (missing(k)) k <- seq_len(x$meta$nper)

  for (l in k)
    x$graph[[l]][i,j] <- value

  x
}


add=function()
{
  a = as.integer(readline(prompt = "enter one value"))

  b = as.integer(readline(prompt = "enter two value"))

  c=a+b
  print(c)
}
add()


define_level_factor <- function (factor_sets, variable_of_interest_name) {
  factor_names = colnames(factor_sets)
  added_factors = paste(factor_names, collapse = " + 1*")
  paste0(variable_of_interest_name, "_level =~ 1*",added_factors)
}


library("xml2")
library("dplyr")
library("stringr")
library("PortfolioAnalytics")

data <- read.csv("C:/Users/qiuch/Desktop/portfolio_proj/input/finalfund.csv",header = T, encoding="UTF-8")

setwd("C:/Users/qiuch/Desktop/portfolio_proj")

print(is.data.frame(data))
rows = nrow(data)

#a = as.Date('2013/1/25',format='%Y/%m/%d')

#date
fund_num = 5 # can be specified
for (j in 1:fund_num){
    tmp = as.character(data[,2*j])
    data[,2*j] = as.Date(tmp,format='%Y/%m/%d')
}

#date completion

#Step 1: find the fund with most dates
fund_most_date = 1
for (fund_most_date in 1:fund_num){
    i = 1
    while(!is.na(data[i,2*fund_most_date])) {i = i + 1}
    print(fund_most_date)

    if (i == rows) break;
}

print(fund_most_date)
#Step 2: Complete all the other funds
if(fund_most_date != 1) {
    for (j in 1:(fund_most_date-1)){
        for(i in 1:rows){
            if(is.na(data[i,2*j]) || (data[i,2*j] > data[i,2*fund_most_date])){
                if(i != rows){
                    #move the date
                    data[(i+1):rows,2*j] = data[i:(rows-1),2*j]
                    data[(i+1):rows,2*j+1] = data[i:(rows-1),2*j+1]
                    #use inflation to estimate the NAV for the lacking date
                    data[i,2*j] = data[i,2*fund_most_date]
                    data[i,2*j+1] = (data[i-1,2*j+1] + data[i+1,2*j+1]) / 2
                }
                else{
                    data[i,2*j] = data[i,2*fund_most_date]
                }
            }
        }
    }
}

if(fund_most_date != fund_num){
    for (j in (fund_most_date+1):fund_num){
        for(i in 1:rows){
            if(is.na(data[i,2*j]) || (data[i,2*j] > data[i,2*fund_most_date])){
                if(i != rows){
                    #move the date
                    data[(i+1):rows,2*j] = data[i:(rows-1),2*j]
                    data[(i+1):rows,2*j+1] = data[i:(rows-1),2*j+1]
                    #use inflation to estimate the NAV for the lacking date
                    data[i,2*j] = data[i,2*fund_most_date]
                    data[i,2*j+1] = (data[i-1,2*j+1] + data[i+1,2*j+1]) / 2
                }
                else{
                    data[i,2*j] = data[i,2*fund_most_date]
                }
            }
        }
    }
}


# GetShockLowData.r

# where to run?
# setwd("C:/cygwin64/home/landau/working/PreservationSimulation/shocks/low/span1/1yr")

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

# G E T   D A T A
rm(results)
results <- fndfGetGiantData("./")
# Get fewer columns to work with, easier to see.
dat.shockall <- as.data.frame(fndfGetShockData(results))

# S U B S E T S
dat.shock <- dat.shockall[dat.shockall$lifem<=100,]
dat.shock50 <- dat.shock[dat.shock$shockimpact==50,]
dat.shock90 <- dat.shock[dat.shock$shockimpact==90,]
dat.shock100 <- dat.shock[dat.shock$shockimpact==100,]

if(0){

source("./ShockTables.r")

# T A B U L A T E   D A T A  A S   T E X T

# M O N T H L Y
sOutputFilename <- "./Data_AuditRandom_Monthly.txt"
sTitle <- "Document losses with multiple copies and MONTHLY random auditing"
sSubtitle <- "Table of percentage loss of collection tabulated\n" %+%
    "by number of copies and sector half-lifetime"
dat.tmp <- dat.auditrandom.monthly
tbl.tmp <- fnPrintTableRandom(dat.tmp, sOutputFilename, sTitle, sSubtitle
)

# IF THAT WORKS, DO SOME MORE.

# Re-form the data into a table for printing.
foo<-(with(dat.auditrandom,
       tapply(mdmlosspct, list(copies, lifem), FUN=identity)))
foo2<-cbind(as.numeric(levels(factor(results$copies))), foo)
tbl2<-data.frame(foo2)
colnames(tbl2)<-c("copies",as.numeric(colnames(foo2[,2:ncol(foo2)])))
# Pretty-print this to a file with explanatory headings.
sink(sOutputFilename)
cat("MIT Preservation Simulation Project", "\n\n")
cat(sOutputFilename, format(Sys.time(),"%Y%m%d_%H%M%S%Z"), "\n\n")
cat(sTitle, "\n\n")
cat(sSubtitle, "\n\n")
cat("\n")
print(tbl2)
sink()

}#endif0

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

# P L O T   D A T A
library(ggplot2)
source("./ShockLowPlots.r")

gp <- fnPlotShock1(dat.shock90, 1, 1, 90)
fnPlotMakeFile(gp, "Shock_freq1span1impact90.png")

gp <- fnPlotShock1(dat.shock50, 1, 1, 50)
fnPlotMakeFile(gp, "Shock_freq1span1impact50.png")

gp <- fnPlotShock1(dat.shock100, 1, 1, 100)
fnPlotMakeFile(gp, "Shock_freq1span1impact100.png")

# not working yet
#fnPlotShock2(dat.shock90)

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


# load national crop products import and export adata from FAO
# scale thes according to population of each country in the basin
# to assess import/export of the countries

setwd( 'P:/is-wel/indus/message_indus' )

pid_pop_gdp = read.csv( "input/PID_pop_gdp.csv", stringsAsFactors=FALSE )

#consider SSP2, million people
country_pop = read.csv('input/OECD_SSP_POP.csv', stringsAsFactors = F) %>%
  filter(Country_Name %in% c('Afghanistan', 'India','Pakistan')) %>%
  filter(grepl('SSP2',Scenario)) %>%
  dplyr::select(Region,X2020) %>% rename(node = Region)

imp_exp.df0 = read.csv( "input/land_maps_crop_yields/FAO_prices/FAOSTAT_IMPORT_EXPORT.csv", stringsAsFactors=FALSE ) %>%
  dplyr::select(Country,Element,Item,Year,Unit,Value)

names(imp_exp.df0) = c('country','imp_exp','item','year','unit','value')

ggplot(imp_exp.df0,aes(year,value,color = item))+
  geom_line()+
  facet_wrap(imp_exp~country)+
  theme_bw()

# consider only year > 2000 . make avg import-export per country, per crop type
# unit 1000 tonnes
imp_exp.df = imp_exp.df0 %>% filter(year >= 2000) %>%
  mutate(imp_exp = gsub('\\ .*$','',imp_exp)) %>%
  group_by(country,item,imp_exp) %>%
  summarise(value = mean(value)) %>%
  ungroup()

# the current demand implementation is based on current production, qhich includes current export and imports
# therefore, a policy that decrease imports, will increase the deamand of crop products
# a policy that limit ezportation, will DECREASE the internal demand

map_country = data.frame(country = unique(imp_exp.df$country),
                         node = c('AFG','IND','PAK') )

map_crop = data.frame(item = unique(imp_exp.df$item),
                         crop = c('cotton',"Maize and products",'pulses','rice','wheat','fodder','sugarcane') )

# scale with population
pop_ratio = pid_pop_gdp %>% mutate(node = gsub('_.*','',PID)) %>%
  filter(year == 2020, node != 'CHN') %>%
  group_by(node) %>%
  summarise(basin_pop = sum(total_pop)) %>% ungroup() %>%
  left_join(country_pop) %>%
  mutate(X2020 = X2020 * 1e6, ratio = basin_pop / X2020) %>%
  dplyr::select(node,ratio)

#consider SSP2, million people
country_gdp = read.csv('input/OECD_SSP_GDP_PPP.csv', stringsAsFactors = F) %>%
  filter(Country_Name %in% c('Afghanistan', 'India','Pakistan')) %>%
  filter(grepl('SSP2',Scenario)) %>%
  dplyr::select(Region,X2020) %>% rename(node = Region)

# scale with population
gdp_ratio = pid_pop_gdp %>% mutate(node = gsub('_.*','',PID)) %>%
  filter(year == 2020, node != 'CHN') %>%
  group_by(node) %>%
  summarise(basin_gdp = sum(total_gdp)) %>% ungroup() %>%
  left_join(country_gdp) %>%
  mutate(X2020 = X2020 * 1e9, ratio = basin_gdp / X2020) %>%
  dplyr::select(node,ratio)

imp_exp_avg = imp_exp.df %>% left_join(map_country) %>%
  left_join(map_crop) %>%
  dplyr::select(node,crop,imp_exp,value) %>%
  left_join(pop_ratio) %>%
  mutate(value = value * ratio ) %>%
  mutate(imp_exp = tolower(imp_exp)) %>%
  dplyr::select(-ratio)

write.csv(imp_exp_avg, paste0(getwd(), '/input/land_maps_crop_yields/FAO_prices/basin_crop_import_export.csv'), row.names = F )


#NEON core-scale cross-validation data prep + calibration fits.
#Fit dirlichet models to all groups of bacteria from 95% of Tedersoo observations (for comparability).
#Not going to apply hierarchy, because it would not be a fair comparison to the Tedersoo model.
#Missing data are allowed.
#clear environment
rm(list = ls())
library(data.table)
library(doParallel)
source('paths.r')
source('paths_fall2019.r')
source('NEFI_functions/crib_fun.r')
source('NEFI_functions/tic_toc.r')

library(RCurl)
# source function from colins github
script <- getURL("https://raw.githubusercontent.com/colinaverill/NEFI_microbe/master/NEFI_functions/ddirch_site.level_JAGS.r", ssl.verifypeer = FALSE)
#script <- gsub("if(is.na(x_sd))", )
eval(parse(text = script))

# source Colin's paths.r
script <- getURL("https://raw.githubusercontent.com/colinaverill/NEFI_microbe/master/paths.r", ssl.verifypeer = FALSE)
eval(parse(text = script))

#detect and register cores.----
n.cores <- detectCores()
n.cores <- 16
registerDoParallel(cores=n.cores)

#set output path.----
output.path <- core.CV_NEON_ddirch_16S_JAGSfit
calval_data.path <- core.CV_NEON_cal.val_data_16S.path

#load NEON core-scale data.----
dat <- readRDS(hierarch_filled_data.path)
dat <- lapply(dat, function(x) x[!(names(x) %in% c("pH", "conifer"))])
dat <- lapply(dat, function(x) setnames(x, old = "pH_water", new = "pH", skip_absent = TRUE))
#pl.truth <- readRDS(NEON_all.phylo.levels_plot.site_obs_fastq_1k_rare.path) #this has the plot and site values for NEON.
y <- readRDS(NEON_16S_phylo_fg_abundances.path)
map <- readRDS(core_obs.path)

#get core/plot/site-level covariate means.----
core_mu <- dat$core.core.mu
plot_mu <- dat$plot.plot.mu
site_mu <- dat$site.site.mu

#merge together.
plot_mu$siteID <- NULL
core.preds <- merge(core_mu   , plot_mu)
core.preds <- merge(core.preds, site_mu)
core.preds$relEM <- NULL
names(core.preds)[names(core.preds)=="b.relEM"] <- "relEM"

#get core/plot/site-level covariate SD.
core_sd <- dat$core.core.sd
plot_sd <- dat$plot.plot.sd
site_sd <- dat$site.site.sd
#merge together.
plot_sd$siteID <- NULL
core.sd <- merge(core_sd   , plot_sd)
core.sd <- merge(core.sd, site_sd)
core.sd$relEM <- NULL
names(core.sd)[names(core.sd)=="b.relEM"] <- "relEM"

#Split into calibration / validation data sets.----
set.seed(420)
ID <- rownames(y$phylum$abundances)
cal.ID <- sample(ID, round(length(ID)/ 2))
cal.ID <- cal.ID[cal.ID %in% core.preds$deprecatedVialID]
val.ID <- ID[!(ID %in% cal.ID)]
val.ID <- val.ID[val.ID %in% core.preds$deprecatedVialID]

#loop through y values. Wasn't an easy way to loop through levels of list.
y.cal <- list()
y.val <- list()
for(i in 1:length(y)){
  lev <- y[[i]]
  lev.cal <- list()
  lev.val <- list()
  lev.cal$abundances <- lev$abundances[rownames(lev$abundances) %in% cal.ID,]
  lev.val$abundances <- lev$abundances[rownames(lev$abundances) %in% val.ID,]
  lev.cal$rel.abundances <- lev$rel.abundances[rownames(lev$rel.abundances) %in% cal.ID,]
  lev.val$rel.abundances <- lev$rel.abundances[rownames(lev$rel.abundances) %in% val.ID,]
  lev.cal$seq_total <- lev$seq_total[names(lev$seq_total) %in% cal.ID]
  lev.val$seq_total <- lev$seq_total[names(lev$seq_total) %in% val.ID]
  lev.cal$group_frequencies <- lev$group_frequencies
  lev.val$group_frequencies <- lev$group_frequencies
  #return to larger list.
  y.cal[[i]] <- lev.cal
  y.val[[i]] <- lev.val
}
names(y.cal) <- names(y)
names(y.val) <- names(y)

#split x means and sd's.
x_mu.cal <- core.preds[core.preds$deprecatedVialID %in% cal.ID,]
x_mu.val <- core.preds[core.preds$deprecatedVialID %in% val.ID,]
x_sd.cal <- core.sd   [core.sd   $deprecatedVialID %in% cal.ID,]
x_sd.val <- core.sd   [core.sd   $deprecatedVialID %in% val.ID,]

#match the order.
x_mu.cal <- x_mu.cal[order(match(x_mu.cal$deprecatedVialID, rownames(y.cal$phylum$abundances))),]
x_sd.cal <- x_sd.cal[order(match(x_sd.cal$deprecatedVialID, rownames(y.cal$phylum$abundances))),]
x_mu.val <- x_mu.val[order(match(x_mu.val$deprecatedVialID, rownames(y.val$phylum$abundances))),]
x_sd.val <- x_sd.val[order(match(x_sd.val$deprecatedVialID, rownames(y.val$phylum$abundances))),]

#subset to predictors of interest, drop in intercept.----
rownames(x_mu.cal) <- rownames(y.cal$phylum$abundances)
intercept <- rep(1, nrow(x_mu.cal))
x_mu.cal <- cbind(intercept, x_mu.cal)
#x_mu.cal <- x_mu.cal[,c('intercept','pH','pC','cn','relEM','map','mat','NPP','forest','ndep.glob')]
#x_mu.cal <- x_mu.cal[,c('intercept','pH','pC','cn','relEM','map','mat','NPP')]
x_mu.cal <- x_mu.cal[,c('intercept','pH','relEM','map','mat','NPP')]

#save calibration/valiation data sets.----
dat.cal <- list(y.cal, x_mu.cal, x_sd.cal)
dat.val <- list(y.val, x_mu.val, x_sd.val)
names(dat.cal) <- c('y.cal','x_mu.cal','x_sd.cal')
names(dat.val) <- c('y.val','x_mu.val','x_sd.val')
dat.out <- list(dat.cal, dat.val)
names(dat.out) <- c('cal','val')
saveRDS(dat.out, calval_data.path)

#fit model using function in parallel loop.-----
#for running production fit on remote.
cat('Begin model fitting loop...\n')
tic()
output.list<-
  foreach(i = 1:length(y)) %dopar% {
    y.group <- y.cal[[i]]
    y.group <- y.group$abundances
    y.group <- y.group + 1
    y.group <- y.group/rowSums(y.group)
    fit <- site.level_dirlichet_jags(y=y.group,x_mu=x_mu.cal, x_sd=x_sd.cal,
                                     adapt = 30001, burnin = 10002, sample = 5003,
                                     #adapt = 100, burnin = 100, sample = 100,   #testing
                                     parallel = T, parallel_method = 'parallel')
    return(fit)                                                                     #allows nested loop to work.
  }
cat('Model fitting loop complete! ')
toc()

#name the items in the list
names(output.list) <- names(y.cal)

#save output.----
cat('Saving fit...\n')
saveRDS(output.list, output.path)
cat('Script complete. \n')


# Seattle Public Data Heatmap
# Mark Delcambre
#
#
# Code significantly based on Myles Harrison Toronto Camera Heat Map
# http://www.everydayanalytics.ca

# Import the necessary libraries.
# MASS is imported for the 2d kde for the heatmap
# RgoogleMaps is imported for the plotting of the map on google maps
# RColorBrewer is used for the coloring of the heat map.
library(MASS)
library(RgoogleMaps)
library(RColorBrewer)
library(scales)

# Title wrapping helper function
titlewrap <- function(x, ...) paste(strwrap(x, ...), collapse = "\n")

# Download the relevant Seattle Public Data into the data directory
if(!file.exists("data")){
    dir.create("data")
}
file_url <- "https://data.seattle.gov/api/views/3k2p-39jp/rows.csv?accessType=DOWNLOAD"
file_loc <- "./data/seattle_911_police_response.csv"
if(!file.exists(file_loc)){
    download.file(file_url,destfile=file_loc,method="curl")
    cat("## Date Downloaded", as.character(Sys.Date()),'\n',file=file_loc,append=T)
}

# Setup the output folder for the images we are plotting
if(!file.exists("output")){
    dir.create("output")
}

# Read the file into memory, last I checked this file is about 200 MB. May need to start subsampling
data <- read.csv(file=file_loc, header=T, comment.char="#", na.strings = "NULL", skipNul=T, stringsAsFactors=F)

# Clean up the dataset, remove leading and trailing white space and remove empty location data.
data[["Event.Clearance.Group"]] <- as.factor(gsub("^\\s+|\\s+$", "",data[["Event.Clearance.Group"]]))
data[["Event.Clearance.Description"]] <- as.factor(gsub("^\\s+|\\s+$", "",data[["Event.Clearance.Description"]]))
data <- data[complete.cases(data["Latitude"],data["Longitude"]),]

# Center for the Google Map
center <- sapply(c(data["Latitude"],data["Longitude"]),function(x) (max(x)+min(x))/2)

# Setup the Google map centered on all data.
map <- GetMap(center=center, SCALE=2, zoom=11)

# Hard coded limits to make all of the kernel densities cover the same area.
lims <- matrix(c(range(data$Latitude),range(data$Longitude)),nrow=2)
lims <- unlist(LatLon2XY.centered(map, lims[,1],lims[,2]))

# Setup Colors from Green to Red.
# Add transparency
colors <- rev(colorRampPalette(brewer.pal(8, 'RdYlGn')(16)))
colors_a <-alpha(colors,0.5)

# Loop through each of the crime categories. Create a heatmap for each one and save them as a new png file.
for (crime in levels(data[["Event.Clearance.Description"]])){

    # Create temporary data frame with only the crime of interest
    data_temp <- data[data[["Event.Clearance.Description"]] %in% crime,]

    if (length(data_temp$Longitude)==0) { next } # if no values, skip no next
    if (crime == "" | crime == "NULL") {next } # skip the two null sets

    # Open file png file, escape name, ideal for unix machines, will still break on windows.
    crime = gsub("([/])","-", crime)
    png(paste("output/Seattle Police 911_",crime,".png",sep=""), width = 1280, height = 1280)

    # Transform Cords for Google Map Plotting
    coords <- LatLon2XY.centered(map, data_temp$Latitude, data_temp$Longitude)
    coords <- data.frame(coords)

    # Generate the kernel density map for the heatmap
    kd <- kde2d(coords$newX, coords$newY, n=500, lims=lims)

    # Plot the map, heatmap, and points
    PlotOnStaticMap(map)
    points(coords$newX, coords$newY, pch=16, cex=0.3)
    image(kd, col=colors_a, add=T)

    title(main=titlewrap(crime,20), cex.main=3, line=-85.5, col.main="black")
    title(main=paste("n =",length(data_temp$Longitude)), cex.main=0.75, line=-86.5)

    # Save and close out the file
    dev.off()
}


set.seed(18231)

x <- c(raphylo(20), raphylo(10, P = 2))
y <- c(x[[1]]$tree, x[[2]]$tree)
z <- new_aphylo_pruner(x)

res0 <- aphylo_mle(x ~ psi + mu_d + mu_s + Pi)

expect_equal(Ntip(x), c(20, 10))
expect_equal(Ntip(y), c(20, 10))
expect_equal(Ntip(res0), c(20, 10))
expect_equal(Ntip(z), c(20, 10))

expect_equal(Nnode(x), c(19, 9))
expect_equal(Nnode(y), c(19, 9))
expect_equal(Nnode(res0), c(19, 9))
expect_equal(Nnode(z), c(19, 9))

expect_equal(Nann(x), c(1, 2))
expect_equal(Nann(res0), c(1, 2))
expect_equal(Nann(z), c(1, 2))

expect_equal(Nannotated(x), c(20, 10))
expect_equal(Nannotated(res0), c(20, 10))
expect_equal(Nannotated(z), c(20, 10))

expect_equal(Ntrees(x), 2)
expect_equal(Ntrees(y), 2)
expect_equal(Ntrees(res0), 2)
expect_equal(Ntrees(z), 2)


#write up a version of FindAllWithinError for R
#based on SimStitch code, modified in 2007 to find all mz values within the error set
#KLongnecker, 23 August 2017
FindAllWithinError <- function(oneList,maxErr,target)

##to run this...do this in the console:
#source("FindAllWithinError.r")
#r <- FindAllWithinError(oneList,maxErr,target)

# oneList <- peakTable$mzmed
# maxErr <- 1
# #target <- 196.076276
# target <- 172.9564
{
#sort input list
inputList <- sort(oneList)
idxSortInput <- sort(oneList,index.return=TRUE)$ix

if (length(target)==1) {
  ti <- 1
  } else {
  stop('This version only handles one mz value')}

e = abs((inputList - target[ti])/target[ti])
ii <- which(e <=maxErr/1e6)

FindAllWithinError <- idxSortInput[ii]
}


library(raster)
library(rgdal)
# Merging CCI types:
# Crops: 10 (Cropland rainfed), 11 (Cropland rainfed - Herbaceous cover), 12 (Cropland rainfed - Tree or shrub cover),
#        20 (Cropland irrigated or post-flooding),
#        30 (Mosaic cropland (>50%) / natural vegetation (tree/shrub/herbaceous cover) (<50%))
# Deciduous trees: 60 (Tree cover  broadleaved  deciduous  closed to open (>15%)),
#                  61 (Tree cover  broadleaved  deciduous  closed (>40%)),
#                  62 (Tree cover  broadleaved  deciduous  open (15-40%)),
#                  80 (Tree cover  needleleaved  deciduous  closed to open (>15%)),
#                  81 (Tree cover  needleleaved  deciduous  closed (>40%)),
#                  82 (Tree cover  needleleaved  deciduous  open (15-40%)),
#                  90 (Tree cover  mixed leaf type (broadleaved and needleleaved))
# Evergreen trees: 50 (Tree cover broadleaved evergreen closed to open (>15%)),
#                  70 (Tree cover  needleleaved  evergreen  closed to open (>15%)),
#                  71 (Tree cover  needleleaved  evergreen  closed (>40%))
#                  72 (Tree cover  needleleaved  evergreen  open (15-40%))
# Shrublands: 100 (Mosaic tree and shrub (>50%) / herbaceous cover (<50%)), 120 (Shrubland), 121 (Shrubland evergreen),
#             122 (Shrubland deciduous)
# Grasslands: 130 (Grassland), 140 (Lichens and mosses), 110 (Mosaic herbaceous cover (>50%) / tree and shrub (<50%)),
#             40 (Mosaic natural vegetation (tree/shrub/herbaceous cover) (>50%) / cropland (<50%))
# Bare soil: 150 (Sparse vegetation (tree/shrub/herbaceous cover) (<15%)), 152 (Sparse shrub (<15%)),
#            153 (Sparse herbaceous cover (<15%)), 200 (Bare areas), 201 (Consolidated bare areas),
#            202 (Unconsolidated bare areas)
# Wetlands: 160 (Tree cover flooded fresh or brakish water), 170 (Tree cover flooded saline water),
#           180 (Shrub or herbaceous cover flooded fresh/saline/brakish water)
# Urban: 190 (Urban areas)
# Water: 210 (Water bodies)
# Permanent snow or ice: 220 (Permanent snow and ice)

# LC-CCI map, freely available
CCI = raster("../data/ESACCI-LC-L4-LCCS-Map-300m-P5Y-2010-v1.6.1.tif")
# Boundaries of the area of interest (tile X20Y01)
AOI = readOGR("../data/aoi.shp", "aoi")
CCI.crop = crop(CCI, AOI)
# Vectors of 3: range min, range max, overwritten by what
reclassifier = c(
    10, 30, 10,
    60, 62, 60, 80, 90, 60,
    70, 72, 70, 50, 50, 70,
    120, 122, 120, 100, 100, 120,
    130, 140, 130, 40, 40, 130, 110, 110, 130,
    200, 202, 200, 150, 153, 200,
    160, 180, 160)
CCI.simple = reclassify(CCI.crop, reclassifier, right=NA)
writeRaster(CCI.simple, "../data/cci-simplified.tif")
# Grid params: ~20-~30 x, ~55-~65 y; 10/10080 steps
# One grid area is exactly 12196.1127540375
# Create stratified random sample of 1000 points (9 classes since there is no permafrost)
Samples = sampleStratified(CCI.simple, 112, sp=TRUE)
writeOGR(Samples, "samples.gml", "samples", driver="GML")


# script to test for differences in reworking between molina and other members
# Eric Barefoot
# Nov 2019

# load libraries

library(tidyverse)
library(here)
library(broom)
library(lme4)
library(devtools)  # for the next thing
library(colorspace)
library(purrr)
library(rsample)

load_all('/Users/ericfoot/Dropbox/programs/git_repos/paleohydror')

library(conover.test)

if (interactive()) {
    require(colorout)
}

format_function = function(pval, signif = 0.001) {
  if (pval > signif) {
    prep = paste('p =', signif(pval, 3))
  } else {
    prep = paste('p \\ll', signif)
  }
  return(prep)
}

# load data

# chamb_data = readRDS(file = here('data','derived_data', 'chamberlin_model_data.rds'))
# chamb_model = readRDS(file = here('data','derived_data', 'chamberlin_stat_model.rds'))
model = readRDS(file = here('data','derived_data','piceance_3d_model_data.rds'))
field = readRDS(file = here('data','derived_data','piceance_field_data.rds'))
combined = readRDS(file = here('data', 'derived_data', 'piceance_field_model_data.rds'))
# barpres = readRDS(file = here('data', 'derived_data', 'piceance_bar_preservation.rds'))

field_depths = field %>% filter(structure %in% c('bar','channel') & meas_type %in% c('thickness', 'dimensions')) %>% mutate(meas_a = case_when(meas_type == 'thickness' ~ meas_a, meas_type == 'dimensions' ~ meas_b), formation = as.factor(formation))

# quick hypothesis test since these are normally distributed.

depths = field_depths$meas_a
formations = field_depths$formation

fit = conover.test(depths, formations, method = 'bonferroni', table = 'false', kw = 'false')
# fit = conover.test(depths, formations, method = 'bonferroni')

p_comp_AG_M = format_function(fit$P[1])
p_comp_AG_S = format_function(fit$P[2])
p_comp_S_M = format_function(fit$P[3])

depth_summary = field_depths %>% group_by(formation) %>% summarize(meanDepth = mean(meas_a), sdDepth = sd(meas_a))

model_depths = model %>% filter(interpretations %in% c('full'))

all_depths = bind_rows(field_depths, model_depths, .id = 'data_source') %>% mutate(data_source = recode(.$data_source, `1` = 'field', `2` = 'model'))

all_depths = all_depths %>% mutate(formID = case_when(formation == 'ohio_creek' ~ 3, formation == 'atwell_gulch' ~ 2, formation == 'molina' ~ 1, formation == 'shire' ~ 0))

bedloadSamples = field %>%
filter(meas_type == 'sample' & !(structure %in% c('outcrop', 'formation', 'bar_drape')) & meas_a < 2000) %>%
mutate(D50 = meas_a * 1e-6) %>%
mutate(formID = case_when(
  formation == 'ohio_creek' ~ 3,
  formation == 'atwell_gulch' ~ 2,
  formation == 'molina' ~ 1,
  formation == 'shire' ~ 0))

samples_for_slope = bedloadSamples %>% select(set_id, D50, textures, composition, samp_ind, samp_code, samp_description)
depths_for_slope = all_depths %>% filter(data_source == 'field') %>% select(-c(textures, composition, samp_ind, samp_code, samp_description))

paleohydroset = inner_join(samples_for_slope, depths_for_slope, by = 'set_id') %>%
mutate(S = trampush_slp(D50, meas_a), tau = (1000 * 9.8 * meas_a * S), taustar = tau / (1065 * 9.8 * D50), Rep = Rep(D50, (1650 / 1000), 9.8, 1.004e-6))

# slope tests

slopes = paleohydroset$S
formations = paleohydroset$formation

fit_slope = conover.test(slopes, formations, method = 'bonferroni', table = 'false', kw = 'false')
# fit_slope = conover.test(slopes, formations, method = 'bonferroni')
# fit_tau = conover.test(paleohydroset$taustar, formations, method = 'bonferroni')

p_comp_AG_M_slope = format_function(fit_slope$P[1])
p_comp_AG_S_slope = format_function(fit_slope$P[2])
p_comp_S_M_slope = format_function(fit_slope$P[3])

slope_summary = paleohydroset %>% group_by(formation) %>% summarize(meanSlope = mean(S), sdSlope = sd(S))

tau_summary = paleohydroset %>% group_by(formation) %>% summarize(meanTau = mean(taustar), sdTau = sd(taustar))

geoms = inner_join(slope_summary, depth_summary, by = 'formation')
geoms = inner_join(geoms, tau_summary, by = 'formation')

# calculating abundance of different avulsion types

avuls = field %>% filter(structure == 'avulsion') %>%
# avuls = field %>% filter(set_id == 'EHAJEKA', structure == 'avulsion') %>%
# avuls = field %>% filter(set_id == 'FORMANA', structure == 'avulsion') %>%
select(formation, interpretations) %>%
transmute(formation = case_when(
  formation == 'molina' ~ 'molina',
  TRUE ~ 'bounding'),
  interp = interpretations
)

avultest = chisq.test(table(avuls))

p_comp_avulsion = format_function(avultest$p.value)

# find out how many new data points we have.

ndata = field_depths %>% mutate(mine = ifelse(set_id == 'FORMANA', 'no', 'yes')) %>% group_by(mine) %>% summarize(n = n()) %>% pull(n)

nold = ndata[1]
nnew = ndata[2]

save(nold,
  nnew,
  p_comp_AG_M_slope,
  p_comp_AG_S_slope,
  p_comp_S_M_slope,
  p_comp_AG_M,
  p_comp_AG_S,
  p_comp_S_M,
  p_comp_avulsion,
  avultest,
  geoms,
  file = here('data', 'data_summaries', 'paleo_geom.rda'))


#!/usr/bin/Rscript

library(suncalc)
#cat(getSunlightTimes(date = Sys.Date(), lat = 32.896244, lon = -117.242651, tz = "")$sunset)
#cat(format((getSunlightTimes(date = Sys.Date(), lat = 32.896244, lon = -117.242651, tz = "")$sunset),'%Y%m%d%H%M'))
cat(format((getSunlightTimes(date = Sys.Date(), lat = 32.896244, lon = -117.242651, tz = "")$sunrise),'%Y-%m-%d %H:%M:%S %Z'))


data_path <- "/home/jgong/gongj_snoRNA/database_data/CNV_data"

file_name <- list.files(data_path, "_snoRNA_TCGA_CNV_20161216.match")
library(tidyverse)
library(stringr)

get_cnv<- function(x){
  name <- str_replace(x, "_.*", "")
  dataset_id <- paste("TCGA", name, sep='-')

  data <- read_tsv(file.path(data_path, x))
  type <- str_sub(colnames(data),14,14)
  col_name <- str_sub(colnames(data),1,12)
  col_name[type=="1"] = paste(name,"Normal", col_name[type=="1"], sep="-")
  col_name[type=="0"] = paste(name,"Tumor", col_name[type=="0"], sep="-")

  colnames(data) <- col_name

  data %>%
    subset(select = which(!duplicated(colnames(.)))) %>%
    mutate(dataset_id, dataset_id) %>%
    gather(sample_id, copy, -c(cnv, dataset_id))

}

file_name %>%
  lapply(get_cnv) %>%
  bind_rows() %>%
  write_tsv(path = "/home/cliu18/liucj/projects/4.SNORic/database/cna/cna.tsv", col_names = F)


#!/usr/bin/env Rscript
source("common.r")

checkDuckdiveParams <- function(f) {
    checkDuckdive <- 0
    if (!(parameters$parameters$dThresholdDirection == "above" | parameters$parameters$dThresholdDirection == "below")) {
        write("Error: dThreshold direction should either be above or below",stderr())
    } else if (parameters$parameters$dThreshold>1 | parameters$parameters$dThreshold < 0) {
        write("Error: dThreshold should lie within 0 and 1",stderr())
    } else if (parameters$parameters$lowThX>1 | parameters$parameters$lowThX < 0) {
        write("Error: lowThX should lie within 0 and 1",stderr())
    } else if (parameters$parameters$hiThX>1 | parameters$parameters$hiThX < 0) {
        write("Error: hiThX should lie within 0 and 1",stderr())
    } else if (parameters$parameters$lowThZ>1 | parameters$parameters$lowThZ < 0) {
        write("Error: lowThZ should lie within 0 and 1",stderr())
    } else if (parameters$parameters$hiThZ>1 | parameters$parameters$hiThZ < 0) {
        write("Error: hiThZ should lie within 0 and 1",stderr())
    } else {
        checkDuckdive <- 1
    }
    return (checkDuckdive)

}
findDuckdive <- function(panel,parameters){

    # panel <- as.numeric(as.character(panel))
    write("Calculating entropy",stderr())

    panel$`acceleration:z`<- as.numeric(as.character(panel$`acceleration:z`))
    panel$`acceleration:x`<- as.numeric(as.character(panel$`acceleration:x`))
    panel$`rotationrate:y`<- as.numeric(as.character(panel$`rotationrate:y`))

    dEntropy <- findSpecEntropy(panel$`acceleration:x`,
                                parameters$windowSize,
                                parameters$overlapStep,
                                1)

    write("Calculating event labels",stderr())
    duckdive <- getEvent(       panel$`acceleration:x`,
                                dEntropy$Entropy,
                                parameters$dThresholdDirection,
                                parameters$dThreshold,
                                parameters$windowSize)

    duckdiveNew <- getDive(     duckdive,
                                panel$`acceleration:x`,
                                panel$`rotationrate:y`,
                                panel$`acceleration:z`,
                                parameters$lowThX,
                                parameters$hiThX,
                                parameters$lowThZ,
                                parameters$hiThZ,
                                parameters$minLengthX,
                                parameters$varLength,
                                parameters$minLengthZ)

    write("Calculating the time stamps of the duckdive labels",stderr())
    dOutLabels <- outputLabels( duckdiveNew$duckdive,
                                parameters$windowSize,
                                panel$time,
                                parameters$dMergeThreshold)

    write("Converting results to JSON", stderr())

    results <- list()
    if ( dOutLabels$startTime == 0 && dOutLabels$endTime == 0 ) {
        results <- vector()
    }
    else {
        for (i in 1:length(dOutLabels$startTime)) {
            labelList<-list(
                startTime=unbox(dOutLabels$startTime[i]),
                endTime=unbox(dOutLabels$endTime[i]),
                type=unbox(parameters$eventType))
            results <- append(results, list(labelList)) # Convert to list objects
        }
    }

    return (results)
}

getDive <- function(duckdive,accX,rotY,accZ,lowThX,hiThX,lowThZ,hiThZ,minLengthX,varLength,minLengthZ) {
    transList <- findTransition(duckdive)
    wStartTimes <- transList$wStartTimes
    wEndTimes <- transList$wEndTimes

    duckdiveNew <- rep(0,length(duckdive))

    for (i in 1:length(wStartTimes)) {

        FrameZ<-accZ[wStartTimes[i]:wEndTimes[i]]
        FrameX<-rotY[wStartTimes[i]:wEndTimes[i]]*accX[wStartTimes[i]:wEndTimes[i]]
        #FrameZ<-accZ[wStartTimes[i]:wEndTimes[i]]

        minAccX<-min(accX[wStartTimes[i]:wEndTimes[i]])
        maxAccX<-max(accX[wStartTimes[i]:wEndTimes[i]])

        maxAccZ<-max(accZ[wStartTimes[i]:wEndTimes[i]])
        minAccZ<-min(accZ[wStartTimes[i]:wEndTimes[i]])

        minRotY<-min(rotY[wStartTimes[i]:wEndTimes[i]])
        maxRotY<-max(rotY[wStartTimes[i]:wEndTimes[i]])

        minFrameX<-min(FrameX)
        maxFrameX<-max(FrameX)

        accBlwThresh2<-0
        accAbvThresh<-0
        accAbvThresh2<-0
        #print(minAccX)
        accNeg<-length(which(accX[wStartTimes[i]:wEndTimes[i]]<(0)))/(wEndTimes[i]-wStartTimes[i])
        #accPos<-length(which(accX[wStartTimes[i]:wEndTimes[i]]>(5)))/(wEndTimes[i]-wStartTimes[i])

        if (minAccX < 0 & length(which(FrameZ>50))<4 & accNeg>0 & maxRotY>0 & minRotY <0) {
            lowX<-(lowThX*minFrameX) #0.4
            HighX<-(hiThX*maxFrameX) #0.3

            lowZ<- (lowThZ*maxAccZ) #0.3
            HighZ<- (hiThZ*maxAccZ) #0.5

            FrameX[which(FrameX>lowX & FrameX<HighX)]<- 0
            FrameX[which(FrameX<=lowX)]<- -1
            FrameX[which(FrameX>=HighX)]<- 1

            FrameZ[which(FrameZ<=lowZ)]<- -1
            FrameZ[which(FrameZ>lowZ & FrameZ<HighZ)]<- 0
            FrameZ[which(FrameZ>=HighZ)]<- 1

            diffX<- append(0,diff(FrameX,1))
            indices<-which(diffX==1 & FrameX==0)
            indices1<-which(diffX==1 & FrameX==1)
            #print("indices")
            #print(indices)
            #print(indices1)
            trans<-0

            if (length(indices)>0 & length(indices1)>0) {
                for (ind in 1:length(indices)) {
                    #print(indices[ind])
                    trans<-which(indices1>indices[ind])[1]
                    #print(trans)
                    if (!(is.na(trans)) & (indices1[trans]-indices[ind])>minLengthX & indices1[trans]>varLength & indices[ind]>varLength) { #minLengthX 30, varLength 10, minLengthZ 20
                        if (length(which(FrameZ[indices[ind]:indices1[trans]]==0)>minLengthZ) &
                            length(which(FrameZ[(indices[ind]-varLength):(indices[ind]+varLength)]==1)) > 0 &
                            length(which(FrameZ[(indices1[trans]-varLength):(indices1[trans]+varLength)]==-1)) > 0) {
                                duckdiveNew[wStartTimes[i]:wEndTimes[i]]<-1
                        }
                    }
                    trans<-0
                }
            }
        }
    }

    duckdiveNew<-list(duckdive=duckdiveNew)#,sit=sit)
    return(duckdiveNew)
}


library(tm)
library(wordcloud)
function(input, output) {

  # Make the wordcloud drawing predictable during a session
  wordcloud_rep <- repeatable(wordcloud)
  output$plot1 <- renderPlot({

    wordcloud_rep( some_txt_corpus, scale=c(4,0.5),
                   min.freq = input$freq, max.words=input$max,random.order=FALSE,
                   colors=brewer.pal(8, "Dark2"))

  })
  output$plot2 <- renderPlot({

    dtm <- DocumentTermMatrix(some_txt_corpus)
    m <- as.matrix(dtm)
    v <- sort(colSums(m),decreasing=TRUE)
    x <- head(v, 4)
    barplot(x,col = "pink",main ="Most frequent words ",
            ylab = "Word frequencies",ylim = c(0, 600))

  })
  output$plot3 <- renderPlot({
    dtm <- DocumentTermMatrix(some_txt_corpus)
    m <- as.matrix(dtm)
    v <- sort(colSums(m),decreasing=TRUE)
    a <- head(v,10)
    b <-tidyr::extract_numeric(a)
    K <- as.matrix(b[1:3])
    a1 <- colSums(K)
    a2 <- b[4]
    p <- c(a1,a2)
    barplot(p, main = "voteleave v|s remain",  ylab = "FREQUENCY", xlab = "",
            ylim = c(0, 2000), names.arg = c("voteleave", "remain"))
  })
  output$plot4 <- renderPlot({
    barplot(ap_dtm[1,],col = "pink",main ="Sentiment for #brexit:Remain",
            ylab = "sentiment",names.arg = c("negative", "positive","overall sentiment"),ylim = c(-100, 500))
  })
  output$plot5 <- renderPlot({
    barplot(ap_dtm[2,],col = "pink",main ="Sentiment for #brexit:Voteleave ",
            ylab = "sentiment",names.arg = c("negative", "positive","overall sentiment"),ylim = c(-100, 500))
  })
}


#' compass_16
#'
#' Calculate the wind sector (16 partition) provenience.
#'
#' @param direction numeric   Directions in degrees from the North.
#' @return sector character
#'
#'
#' @author    Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#'
#' @export
#'
#'
#'
#'

compass_16=function(direction) {
                         ct$assign("direction", as.array(direction))
                         ct$eval("var res=[]; for(var i=0, len=direction.length; i < len; i++){ res[i]=compass_16(direction[i])};")
                        res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


# Adopted from GSEA R package (GSEA.Gct2Frame2), read the GCT file
readGCT <- function(filename = "NULL") {
      content <- readLines(filename)
      content <- content[-1]
      content <- content[-1]
      col.names <- noquote(unlist(strsplit(content[1], "\t")))
      col.names <- col.names[c(-1, -2)]
      num.cols <- length(col.names)
      content <- content[-1]
      num.lines <- length(content)

      row.nam <- vector(length=num.lines, mode="character")
      #row.des <- vector(length=num.lines, mode="character")
      m <- matrix(0, nrow=num.lines, ncol=num.cols)

      for (i in 1:num.lines) {
         line.list <- noquote(unlist(strsplit(content[i], "\t")))
         row.nam[i] <- noquote(line.list[1])
         #row.des[i] <- noquote(line.list[2])
         line.list <- line.list[c(-1, -2)]
         for (j in 1:length(line.list)) {
            m[i, j] <- as.numeric(line.list[j])
         }
      }
      ds <- data.frame(m)
      names(ds) <- col.names
      row.names(ds) <- row.nam
      return(ds)
}

readGMT <- function (filename = "NULL") {
	temp = readLines (filename)
	max.Ng <- length(temp)
	gs = list()
	for (i in 1:max.Ng) {
		line = unlist(strsplit(temp[[i]], "\t"))
		name = make.names(line[1])
		line = line [-1]
		line = line [-1] # desc
		gs[[name]] = line

	}

	return (gs)
}

# Calculate ES score, adopted from GSEA R package (GSEA.EnrichmentScore)
EnrichmentScore <- function(gene.list, gene.set, weighted.score.type = {{args.weightexp}}, correl.vector = NULL) {
	tag.indicator <- sign(match(gene.list, gene.set, nomatch=0))    # notice that the sign is 0 (no tag) or 1 (tag)
	no.tag.indicator <- 1 - tag.indicator
	N <- length(gene.list)
	Nh <- length(gene.set)
	Nm <-  N - Nh
	if (weighted.score.type == 0) {
		correl.vector <- rep(1, N)
	}
	alpha <- weighted.score.type
	correl.vector <- abs(correl.vector**alpha)
	sum.correl.tag    <- sum(correl.vector[tag.indicator == 1])
	norm.tag    <- 1.0/sum.correl.tag
	norm.no.tag <- 1.0/Nm
	RES <- cumsum(tag.indicator * correl.vector * norm.tag - no.tag.indicator * norm.no.tag)
	max.ES <- max(RES)
	min.ES <- min(RES)
	if (is.na(max.ES) || is.na(min.ES)) {
		return(list(ES = 0, arg.ES = 1, RES = RES, indicator = tag.indicator))
	}
	if (max.ES > - min.ES) {
	#      ES <- max.ES
		ES <- signif(max.ES, digits = 5)
		arg.ES <- which.max(RES)
	} else {
	#      ES <- min.ES
		ES <- signif(min.ES, digits=5)
		arg.ES <- which.min(RES)
	}
	return(list(ES = ES, arg.ES = arg.ES, RES = RES, indicator = tag.indicator))
}

ESPlot = function (es, gs, outprefix) {
	for (gset in names(es)) {
		png (filename = paste (outprefix, make.names(gset), ".png", sep="", collapse = ""), type="cairo")
		esret = es [[gset]][[1]]
		N = length(esret$indicator)
		sub.string <- paste("Number of genes: ", N, " (in list), ", length(gs[[gset]]), " (in gene set)", sep = "", collapse="")

		main.string <- paste("Gene Set: ", gset)
		minRES = min (esret$RES)
		maxRES = max (esret$RES)
		if (is.na(maxRES) || maxRES < 0.3) maxRES <- 0.3
		if (is.na(minRES) || minRES > -0.3) minRES <- -0.3
		delta <- (maxRES - minRES)*.5
		minplot <- minRES - delta
		maxplot <- maxRES
		col <- ifelse(esret$ES > 0, 2, 4)
		plot(1:N, esret$RES, main = main.string, sub = sub.string, xlab = "Gene List Index", ylab = "Running Enrichment Score (RES)", xlim=c(1, N), ylim=c(minplot, maxplot), type = "l", lwd = 2, cex = 1, col = col)

		rect (0, minplot, N, minplot + 0.5*delta, col=rgb(255, 250, 230, maxColorValue=255), border=NA, lwd=0)
		lines(c(1, N), c(0, 0), lwd = 1, lty = 2, cex = 1, col = 1) # zero RES line
		lines(c(esret$arg.ES, esret$arg.ES), c(minplot, maxplot), lwd = 1, lty = 3, cex = 1, col = col) # max enrichment vertical line
		for (j in 1:N) {
			if (esret$indicator[j] == 1) {
				lines(c(j, j), c(minplot, minplot + 0.5*delta), lwd = 1, lty = 1, cex = 1, col = 1)  # enrichment tags
			}
		}

		adjx <- ifelse(esret$ES > 0, 0, 1)

		leg.txt <- paste("Peak at ", esret$arg.ES, sep="", collapse="")
		text(x=esret$arg.ES, y=minplot + 1.8*delta, adj = c(adjx, 0), labels=leg.txt, cex = 1.0)
		dev.off()
	}
}

NPvalPlot = function (es, outprefix) {
	Ns = length(es[[1]])
	NESret = vector (length = 0, mode = "numeric")
	for (gset in names(es)) {
		png (filename = paste (outprefix, make.names(gset), ".png", sep="", collapse = ""), type="cairo")
		esrets = es [[gset]]
		nes = esrets[[1]]$ES / mean (esrets[[1]]$RES[esrets[[1]]$RES > 0])
		NESret = c (NESret, nes)
		if (esrets[[1]]$ES < 0) {
			nes = - esrets[[1]]$ES / mean (esrets[[1]]$RES[esrets[[1]]$RES < 0])
		}
		#sub.string <- paste("ES =", signif(esrets[[1]]$ES, digits = 3), ", NES =", signif(nes, digits=3), ", Nom. p-val=", signif(esrets[[1]]$p, digits = 3), ", FDR=", signif(esrets[[1]]$q, digits = 3), sep="", collapse="")
		sub.string <- paste("ES =", signif(esrets[[1]]$ES, digits = 3), ", NES =", signif(nes, digits=3), ", Nom. p-val=", signif(esrets[[1]]$p, digits = 3), sep="", collapse="")

		phi = vector (length = Ns, mode = "numeric")
		for (i in 1:Ns) {
			phi[i] = esrets[[i]]$ES
		}

		temp <- density(phi, adjust=.5)
		x.plot.range <- range(temp$x)
		y.plot.range <- c(-0.125*max(temp$y), 1.5*max(temp$y))
		plot(temp$x, temp$y, type = "l", sub = sub.string, xlim = x.plot.range, ylim = y.plot.range, lwd = 2, col = 2, main = "Gene Set Null Distribution", xlab = "ES", ylab="P(ES)")
		x.loc <- which.min(abs(temp$x - esrets[[1]]$ES))
		lines(c(esrets[[1]]$ES, esrets[[1]]$ES), c(0, temp$y[x.loc]), lwd = 2, lty = 1, cex = 1, col = 1)
		lines(x.plot.range, c(0, 0), lwd = 1, lty = 1, cex = 1, col = 1)

		leg.txt <- c("Gene Set Null Density", "Observed Gene Set ES value")
		c.vec <- c(2, 1)
		lty.vec <- c(1, 1)
		lwd.vec <- c(2, 2)
		legend(x=-0.2, y=y.plot.range[2], bty="n", bg = "white", legend=leg.txt, lty = lty.vec, lwd = lwd.vec, col = c.vec, cex = 1.0)
		dev.off()
	}
	return (NESret)
}

ESWithPerm = function (exp, gs, nperm = {{args.nperm}}) {
  exp      = exp[order(-exp[,1]),,drop=F]
  corrVec  = c (exp[,1])

  geneList = rownames(exp)
  ret = list()
  for (gset in names(gs)) {
    ess = vector (length = nperm, mode = "numeric")
    ret[[ gset ]] = vector (length = nperm, mode = "list")
    ret[[ gset ]][[1]] = EnrichmentScore (geneList, gs[[gset]], correl.vector = corrVec)
    ret[[ gset ]][[1]]$hits = geneList[as.logical(ret[[ gset ]][[1]]$indicator)]
    ess[1] = ret[[ gset ]][[1]]$ES
    for (i in 1:(nperm-1)) {
      geneList1 = sample(geneList)
      ret[[ gset ]][[i+1]] = EnrichmentScore (geneList1, gs[[gset]], correl.vector = corrVec)
      #ret[[ gset ]][[i+1]]$hits = geneList1[as.logical(ret[[ gset ]][[i+1]]$tag.indicator)]
      ess[i+1] = ret[[ gset ]][[i+1]]$ES
    }
    #ess.sorted = sort (ess, index.return = T)
    for (i in 1:nperm) {
      if (ess[i] > 0) {
        ret[[ gset ]][[i]]$p = sum (ess >= ess[i]) / nperm
      } else {
        ret[[ gset ]][[i]]$p = sum (ess <= ess[i]) / nperm
      }
    }
  }

  return (ret)
}

AdjustP = function (esp) {
	ret = esp
	for (gset in names(ret)) {
		pvec = vector (length = length(ret[[ gset ]]), mode="numeric")
		for (j in 1:length(ret[[ gset ]])) {
			pvec[j] = ret[[ gset ]][[ j ]]$p
		}
		qs = p.adjust (pvec)
		for (j in 1:length(ret[[ gset ]])) {
			ret[[ gset ]][[ j ]]$q = qs[j]
		}
	}
	return (ret)
}

ExportResult = function (es, nes, outfile) {
	ES   = vector(length = 0, mode = "numeric")
	pval = vector(length = 0, mode = "numeric")
	fdr  = vector(length = 0, mode = "numeric")
	maxI = integer(length = 0)

	for (gset in names(es)) {
		esret = es[[gset]][[1]]
		ES    = c (ES, esret$ES)
		pval  = c (pval, esret$p)
		fdr   = c (fdr, esret$q)
		maxI  = c (maxI, esret$arg.ES)
		Hits  = paste(esret$hits, collapse=",")
	}
	outmat = data.frame (cbind(ES = ES, NES = nes, Pval = pval, Qval = fdr, PeatAt = maxI, Hits=Hits))
	rownames (outmat) = names(es)
	write.table (outmat, outfile, sep= "\t", quote=F, col.names=T, row.names=T)
	#write.table (es, outfile, append=T, sep= "\t", quote=F, col.names=T, row.names=T)
}
seed = {{args.seed}}
if (seed > -1) set.seed(seed)
dir.create("{{o.outdir}}", showWarnings = F, recursive = T)
exp = readGCT("{{i.gctfile}}")
gs  = readGMT("{{i.gmtfile}}")
ess = ESWithPerm(exp = exp, gs = gs)
esq = AdjustP(ess)
ESPlot(es = esq, gs = gs, outprefix = "{{o.outdir}}/RES.")
nes = NPvalPlot(es = esq, outprefix = "{{o.outdir}}/normP.")
ExportResult (es = esq, nes=nes, outfile = "{{o.outdir}}/report.txt")


library(ggplot2)
# library(tidyverse)
library(rlang)
library(plotly)

# Taken from Hadley Wickam Advanced R
cement <- function(...) {
  args <- ensyms(...)
  paste(purrr::map(args, as_string), collapse = " ")
}

# Function to make the bar plot
bar_plot1 <- function(wine_data, x_name="winery", y_name="points", desc=TRUE) {
  # Unquoting variables to use with dplyr functions
  x_name <- sym(x_name)
  y_name <- sym(y_name)
  print(identity(n))

  # Specifying axes titles here
  xaxisKey_bp <- tibble(label = c("Winery", "Region", "Variety"),
                     value = c("winery", "region_1", "variety"))
  x_title <- xaxisKey_bp$label[xaxisKey_bp$value == cement(!!x_name)]

  yaxisKey_bp <- tibble(label = c("Rating", "Price ($)", "Value"),
                     value = c("points", "price", "value_scaled"))
  y_title <- yaxisKey_bp$label[yaxisKey_bp$value == cement(!!y_name)]

  # If the user specifies Highest to Lowest, use this plot
  if (desc==TRUE) {
    # Wrangling and sorting
    new_data <- wine_data %>%
      group_by(!!x_name) %>%
      summarize(rating = mean(!!y_name)) %>%
      arrange(desc(rating)) %>%
      slice(1:20) %>%
      mutate(highlight_flag = ifelse(rating == max(rating), T, F))

    # Plotting wrangled data
    new_plot <- ggplot(new_data, aes(x=reorder(!!x_name, -rating),
                                     rating, fill=highlight_flag)) +
      geom_bar(stat='identity') +
      scale_fill_manual(name = x_name, values=c('lightgrey',"#512888")) +
      scale_y_continuous(limits = c(min(new_data$rating),
                                    max(new_data$rating)),
                         oob=rescale_none) +
      xlab(x_title) +
      ylab(y_title) +
      ggtitle(paste0(y_title, ' by ', x_title)) +
      theme_bw() +
      theme(axis.text.x = element_text(angle=60, hjust=1),
            legend.position = 'none',
            panel.grid.major = element_blank())

    ggplotly(new_plot, tooltip="")

  } else {
    new_data <- wine_data %>%
      group_by(!!x_name) %>%
      summarize(rating = mean(!!y_name)) %>%
      arrange(rating) %>%
      slice(-20:-n()) %>%
      mutate(highlight_flag = ifelse(rating == min(rating), T, F))

    new_plot <- ggplot(new_data, aes(x=reorder(!!x_name, rating), rating,
                                     fill=highlight_flag)) +
      geom_bar(stat='identity') +
      scale_fill_manual(name = x_name, values=c('lightgrey',"#512888")) +
      scale_y_continuous(limits = c(min(new_data$rating),
                                    max(new_data$rating)),
                         oob=rescale_none) +
      xlab(x_title) +
      ylab(y_title) +
      ggtitle(paste0(y_title, ' by ', x_title)) +
      theme_bw() +
      theme(axis.text.x = element_text(angle=60, hjust=1),
            legend.position = 'none',
            panel.grid.major = element_blank())

    ggplotly(new_plot, tooltip="")
  }
}


#!/usr/bin/env r

# Patrick Steadman, Franklandlab 2015

#### 20150817
# unable to get ddply to work when including mouse with the current naming scheme.
# works when mouse not included in melt call

# for watermaze what should be the lm call?

getgroupstat <- function(data, groupvar="genotype",
        comparisonvar=c("targetzone","nontargetzone")
        ){
    "
    Requires:
        plyr, reshape2

    Useful to get summarized data for constructing box plots

    Inputs:
    groupvar:
        is the variable to contrast experiment data by, often
        this is genotype
    comparisonvar:
        are variables you want to compare between groupvar.
        this could be time in targetzone and nontargetzone in the
        watermaze for example.
    "
    melted<-melt(data[,c(groupvar,
        comparisonvar)], id.vars=groupvar)
    data.sem<-ddply(melted,c(groupvar,"variable"),
        summarise, mean=mean(value), sem=sd(value)/sqrt(length(value)) )
    data.sem<-transform(data.sem, lower=mean-sem, upper=mean+sem)
    return(data.sem)
    }

addcatvar <- function(df1, df2, catvar="genotype"){
    "
    Add a categorical (factor/level) variable from df1 which is usually probe data
    to df2 which is usually training data

    I use this to add genotype or condition information from a probe dataframe to
    my training dataframe

    Matches based on both dataframes with column titled 'mouse' - therefore requires
    a column with this name in df1 and df2

    Inputs:
    df1:
        dataframe extract categorical variable from (e.g. probe test)
    df2:
        dataframe you are adding categorical variable to (e.g. training data) where
        subject occurs many times
    "
    # Tmp make new column all ""
    df2[,catvar] <- as.character("")
    for (ms in levels(df2$mouse)){
        df2[df2$mouse==ms,][catvar] <- as.character(df1[df1$mouse==ms,][catvar])
    }
    return(as.data.frame(df2))
}

# average latency for each mouse, for each day, average time
averagedays <- function(data){
    "
    FIX TO INCLUDE ALL OTHER COLS as well as new day col
    Inputs:
    data:
        dataframe of your mouse data with columns named
        mouse, day, timetoplatform, trialduration
    "
    out <- NULL
    for (i in levels(data$mouse)){
        for (j in seq(1:max(data$day))){
            tmp<-data.frame(mouse=i,
                genotype=subset(data, mouse==i & day==j & trial==1, genotype),
                dose=subset(data, mouse==i & day==j & trial==1, dose),
                day=j,
                timetoplatform=mean(subset(data, mouse==i & day==j)$timetoplatform),
                trialduration=mean(subset(data, mouse==i & day==j)$trialduration)
                )
            out <- rbind(out, tmp)
            }
        }
    return(as.data.frame(out))
}


# Data Wrangling in R
# 3.4 Importing TSV Files into R

# Read in TSV containing Medicare data
# This file is comparing the charges for the 100 most common inpatient services and 30 common outpatient services.  Providers determine what they will charge for items and services provided to patients and these charges are the amount the providers bills for an item or service.

# First, we need to load the tidyverse
library(tidyverse)

# Next, let's just try reading in the file and see what it looks like
inpatient <- read_tsv('http://594442.youcanlearnit.net/inpatient.tsv')

glimpse(inpatient)

# First issue that we need to correct is the variable names.

names <- c("DRG", "ProviderID", "Name", "Address", "City", "State",
           "ZIP", "Region", "Discharges", "AverageCharges", "AverageTotalPayments",
           "AverageMedicarePayments")

inpatient <- read_tsv('http://594442.youcanlearnit.net/inpatient.tsv', col_names = names)

# Now the names are the first observation!
# Two ways I can deal with this, I can just delete the first row or I can fix... Let's fix

inpatient <- read_tsv('http://594442.youcanlearnit.net/inpatient.tsv', col_names = names,
                      skip=1)

# Let's specify our data types, reading only discharges as an integer for now

types = 'cccccccciccc'
inpatient <- read_tsv('http://594442.youcanlearnit.net/inpatient.tsv', col_names = names,
                      skip=1, col_types = types)
glimpse(inpatient)

# Now let's deal with the currency amounts
# Currency is floating point, so we might be tempted to try doubles

types = 'cccccccciddd'
inpatient <- read_tsv('http://594442.youcanlearnit.net/inpatient.tsv', col_names = names,
                      skip=1, col_types = types)
glimpse(inpatient)

# But that doesn't work quite right, so we can use numeric instead
# It finds the first number in the field.  Good for getting rid of $, % etc.

types = 'ccccccccinnn'
inpatient <- read_tsv('http://594442.youcanlearnit.net/inpatient.tsv', col_names = names,
                      skip=1, col_types = types)

glimpse(inpatient)