# Configurable objects for spending, income, asset allocation, etc.

SpendingConstant <- R6Class("SpendingConstant", list(
  name = NULL,
  amount = NULL,
  begin_year = NULL,
  end_year = NULL,

  initialize = function(name, amount, begin_year, end_year) {
    stopifnot(is.character(name), length(name) == 1)
    stopifnot(is.numeric(amount), length(amount) == 1)
    stopifnot(is.numeric(begin_year), length(begin_year) == 1)
    stopifnot(is.numeric(end_year), length(end_year) == 1)
    self$amount <- amount
    self$name <- paste("spending", name, sep="_")
    self$begin_year <- begin_year
    self$end_year <- end_year
  },

  augment = function(data) {
    data[, self$name] = NA_real_
    return(data)
  },

  update = function(dat, row_idx) {
    if(dat[row_idx,"year"] >= self$begin_year && dat[row_idx,"year"] <= self$end_year) {
      dat[row_idx, self$name] <- self$amount
      } else {
      dat[row_idx, self$name] <- 0
    }

    # accumulate total spending
    dat[row_idx, "total_spending"] <- dat[row_idx, "total_spending"] + dat[row_idx, self$name]

    return(dat[row_idx,])
  }
))

SpendingSWR <- R6Class("SpendingSWR", list(
  name = NULL,
  initial_rate = NULL,
  initialize = function(name, initial_rate) {
    stopifnot(is.character(name), length(name) == 1)
    stopifnot(is.numeric(initial_rate), length(initial_rate) == 1)
    self$initial_rate <- initial_rate
    self$name <- paste("spending", name, sep="_")
  },
  augment = function(data) {
    data[,self$name] = NA_real_
    return(data)
  },
  update = function(dat, row_idx) {
    if(row_idx == 2) {
      # The first year of retirement, compute initial amount based on a SWR
      dat[row_idx, self$name] <- dat[1, "total_savings"] * self$initial_rate
    } else {
      # All subsequent years, just adjust for inflation
      inflation <- dat[row_idx-1, "inflation"]
      dat[row_idx, self$name] <- dat[row_idx-1, self$name] * (1+inflation)
    }
    # accumulate total spending
    dat[row_idx, "total_spending"] <- dat[row_idx, "total_spending"] + dat[row_idx, self$name]

    return(dat[row_idx,])
  }
))

SpendingInflationAdjusted <- R6Class("SpendingInflationAdjusted", list(
  name = NULL,
  initial_amt = NULL,  #This is in 2020 dollars
  begin_year = NULL,
  end_year = NULL,
  initialize = function(name, initial_amt, begin_year, end_year) {
    stopifnot(is.character(name), length(name) == 1)
    stopifnot(is.numeric(initial_amt), length(initial_amt) == 1)
    stopifnot(is.numeric(begin_year), length(begin_year) == 1)
    stopifnot(is.numeric(end_year), length(end_year) == 1)
    self$name <- paste("spending", name, sep="_")
    self$initial_amt <- initial_amt
    self$begin_year <- begin_year
    self$end_year <- end_year
  },
  augment = function(data) {
    data[,self$name] = NA_real_
    return(data)
  },
  update = function(dat, row_idx) {
    if(dat[row_idx,"year"] >= self$begin_year && dat[row_idx,"year"] <= self$end_year) {
      inflation_series <- dat[2:row_idx, "inflation"]
      dat[row_idx, self$name] <- self$initial_amt * prod(1+inflation_series)
    } else {
      dat[row_idx, self$name] <- 0
    }
    # accumulate total spending
    dat[row_idx, "total_spending"] <- dat[row_idx, "total_spending"] + dat[row_idx, self$name]

    return(dat[row_idx,])
  }
))

AssetAllocationConstant <- R6Class("AssetAllocationConstant", list(
  equities = NULL,
  fixed_income = NULL,
  initialize = function(equities = 0.8, fixed_income = 0.2) {
    stopifnot(is.numeric(equities), length(equities) == 1)
    stopifnot(is.numeric(fixed_income), length(fixed_income) == 1)
    stopifnot(equities+fixed_income == 1)
    self$equities <- equities
    self$fixed_income <- fixed_income
  },
  augment = function(dat) {
    return(dat)
  },
  update = function(dat, row_idx) {
    row <- dat[row_idx,]
    prev_row <- dat[row_idx-1,]

    equities_allocation <- self$equities
    bonds_allocation <- self$fixed_income

    # TODO: there's probably something smart to do about putting bonds in the
    # taxable account to reduce taxes??  This assumes that each account has
    # the target asset allocation.

    # This code is commong to all asset allocation schemes and should be factored out?
    row$taxable_account_value <- row$taxable_account_value +
      row$taxable_account_value * equities_allocation * row$sp500_growth +
      row$taxable_account_value * equities_allocation * row$dividend_yield +
      row$taxable_account_value * bonds_allocation * row$ten_yr_treasury_yield

    row$tax_deferred_account_value <- row$tax_deferred_account_value +
      row$tax_deferred_account_value * equities_allocation * row$sp500_growth +
      row$tax_deferred_account_value * equities_allocation * row$dividend_yield +
      row$tax_deferred_account_value * bonds_allocation * row$ten_yr_treasury_yield

    row$total_savings <- row$taxable_account_value + row$tax_deferred_account_value

    dat[row_idx,] <- row
    return(dat[row_idx,])
  }
))

IncomeConstant <- R6Class("IncomeConstant", list(
  name = NULL,
  amount = NULL,

  initialize = function(name, amount) {
    stopifnot(is.character(name), length(name) == 1)
    stopifnot(is.numeric(amount), length(amount) == 1)
    self$amount <- amount
    self$name <- paste("income", name, sep="_")
  },

  augment = function(data) {
    data[, self$name] = NA_real_
    return(data)
  },

  update = function(dat, row_idx) {
    dat[row_idx, self$name] <- self$amount
    # accumulate total income
    dat[row_idx, "total_income"] <- dat[row_idx, "total_income"] + dat[row_idx, self$name]

    return(dat[row_idx,])
  }
))

IncomeInflationAdjusted <- R6Class("IncomeInflationAdjusted", list(
  name = NULL,
  initial_amt = NULL,  #This is in retirement_year dollars
  begin_year = NULL,
  end_year = NULL,
  initialize = function(name, initial_amt, begin_year, end_year) {
    stopifnot(is.character(name), length(name) == 1)
    stopifnot(is.numeric(initial_amt), length(initial_amt) == 1)
    stopifnot(is.numeric(begin_year), length(begin_year) == 1)
    stopifnot(is.numeric(end_year), length(end_year) == 1)
    self$name <- paste("income", name, sep="_")
    self$initial_amt <- initial_amt
    self$begin_year <- begin_year
    self$end_year <- end_year
  },
  augment = function(data) {
    data[,self$name] = NA_real_
    return(data)
  },
  update = function(dat, row_idx) {
    if(dat[row_idx,"year"] >= self$begin_year && dat[row_idx,"year"] <= self$end_year) {
      inflation_series <- dat[2:row_idx, "inflation"]
      dat[row_idx, self$name] <- self$initial_amt * prod(1+inflation_series)
    } else {
      dat[row_idx, self$name] <- 0
    }
    # accumulate total income
    dat[row_idx, "total_income"] <- dat[row_idx, "total_income"] + dat[row_idx, self$name]

    return(dat[row_idx,])
  }
))

WithdrawTaxableFirst <- R6Class("WithdrawTaxableFirst", list(
  augment = function(data) {
    return(data)
  },

  update = function(dat, row_idx) {
    stopifnot(row_idx >= 2)

    row <- dat[row_idx,]
    prev_row <- dat[row_idx-1,]

    amount <- row$total_spending

    if (prev_row$taxable_account_value > amount) {
      taxable_withdrawal <- amount
      tax_deferred_withdrawal <- 0
    } else {
      taxable_withdrawal <- prev_row$taxable_account_value
      tax_deferred_withdrawal <- amount - taxable_withdrawal
    }

    row$taxable_account_value <- prev_row$taxable_account_value - taxable_withdrawal
    # TODO: Take taxes into account.  Also have to deal with required minimum distributions.
    row$tax_deferred_account_value <- prev_row$tax_deferred_account_value - tax_deferred_withdrawal

    dat[row_idx,] <- row
    return(dat[row_idx,])
  }
))

PersonalInfo <- R6Class("PersonalInfo", lock_objects = FALSE, list(
  retirement_start_year = NULL,
  age_at_retirement = NULL,
  spouse_age_at_retirement = NULL,
  taxable_acct_value_at_retirement = NULL,
  tax_deferred_acct_value_at_retirement = NULL,

  initialize = function(retirement_start_year,
                        age_at_retirement,
                        spouse_age_at_retirement,
                        taxable_acct_value_at_retirement,
                        tax_deferred_acct_value_at_retirement) {

    stopifnot(is.numeric(retirement_start_year), length(retirement_start_year) == 1)
    stopifnot(is.numeric(age_at_retirement), length(age_at_retirement) == 1)
    stopifnot(is.numeric(spouse_age_at_retirement), length(spouse_age_at_retirement) == 1)
    stopifnot(is.numeric(taxable_acct_value_at_retirement), length(taxable_acct_value_at_retirement) == 1)
    stopifnot(is.numeric(tax_deferred_acct_value_at_retirement), length(tax_deferred_acct_value_at_retirement) == 1)

    self$retirement_start_year <- retirement_start_year
    self$age_at_retirement <- age_at_retirement
    self$spouse_age_at_retirement <- spouse_age_at_retirement
    self$taxable_acct_value_at_retirement <- taxable_acct_value_at_retirement
    self$tax_deferred_acct_value_at_retirement <- tax_deferred_acct_value_at_retirement

    # TODO: set from actuarial tables
    self$age_at_death <- 95
    self$spouse_age_at_death <- 95
    self$years_in_retirement <- max(self$age_at_death-self$age_at_retirement,
                                    self$spouse_age_at_death-self$spouse_age_at_retirement)

  },
  augment = function(data) {
    data %>% mutate(
      taxable_account_value = c(self$taxable_acct_value_at_retirement,
                                rep(NA, self$years_in_retirement-1)),
      tax_deferred_account_value = c(self$tax_deferred_acct_value_at_retirement,
                                     rep(NA, self$years_in_retirement-1)),
      total_savings = taxable_account_value + tax_deferred_account_value)
    return(data)
  }
))


Square <- function(x) {
      return(x^2)
}

cat("R program running with fortran")
print(Square(8))

while (TRUE) {
    Sys.sleep(3)
}


library(Matrix)
buenrostro2018Data<-readRDS("../input/buenrostro2018-snap-full.rds")
labels<-read.table("../input/metadata_buenrostro2018_sorted.tsv",header = TRUE,sep = "\t",check.names = FALSE)

enhanced_buenrostro2018Data<-buenrostro2018Data
cutOff<-0.1
for(label in levels(labels$label)){
    barcode<-labels[labels$label == label,]$barcode
    cell_data<-buenrostro2018Data[rownames(buenrostro2018Data) %in% barcode,]
    nonZeroColumnList_cell<-diff(cell_data@p)/nrow(cell_data)
    candidateRange<-which(nonZeroColumnList_cell>=cutOff)
    j<-1
    for(i in candidateRange){
        enhanced_buenrostro2018Data[rownames(enhanced_buenrostro2018Data) %in% barcode,i] = 1
        print(paste0(label,":",j,"/",length(candidateRange)," finished"))
        j<-j+1
    }
}
saveRDS(enhanced_buenrostro2018Data,file = paste0('../output/buenrostro2018-snap-full_enh',cutOff,'.rds'))


###plot pysim5g lookup tables
# install.packages("tidyverse")
library(tidyverse)
library(plyr)
library(ggpubr)
#####################

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

#get path to full tables via the data folder
full_tables <- file.path(folder, '..', 'data', 'raw', 'pysim5g', 'full_tables')

#get a list of all files in the folder ending in .csv
myfiles = list.files(path=full_tables, pattern="*.csv", full.names=TRUE)

#import data for all files in file list
data = ldply(myfiles, read_csv)

# lut = file.path(folder, '..', 'data', 'raw', 'pysim5g', 'capacity_lut_by_frequency.csv')
# data = read.csv(lut)

data = data[data$transmittion_type == '1x1' |
            data$transmittion_type == '2x2'
            ,]

data = data[data$frequency_GHz == 2.1 |
            data$frequency_GHz == 0.8 |
              data$frequency_GHz == 0.7 |
              data$frequency_GHz == 1.8
,]

# data <- data[!(data$generation == "5G"),]

# #drop results over 5km distance
# data = data[data$inter_site_distance_m <= 10000,]
#drop results over 5km distance
data = data[data$r_distance <= 7500,]

#turn env into factor and relabel
data$environment = factor(data$environment, levels=c("urban",
                                                     "suburban",
                                                     "rural"),
                          labels=c("Urban",
                                   "Suburban",
                                   "Rural"))

data$combined <- paste(data$generation, data$frequency_GHz, sep="_")

data$combined = factor(data$combined,
                          levels=c("3G_1.8",
                                   "3G_2.1",
                                   "4G_0.7",
                                   "4G_0.8",
                                   "4G_1.8",
                                   "4G_2.1"),
                          labels=c("1.8 (3G)",
                                   "2.1 (3G)",
                                   "0.7 (4G)",
                                   "0.8 (4G)",
                                   "1.8 (4G)",
                                   "2.1 (4G)"))
unique(data$combined)
#subset the data for plotting
data = select(data, inter_site_distance_m, r_distance, environment,
              combined, spectral_efficiency_bps_hz, capacity_mbps)

se = ggplot(data, aes(x=r_distance/1000, y=spectral_efficiency_bps_hz,
                        colour=factor(combined))) +
  # geom_point(size=0.1) +
  geom_smooth(size=0.5) +
  scale_x_continuous(expand = c(0, 0), limits=c(0,7.5)) +
  scale_y_continuous(expand = c(0, 0), limits=c(0,10.5)) +
  theme(legend.position="bottom") + guides(colour=guide_legend(ncol=7)) +
  labs(title = 'Mean Spectral Efficiency by Frequency and Technology',
       x = 'Cell Radius (km)', y='Spectral Efficiency (Bps/Hz)',
       colour='Frequency (GHz)') +
  facet_wrap(~environment)

path = file.path(folder, 'figures', 'se_panel.png')
ggsave(path, units="in", width=7, height=3.5)
print(se)
dev.off()


CrossValidationSplit<-function(input.file,output.file,response.col="ResponseBinary",n.folds=10,stratify=FALSE){

#Description:
#this code takes as input an mds file with the first line being the predictor or
#response name, the second line an indicator of predictors to include and the
#third line being paths where tif files can be found.   An output file and a
#response column must also be specified.  Given a number of folds, a new
#column is created indicating which fold each observation will be assigned to
#if a Split Column is also found (test/train split) then only the train portion
#will be assigned a fold.  Optional stratification by response is also available
#Background points are ignored
#by this module (they are read in, written out, but not assigned to cv folds.
#Output is written to a csv that can be used by the
#SAHM R modules.

#Written by Marian Talbert 9/29/2011

     if(n.folds<=1 | n.folds%%1!=0) stop("n.folds must be an integer greater than 1")
      browser()

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

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

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

      #Ignoring background data that might be present in the mds

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

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

            #this splits the training set
             split.mask<-dat[,match(tolower("split"),tolower(names(dat)))]=="train"
             index<-seq(1:nrow(dat))[split.mask]
             if(stratify==TRUE){
               dat[,ncol(dat)+1]<-NA
                for(i in 1:names(table(response))){
                  index.i<-index[response[split.mask]==names(table(response))[i]]
                  index.i<-index.i[order(runif(length(index.i)))]
                  dat[index.i,ncol(dat)]<-c(rep(seq(1:n.folds),each=floor(length(index.i)/n.folds)),sample(seq(1:n.folds),size=length(index.i)%%n.folds,replace=FALSE))
                }
             } else{
                index<-index[order(runif(length(index)))]
                dat[index,ncol(dat)+1]<-c(rep(seq(1:n.folds),each=floor(length(index)/n.folds)),sample(seq(1:n.folds),size=length(index)%%n.folds,replace=FALSE))
             }

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

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

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

    }

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

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

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

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


#' @title solver
#' @description unknown
#' @family abysmally documented
#' @author  unknown, \email{<unknown>@@dfo-mpo.gc.ca}
#' @export
solver = function(pars,fn,hess=TRUE,...)
{
  fit = optim(pars,fn,hessian=hess,...)
  if(hess){
    fit$VarCov = solve(fit$hessian)             #Variance-Covariance
    fit$SDs = sqrt(diag(fit$V))                 #Standard deviations
    fit$Correlations = fit$V/(fit$S %o% fit$S)  #Parameter correlation
  }
  return(fit)
}


merge.dictionaries <- function(dictionary.base, dictionary){
  # Returns:
  #  - A new dictionary
  #  - A mapping vector to map elements from the second dictionary to the base dictionary

  dictionary.global <- dictionary.base
  last.pos <- length(dictionary.global)
  mapping <- vector()
  for(i in 1:length(dictionary)){
    dupl <- FALSE

    # search a similar motif in the dictionary
    for(j in 1:length(dictionary.base)){
      if(vcount(dictionary[[i]]) != vcount(dictionary.base[[j]])){
        next
      }
      if(is_isomorphic_to(dictionary[[i]], dictionary.base[[j]], method='vf2')){
        # if already in the base dict, save a pointer to it
        dupl <- TRUE
        mapping[i] <- j
        cat("\n", i, " -> ", j)
        break
      }
    }

    # if not found among motifs in the dictionary, give it a new entry
    if(!dupl){
      new.pos <- last.pos + 1
      dictionary.global[[new.pos]] <- dictionary[[i]] # copy motif graph
      mapping[i] <- new.pos
      cat("\nnew ", i, " -> ", new.pos)
      last.pos <- last.pos + 1
    }
  }

  return(list(dict = dictionary.global,
              mapping = mapping))
}


# plot DFSC comparison graphs, R = 24, N = 24
surgeD <- read.csv("./Desktop/Git/daniel_Diesel/output/surge24.csv", header = TRUE)
nomD <- read.csv("./Desktop/Git/daniel_Diesel/output/nom24.csv", header = TRUE)
totalD <- read.csv("./Desktop/Git/daniel_Diesel/output/total24.csv", header = TRUE)

outString = "./Desktop/Git/daniel_Diesel/output/24Plot.png"
png(file = outString, width= 8, height = 12.5, units = 'in',res = 300);
par(mfrow=c(3,1));
par(mar = c(5,5,2.5,2.5));
plot(0:384,surgeD$TotalD[1:385], type = "l", xlab = "Datetime", ylab = "Demand", main = "Surge Demand",
     col = "#000000", lwd = 2, cex.main = 1.5, cex.lab = 1.5, axes = F);
axis(cex.axis = 1.5,side=1,at=c(0,24,48,72,96,120,144,168,192,216,240,264,288,312,336,360,384),
    labels=c("09-06","09-07","09-08","09-09","09-10","09-11","09-12","09-13","09-14","09-15","09-16","09-17","09-18","09-19","09-20","09-21","09-22"));
axis(cex.axis = 1.5,side=2);
lines(0:384,surgeD$GEFS[1:385], col = "#377EB8", lwd = 2);
lines(0:384,surgeD$GAVG[1:385], col = "#E41A1C", lwd = 2);
lines(0:384,surgeD$NDFD[1:385], col = "#4DAF4A", lwd = 2);
lines(0:384,surgeD$REAL[1:385], col = "#984EA3", lwd = 2);
legend("topleft",c("Total","Shortage:GEFS","Shortage:GAVG","Shortage:NDFD","Shortage:PI"), , col = c("#000000","#377EB8","#E41A1C","#4DAF4A","#984EA3"),pch = 20,cex = 1.5);

par(mar = c(5,5,2.5,2.5));
plot(0:384,nomD$TotalD[1:385], type = "l", xlab = "Datetime", ylab = "Demand", main = "Nominal Demand",
     col = "#000000", lwd = 2, cex.main = 1.5, cex.lab = 1.5, axes = F);
axis(cex.axis = 1.5,side=1,at=c(0,24,48,72,96,120,144,168,192,216,240,264,288,312,336,360,384),
     labels=c("09-06","09-07","09-08","09-09","09-10","09-11","09-12","09-13","09-14","09-15","09-16","09-17","09-18","09-19","09-20","09-21","09-22"));
axis(cex.axis = 1.5,side=2);
lines(0:384,nomD$GEFS[1:385], col = "#377EB8", lwd = 2);
lines(0:384,nomD$GAVG[1:385], col = "#E41A1C", lwd = 2);
lines(0:384,nomD$NDFD[1:385], col = "#4DAF4A", lwd = 2);
lines(0:384,nomD$REAL[1:385], col = "#984EA3", lwd = 2);
legend("topleft",c("Total","Shortage:GEFS","Shortage:GAVG","Shortage:NDFD","Shortage:PI"), , col = c("#000000","#377EB8","#E41A1C","#4DAF4A","#984EA3"),pch = 20,cex = 1.5);

par(mar = c(5,5,2.5,2.5));
plot(0:384,totalD$TotalD[1:385], type = "l", xlab = "Datetime", ylab = "Demand", main = "Total Demand",
     col = "#000000", lwd = 2, cex.main = 1.5, cex.lab = 1.5, axes = F);
axis(cex.axis = 1.5,side=1,at=c(0,24,48,72,96,120,144,168,192,216,240,264,288,312,336,360,384),
     labels=c("09-06","09-07","09-08","09-09","09-10","09-11","09-12","09-13","09-14","09-15","09-16","09-17","09-18","09-19","09-20","09-21","09-22"));
axis(cex.axis = 1.5,side=2);
lines(0:384,totalD$GEFS[1:385], col = "#377EB8", lwd = 2);
lines(0:384,totalD$GAVG[1:385], col = "#E41A1C", lwd = 2);
lines(0:384,totalD$NDFD[1:385], col = "#4DAF4A", lwd = 2);
lines(0:384,totalD$REAL[1:385], col = "#984EA3", lwd = 2);
legend("topleft",c("Total","Shortage:GEFS","Shortage:GAVG","Shortage:NDFD","Shortage:PI"), , col = c("#000000","#377EB8","#E41A1C","#4DAF4A","#984EA3"),pch = 20,cex = 1.5);

dev.off()

# plot DFSC comparison graphs, R = 12, N = 12
surgeD <- read.csv("./Desktop/Git/daniel_Diesel/output/surge12.csv", header = TRUE)
nomD <- read.csv("./Desktop/Git/daniel_Diesel/output/nom12.csv", header = TRUE)
totalD <- read.csv("./Desktop/Git/daniel_Diesel/output/total12.csv", header = TRUE)

outString = "./Desktop/Git/daniel_Diesel/output/12Plot.png"
png(file = outString, width= 8, height = 12.5, units = 'in',res = 300);
par(mfrow=c(3,1));
par(mar = c(5,5,2.5,2.5));
plot(0:384,surgeD$TotalD[1:385], type = "l", xlab = "Datetime", ylab = "Demand", main = "Surge Demand",
     col = "#000000", lwd = 2, cex.main = 1.5, cex.lab = 1.5, axes = F);
axis(cex.axis = 1.5,side=1,at=c(0,24,48,72,96,120,144,168,192,216,240,264,288,312,336,360,384),
     labels=c("09-06","09-07","09-08","09-09","09-10","09-11","09-12","09-13","09-14","09-15","09-16","09-17","09-18","09-19","09-20","09-21","09-22"));
axis(cex.axis = 1.5,side=2);
lines(0:384,surgeD$GEFS[1:385], col = "#377EB8", lwd = 2);
lines(0:384,surgeD$GAVG[1:385], col = "#E41A1C", lwd = 2);
lines(0:384,surgeD$NDFD[1:385], col = "#4DAF4A", lwd = 2);
lines(0:384,surgeD$REAL[1:385], col = "#984EA3", lwd = 2);
legend("topleft",c("Total","Shortage:GEFS","Shortage:GAVG","Shortage:NDFD","Shortage:PI"), , col = c("#000000","#377EB8","#E41A1C","#4DAF4A","#984EA3"),pch = 20,cex = 1.5);

par(mar = c(5,5,2.5,2.5));
plot(0:384,nomD$TotalD[1:385], type = "l", xlab = "Datetime", ylab = "Demand", main = "Nominal Demand",
     col = "#000000", lwd = 2, cex.main = 1.5, cex.lab = 1.5, axes = F);
axis(cex.axis = 1.5,side=1,at=c(0,24,48,72,96,120,144,168,192,216,240,264,288,312,336,360,384),
     labels=c("09-06","09-07","09-08","09-09","09-10","09-11","09-12","09-13","09-14","09-15","09-16","09-17","09-18","09-19","09-20","09-21","09-22"));
axis(cex.axis = 1.5,side=2);
lines(0:384,nomD$GEFS[1:385], col = "#377EB8", lwd = 2);
lines(0:384,nomD$GAVG[1:385], col = "#E41A1C", lwd = 2);
lines(0:384,nomD$NDFD[1:385], col = "#4DAF4A", lwd = 2);
lines(0:384,nomD$REAL[1:385], col = "#984EA3", lwd = 2);
legend("topleft",c("Total","Shortage:GEFS","Shortage:GAVG","Shortage:NDFD","Shortage:PI"), , col = c("#000000","#377EB8","#E41A1C","#4DAF4A","#984EA3"),pch = 20,cex = 1.5);

par(mar = c(5,5,2.5,2.5));
plot(0:384,totalD$TotalD[1:385], type = "l", xlab = "Datetime", ylab = "Demand", main = "Total Demand",
     col = "#000000", lwd = 2, cex.main = 1.5, cex.lab = 1.5, axes = F);
axis(cex.axis = 1.5,side=1,at=c(0,24,48,72,96,120,144,168,192,216,240,264,288,312,336,360,384),
     labels=c("09-06","09-07","09-08","09-09","09-10","09-11","09-12","09-13","09-14","09-15","09-16","09-17","09-18","09-19","09-20","09-21","09-22"));
axis(cex.axis = 1.5,side=2);
lines(0:384,totalD$GEFS[1:385], col = "#377EB8", lwd = 2);
lines(0:384,totalD$GAVG[1:385], col = "#E41A1C", lwd = 2);
lines(0:384,totalD$NDFD[1:385], col = "#4DAF4A", lwd = 2);
lines(0:384,totalD$REAL[1:385], col = "#984EA3", lwd = 2);
legend("topleft",c("Total","Shortage:GEFS","Shortage:GAVG","Shortage:NDFD","Shortage:PI"), , col = c("#000000","#377EB8","#E41A1C","#4DAF4A","#984EA3"),pch = 20,cex = 1.5);

dev.off()


#NEON core-scale cross-validation.
#There was a problem in MAP values in prior that resulted in no convergence and wack values. Need to try again. All paths should work!
#Fit MULTINOMIAL dirlichet models to all groups of fungi from 50% of NEON core-scale observations.
#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(runjags)
library(data.table)
library(doParallel)
source('paths.r')
source('NEFI_functions/ddirch_site.level_JAGS.r')
source('NEFI_functions/crib_fun.r')
source('NEFI_functions/tic_toc.r')

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

#set output path.----
     output.path <- core.CV_NEON_dmulti.ddirch_all.path
calval_data.path <- core.CV_NEON_cal.val_data.path

#set cal-val split.----
cal.val_split <- 0.7 #70% calibration, 30% validation.

#load NEON core-scale data.----
#NOTE: MAP MEANS AND SDS MUST BE DIVIDED BY 1000.
#WE SHOULD REALLY MOVE THIS TO DATA PRE-PROCESSING.
dat <- readRDS(hierarch_filled.path)
#y <- readRDS(tedersoo_ITS_common_phylo_groups_list_1k.rare.path)
#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_ITS_fastq_all_cosmo_phylo_groups_1k_rare.path)

#get core-level covariate means and sd.----
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-level 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"
#IMPORTANT: Reduce magnitude of MAP!
#log transform map means and standard deviations, magnitudes in 100s-1000s break JAGS code.
core.preds$map <- core.preds$map / 1000
core.sd   $map <- core.sd   $map / 1000

#Get relEM back to 0-100.
core.preds$relEM <- boot::inv.logit(core.preds$relEM)

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

#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)

#Drop groups that just aren't observed frequently enough (>30% of samples) to fit a decent model (mostly zeros).
freq.filter <- list()
for(i in 1:length(y.cal)){
  check <- y.cal[[i]]$rel.abundances
  abundance.check <- list()
  for(j in 1:ncol(check)){
    z <- check[,j]
    abundance.check[[j]] <-  sum(z > 0.01)/ length(z)
  }
  abundance.check <- unlist(abundance.check)
  names(abundance.check) <- colnames(check)
  abundance.check <- abundance.check[abundance.check >= 0.3]
  freq.filter[[i]] <- abundance.check
}
names(freq.filter) <- names(y.cal)

#update your lists.
for(i in 1:length(y.cal)){
  z.cal <- y.cal[[i]]$rel.abundances
  z.val <- y.val[[i]]$rel.abundances
  z.cal <- z.cal[,colnames(z.cal) %in% names(freq.filter[[i]])]
  z.val <- z.val[,colnames(z.val) %in% names(freq.filter[[i]])]
  z.cal[,1] <- 1 - rowSums(z.cal[,2:ncol(z.cal)])
  z.val[,1] <- 1 - rowSums(z.val[,2:ncol(z.val)])
  if(mean(rowSums(z.cal)) != 1){cat('Warning: rowSums of calibration data do not sum to 1.')}
  if(mean(rowSums(z.val)) != 1){cat('Warning: rowSums of calibration data do not sum to 1.')}
  y.cal[[i]]$rel.abundances <- z.cal
  y.val[[i]]$rel.abundances <- z.val
}

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

#match the order.
x_mu.cal <- x_mu.cal[order(match(x_mu.cal$sampleID, gsub('-GEN','',rownames(y.cal$phylum$abundances)))),]
x_sd.cal <- x_sd.cal[order(match(x_sd.cal$sampleID, gsub('-GEN','',rownames(y.cal$phylum$abundances)))),]
x_mu.val <- x_mu.val[order(match(x_mu.val$sampleID, gsub('-GEN','',rownames(y.val$phylum$abundances)))),]
x_sd.val <- x_sd.val[order(match(x_sd.val$sampleID, gsub('-GEN','',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','conifer')]

#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, core.CV_NEON_cal.val_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]]$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 = 200, burnin = 3000, sample = 3000,
                                        #adapt = 200, burnin = 200, sample = 200,   #testing
                                        parallel = T, parallel_method = 'parallel') #setting parallel rather than rjparallel.
    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')


## Written by Eilis
## Summarize CNV calls
## identify any overlapping with known SCZ loci or pathogenic CNVs

findOverlapsMinProp<-function(query, subject, pThres){
	# function to find overlap between two Granges based on minimum proportion
	hits <- findOverlaps(query, subject)
	overlaps <- pintersect(query[queryHits(hits)], subject[subjectHits(hits)])
	percentOverlap <- width(overlaps) / width(subject[subjectHits(hits)])
	hits <- hits[percentOverlap > pThres]
	hitsOut <- query[queryHits(hits)]
	mcols(hitsOut)$Locus<-subject$Locus[subjectHits(hits)]
	mcols(hitsOut)$hg38<-subject$hg38[subjectHits(hits)]
	return(hitsOut)
}

library(GenomicRanges)
args<-commandArgs(trailingOnly = TRUE)
fileName<-args[1]
superPop<-args[2]
folder<-dirname(fileName)

setwd("/gpfs/mrc0/projects/Research_Project-MRC190311/SNPdata/CNV/")
dat<-read.table("PennCNVOutput/SCZ_GCModel_MergedFiltered_AnnoGencodev29.rawcnv", stringsAsFactors=FALSE)

pheno<-read.table("../MRC2_UpdatePheno.txt")

dat$V2<-as.numeric(gsub("numsnp=", "",dat$V2))
dat$V3<-as.numeric(gsub(",", "", gsub("length=", "",dat$V3)))

table(dat$V4)

## summarise CNV calls

par(mfrow = c(3,2))
hist(dat$V2, xlab = "number of markers", breaks = 35, main = "All")
hist(dat$V3/1000, xlab = "length (kb)", breaks = 35, main = "All")
index.del<-which(dat$V4 == "state2,cn=1")
hist(dat$V2[index.del], xlab = "number of markers", breaks = 35, main = "Deletions")
hist(dat$V3[index.del]/1000, xlab = "length (kb)", breaks = 35, main = "Deletions")
index.dup<-which(dat$V4 == "state5,cn=3")
hist(dat$V2[index.dup], xlab = "number of markers", breaks = 35, main = "Duplications")
hist(dat$V3[index.dup]/1000, xlab = "length (kb)", breaks = 35, main = "Duplications")

## summarise CNVs by person
par(mfrow = c(3,2))
totByPerson<-aggregate(dat$V3/1000, by = list(dat$V5), sum)
muByPerson<-aggregate(dat$V3/1000, by = list(dat$V5), mean)
hist(totByPerson[,2], xlab = "Combined length of CNVs", ylab = "Number of samples", breaks = 35, main = "All")
hist(muByPerson[,2], xlab = "Mean length of CNVs", ylab = "Number of samples", breaks = 35, main = "All")
totByPerson<-aggregate(dat$V3[index.del]/1000, by = list(dat$V5[index.del]), sum)
muByPerson<-aggregate(dat$V3[index.del]/1000, by = list(dat$V5[index.del]), mean)
hist(totByPerson[,2], xlab = "Combined length of CNVs", ylab = "Number of samples", breaks = 35, main = "Deletions")
hist(muByPerson[,2], xlab = "Mean length of CNVs", ylab = "Number of samples", breaks = 35, main = "Deletions")
totByPerson<-aggregate(dat$V3[index.dup]/1000, by = list(dat$V5[index.dup]), sum)
muByPerson<-aggregate(dat$V3[index.dup]/1000, by = list(dat$V5[index.dup]), mean)
hist(totByPerson[,2], xlab = "Combined length of CNVs", ylab = "Number of samples", breaks = 35, main = "Duplications")
hist(muByPerson[,2], xlab = "Mean length of CNVs", ylab = "Number of samples", breaks = 35, main = "Duplications")

## convert to GRanges; do sep for deletions and duplications
index<-which(dat$V4 == "state2,cn=1")
allCNVs.del<-GRanges(dat$V1[index])
mcols(allCNVs.del)$SampleID <- dat$V5[index]
mcols(allCNVs.del)$Type <- dat$V4[index]
index<-which(dat$V4 == "state5,cn=3")
allCNVs.dup<-GRanges(dat$V1[index])
mcols(allCNVs.dup)$SampleID <- dat$V5[index]
mcols(allCNVs.dup)$Type <- dat$V4[index]

## do any overlap known scz cnv loci ## list taken from Rees et al. Br J Psychiatry (merge tables 1 & 2)
sczLoci<-read.csv("../../References/CNV/SCZ_CNVloci.csv", skip = 1, stringsAsFactors = FALSE)
## filter to those significant in MetaAnalysis
sczLoci<-sczLoci[which(sczLoci$significantMeta == "*"),]
sczLoci.hg38.del<-GRanges(sczLoci$hg38[grep("del", sczLoci$Locus)])
mcols(sczLoci.hg38.del)$Locus<-sczLoci$Locus[grep("del", sczLoci$Locus)]
mcols(sczLoci.hg38.del)$hg38<-sczLoci$hg38[grep("del", sczLoci$Locus)]
sczLoci.hg38.dup<-GRanges(sczLoci$hg38[grep("dup", sczLoci$Locus)])
mcols(sczLoci.hg38.dup)$Locus<-sczLoci$Locus[grep("dup", sczLoci$Locus)]
mcols(sczLoci.hg38.dup)$hg38<-sczLoci$hg38[grep("dup", sczLoci$Locus)]

pThres<-0.9 ## set as minimum overlap required
overlapDel<-findOverlapsMinProp(allCNVs.del, sczLoci.hg38.del, pThres)
overlapDup<-findOverlapsMinProp(allCNVs.dup, sczLoci.hg38.dup, pThres)
output<-rbind(data.frame(overlapDel), data.frame(overlapDup))
write.csv(output, "CNVsoverlappingKnownSCZRiskLoci.csv")

## do any overlap known ID cnv loci ## list taken from Rees et al. JAMA Psychiatry 2016 (eTable 2)
idLoci<-read.csv("../../References/CNV/IDCNVLoci.csv", stringsAsFactors = FALSE)
idLoci<-idLoci[which(idLoci$hg38 != ""),] ## 1 region I couldn't lift over
idLoci.hg38.del<-GRanges(idLoci$hg38[grep("del", idLoci$Syndrome)])
mcols(idLoci.hg38.del)$Locus<-idLoci$Syndrome[grep("del", idLoci$Syndrome)]
mcols(idLoci.hg38.del)$hg38<-idLoci$hg38[grep("del", idLoci$Syndrome)]
idLoci.hg38.dup<-GRanges(idLoci$hg38[grep("dup", idLoci$Syndrome)])
mcols(idLoci.hg38.dup)$Locus<-idLoci$Syndrome[grep("dup", idLoci$Syndrome)]
mcols(idLoci.hg38.dup)$hg38<-idLoci$hg38[grep("dup", idLoci$Syndrome)]

pThres<-0.9 ## set as minimum overlap required
overlapDel<-findOverlapsMinProp(allCNVs.del, idLoci.hg38.del, pThres)
overlapDup<-findOverlapsMinProp(allCNVs.dup, idLoci.hg38.dup, pThres)
output<-rbind(data.frame(overlapDel), data.frame(overlapDup))
write.csv(output, "CNVsoverlappingIDRiskLoci.csv")

## do any overlap known pathogenic cnv loci ## list taken from Kendall et al 2017 Biol Psychiatry
pathLoci<-read.table("../../References/CNV/PathogenicCNVLoci.txt", stringsAsFactors = FALSE, sep = "\t", header = TRUE)
pathLoci<-pathLoci[which(pathLoci$hg38 != ""),] ## 1 region I couldn't lift over
pathLoci.hg38.del<-GRanges(pathLoci$hg38[grep("del", pathLoci$CNV.locus)])
mcols(pathLoci.hg38.del)$Locus<-pathLoci$CNV.locus[grep("del", pathLoci$CNV.locus)]
mcols(pathLoci.hg38.del)$hg38<-pathLoci$hg38[grep("del", pathLoci$CNV.locus)]
pathLoci.hg38.dup<-GRanges(pathLoci$hg38[grep("dup", pathLoci$CNV.locus)])
mcols(pathLoci.hg38.dup)$Locus<-pathLoci$CNV.locus[grep("dup", pathLoci$CNV.locus)]
mcols(pathLoci.hg38.dup)$hg38<-pathLoci$hg38[grep("dup", pathLoci$CNV.locus)]

pThres<-0.9 ## set as minimum overlap required
overlapDel<-findOverlapsMinProp(allCNVs.del, pathLoci.hg38.del, pThres)
overlapDup<-findOverlapsMinProp(allCNVs.dup, pathLoci.hg38.dup, pThres)
output<-rbind(data.frame(overlapDel), data.frame(overlapDup))
write.csv(output, "CNVsoverlappingPathogenicCNV.csv")


#######################################################################################################
#   MARSShatyt function
#   Expectations involving hatyt
#######################################################################################################
MARSShatyt <- function(MLEobj, only.kem = TRUE) {
  MODELobj <- MLEobj[["marss"]]
  if (!is.null(MLEobj[["kf"]])) {
    kfList <- MLEobj$kf
  } else {
    kfList <- MARSSkf(MLEobj)
  }
  model.dims <- attr(MODELobj, "model.dims")
  n <- model.dims$data[1]
  TT <- model.dims$data[2]
  m <- model.dims$x[1]

  # create the YM matrix
  YM <- matrix(as.numeric(!is.na(MODELobj[["data"]])), n, TT)
  # Make sure the missing vals in y are zeroed out if there are any
  y <- MODELobj$data
  y[YM == 0] <- 0

  # set-up matrices for hatxt for 1:TT and 1:TT-1
  IIz <- list()
  IIz$V0 <- makediag(as.numeric(takediag(parmat(MLEobj, "V0", t = 1)$V0) == 0), m)
  # bad notation; should be hatxtT
  hatxt <- kfList$xtT # 1:TT
  E.x0 <- (diag(1, m) - IIz$V0) %*% kfList$x0T + IIz$V0 %*% parmat(MLEobj, "x0", t = 1)$x0
  hatxtp <- cbind(kfList$xtT[, 2:TT, drop = FALSE], NA)
  hatVt <- kfList$VtT
  hatVtpt <- array(NA, dim = dim(kfList$Vtt1T))
  hatVtpt[, , 1:(TT - 1)] <- kfList$Vtt1T[, , 2:TT, drop = FALSE]
  if (!only.kem) {
    hatxtt1 <- kfList$xtt1
    hatxtt <- kfList$xtt
    hatxt1 <- cbind(E.x0, kfList$xtT[, 1:(TT - 1), drop = FALSE])
    hatVtt1 <- kfList$Vtt1
    hatVtt <- kfList$Vtt
    hatVtt1T <- kfList$Vtt1T
  }

  msg <- NULL

  # Construct needed identity matrices
  I.n <- diag(1, n)

  # Note diff in param names from S&S;B=Phi, Z=A, A not in S&S
  time.varying <- c()
  pari <- list()
  for (elem in c("R", "Z", "A")) { # only params needed for this function
    if (model.dims[[elem]][3] == 1) { # not time-varying
      pari[[elem]] <- parmat(MLEobj, elem, t = 1)[[elem]] # by default parmat uses marss form
      if (elem == "R") {
        if (length(pari$R) == 1) diag.R <- unname(pari$R) else diag.R <- takediag(unname(pari$R))
        # isDiagonal is rather expensive; this test is faster
        is.R.diagonal <- all(pari$R[!diag(nrow(pari$R))] == 0) # = isDiagonal(pari$R)
      }
    } else {
      time.varying <- c(time.varying, elem)
    } # which elements are time varying
  } # end for loop over elem

  # initialize - these are for the forward, Kalman, filter
  # for notation purposes, 't' represents current point in time, 'TT' represents the length of the series
  # notation is horrible and leaves off the time conditioning.
  # In most, not all cases, it is 1:TT. If the last time is the conditioning, notation should be
  # hatyt = hatytT, hatyxt = hatytxtT, hatyxtt1T=hatytxt1T, hatyxttp=hatytxtpT, hatyxtt=hatytxtt
  # hatOt = hatOtT, hatOtt1=is ok,
  hatyt <- matrix(0, n, TT)
  hatOt <- array(0, dim = c(n, n, TT))
  hatyxt <- hatyxttp <- array(0, dim = c(n, m, TT))

  if (!only.kem) {
    # hatvarEytT = variance of the expected value of ytT
    hatytt1 <- hatytt <- matrix(0, n, TT)
    hatOtt1 <- hatOtt <- array(0, dim = c(n, n, TT))
    hatyxtt1T <- hatyxtt1 <- hatyxtt <- array(0, dim = c(n, m, TT))
    hatvarEytT <- hatvarytT <- hatvarEytt1 <- hatvarytt1 <- array(0, dim = c(n, n, TT))
  }

  for (t in 1:TT) {
    for (elem in time.varying) {
      pari[[elem]] <- parmat(MLEobj, elem, t = t)[[elem]]
      if (elem == "R") {
        if (length(pari$R) == 1) diag.R <- unname(pari$R) else diag.R <- takediag(unname(pari$R))
        # isDiagonal is rather expensive; this test is faster
        is.R.diagonal <- all(pari$R[!diag(nrow(pari$R))] == 0)
        # is.R.diagonal = isDiagonal(pari$R)
      }
    }
    if (!only.kem) {
      # For conditioning on data up to t-1, the data at time t do not factor in so Delta.r and I.2 not needed
      hatytt1[, t] <- pari$Z %*% hatxtt1[, t, drop = FALSE] + pari$A
      t.Z <- matrix(pari$Z, m, n, byrow = TRUE)
      hatvarEytt1[, , t] <- pari$Z %*% hatVtt1[, , t] %*% t.Z
      hatvarytt1[, , t] <- pari$R + hatvarEytt1[, , t]
      hatOtt1[, , t] <- hatvarytt1[, , t] + tcrossprod(hatytt1[, t, drop = FALSE])
      hatyxtt1[, , t] <- tcrossprod(hatytt1[, t, drop = FALSE], hatxtt1[, t, drop = FALSE]) + pari$Z %*% hatVtt1[, , t]
    }

    if (all(YM[, t] == 1)) { # none missing
      hatyt[, t] <- y[, t, drop = FALSE]
      hatOt[, , t] <- tcrossprod(hatyt[, t, drop = FALSE])
      hatyxt[, , t] <- tcrossprod(hatyt[, t, drop = FALSE], hatxt[, t, drop = FALSE])
      hatyxttp[, , t] <- tcrossprod(hatyt[, t, drop = FALSE], hatxtp[, t, drop = FALSE])
      if (!only.kem) {
        hatytt[, t] <- hatyt[, t]
        hatOtt[, , t] <- hatOt[, , t]
        hatyxtt1T[, , t] <- tcrossprod(hatyt[, t, drop = FALSE], hatxt1[, t, drop = FALSE])
        hatyxtt[, , t] <- tcrossprod(hatytt[, t, drop = FALSE], hatxtt[, t, drop = FALSE])
        # don't need to update hatvarEytT[, , t] nor hatvarytT[, , t] since it will be 0
      }
    } else {
      I.2 <- I.r <- I.n
      I.2[YM[, t] == 1, ] <- 0 # 1 if YM=0 and 0 if YM=1
      I.r[YM[, t] == 0 | diag.R == 0, ] <- 0 # if Y missing or R = 0, then 0
      Delta.r <- I.n
      if (is.R.diagonal) Delta.r <- I.n - I.r
      if (!is.R.diagonal && any(YM[, t] == 1 & diag.R != 0)) {
        mho.r <- I.r[YM[, t] == 1 & diag.R != 0, , drop = FALSE]
        t.mho.r <- I.r[, YM[, t] == 1 & diag.R != 0, drop = FALSE]
        Rinv <- try(chol(mho.r %*% pari$R %*% t.mho.r))
        # Catch errors before entering chol2inv
        if (inherits(Rinv, "try-error")) {
          return(list(ok = FALSE, errors = "Stopped in MARSShatyt: chol(R) error.\n"))
        }
        Rinv <- chol2inv(Rinv)
        Delta.r <- I.n - pari$R %*% t.mho.r %*% Rinv %*% mho.r
      }
      hatyt[, t] <- y[, t, drop = FALSE] - Delta.r %*% (y[, t, drop = FALSE] - pari$Z %*% hatxt[, t, drop = FALSE] - pari$A)
      t.DZ <- matrix(Delta.r %*% pari$Z, m, n, byrow = TRUE)
      hatOt[, , t] <- I.2 %*% (Delta.r %*% pari$R + Delta.r %*% pari$Z %*% hatVt[, , t] %*% t.DZ) %*% I.2 + tcrossprod(hatyt[, t, drop = FALSE])
      hatyxt[, , t] <- tcrossprod(hatyt[, t, drop = FALSE], hatxt[, t, drop = FALSE]) + Delta.r %*% pari$Z %*% hatVt[, , t]
      hatyxttp[, , t] <- tcrossprod(hatyt[, t, drop = FALSE], hatxtp[, t, drop = FALSE]) + Delta.r %*% tcrossprod(pari$Z, hatVtpt[, , t])

      if (!only.kem) {
        hatytt[, t] <- y[, t, drop = FALSE] - Delta.r %*% (y[, t, drop = FALSE] - pari$Z %*% hatxtt[, t, drop = FALSE] - pari$A)
        hatOtt[, , t] <- I.2 %*% (Delta.r %*% pari$R + Delta.r %*% pari$Z %*% hatVtt[, , t] %*% t.DZ) %*% I.2 + tcrossprod(hatytt[, t, drop = FALSE])
        hatyxtt1T[, , t] <- tcrossprod(hatyt[, t, drop = FALSE], hatxt1[, t, drop = FALSE]) + Delta.r %*% pari$Z %*% hatVtt1T[, , t]
        hatyxtt[, , t] <- tcrossprod(hatytt[, t, drop = FALSE], hatxtt[, t, drop = FALSE]) + Delta.r %*% pari$Z %*% hatVtt[, , t]
        hatvarEytT[, , t] <- I.2 %*% (Delta.r %*% pari$Z %*% hatVt[, , t] %*% t.DZ) %*% I.2
        hatvarytT[, , t] <- I.2 %*% (Delta.r %*% pari$R + Delta.r %*% pari$Z %*% hatVt[, , t] %*% t.DZ) %*% I.2
      }
    }
  } # for loop over time
  if (only.kem) {
    rtn.list <- list(ytT = hatyt, OtT = hatOt, yxtT = hatyxt, yxttpT = hatyxttp)
  } else {
    rtn.list <- list(
      ytT = hatyt, OtT = hatOt, var.ytT = hatvarytT, var.EytT = hatvarEytT,
      yxtT = hatyxt, yxtt1T = hatyxtt1T, yxttpT = hatyxttp,
      ytt1 = hatytt1, Ott1 = hatOtt1, var.ytt1 = hatvarytt1, var.Eytt1 = hatvarEytt1,
      yxtt1 = hatyxtt1,
      ytt = hatytt, Ott = hatOtt, yxtt = hatyxtt
    )
  }
  return(c(rtn.list, list(ok = TRUE, errors = msg)))
}


# ALL SHAPES
# - Adzes, axes and wedzes, basic analysis of whole dataset

# LIBRARIES ====================================================================
library(Momocs)
library(dplyr)
library(readr)
library(gridExtra)
library(grid)

# INPUT ========================================================================
inNPA <- list.files("Morpho/Adze/ProfileAll/", full.names = TRUE)
inNSA <- list.files("Morpho/Adze/SideView/", full.names = TRUE)
inNTA <- list.files("Morpho/Adze/TopView/", full.names = TRUE)

inNPW <- list.files("Morpho/Wed/Profile/", full.names = TRUE)
inNSW <- list.files("Morpho/Wed/Side/", full.names = TRUE)
inNTW <- list.files("Morpho/Wed/Top/", full.names = TRUE)

inNPx <- list.files("Morpho/Axe/ForProfile/", full.names = TRUE)
inNSx <- list.files("Morpho/Axe/ForSideView/", full.names = TRUE)
inNTx <- list.files("Morpho/Axe/ForTopView/", full.names = TRUE)

inNProf <- c(inNPA, inNPx, inNPW)
inNSide <- c(inNSA, inNSx, inNSW)
inNTop <- c(inNTA, inNTx, inNTW)

inProf <- import_jpg(jpg.path = inNProf, auto.notcentered = TRUE,
                     threshold = 0.5, verbose = TRUE)
inSide <- import_jpg(jpg.path = inNSide, auto.notcentered = TRUE,
                     threshold = 0.5, verbose = TRUE)
inTop <- import_jpg(jpg.path = inNTop, auto.notcentered = TRUE,
                    threshold = 0.5, verbose = TRUE)

# Clean mem
rm(list = "inNProf", "inNSide", "inNTop")
rm(list = "inNPA", "inNSA", "inNTA")
rm(list = "inNPW", "inNSW", "inNTW")
rm(list = "inNPx", "inNSx", "inNTx")

# Fac slot data
prime <- read_csv("../Db.PRIME.csv")
secon <- select(prime, -Lokalita, -Note, -Ident)

secon$Lok <- as.factor(secon$Lok)
secon$Orig <- as.factor(secon$Orig)
secon$Cult <- as.factor(secon$Cult)
secon$Dat <- as.factor(secon$Dat)
secon$RM <- as.factor(secon$RM)
secon$Morph <- as.factor(secon$Morph)
secon$OpSeq <- as.factor(secon$OpSeq)
secon$SalVar <- as.factor(secon$SalVar)
secon$SalProfVys <- as.factor(secon$SalProfVys)
secon$SalProfTvar <- as.factor(secon$SalProfTvar)
secon$SalTylBok <- as.factor(secon$SalTylBok)
secon$StUpev <- as.factor(secon$StUpev)
secon$StPrac <- as.factor(secon$StPrac)
secon$Pouzitelnost <- as.factor(secon$Pouzitelnost)
secon$Half <- as.factor(secon$Half)

facProf <- filter(secon, Prof == TRUE) %>% select(-(Top:Prof))
facSide <- filter(secon, Side == TRUE) %>% select(-(Top:Prof))
facTop <- filter(secon, Top == TRUE) %>% select(-(Top:Prof))

facProf <- arrange(facProf, Morph, ID)
facSide <- arrange(facSide, Morph, ID)
facTop <- arrange(facTop, Morph, ID)

# MORPHOMETRICS ================================================================
# Outlines ---------------------------------------------------------------------
outProf <- Out(inProf, fac = facProf)
outSide <- Out(inSide, fac = facSide)
outTop <- Out(inTop, fac = facTop)

panel(outProf, fac = "Orig", names = TRUE)
panel(outSide, fac = "Orig", names = TRUE)
panel(outTop, fac = "Orig", names = TRUE)

# Clean mem.
rm(list = "prime", "secon")
rm(list = "facProf", "facSide", "facTop")
rm(list = "inProf", "inSide", "inTop")

# Save =========================================================================
save(outProf, file = "./Archive/AllShapes/Dt.outProf")
save(outSide, file = "./Archive/AllShapes/Dt.outSide")
save(outTop, file = "./Archive/AllShapes/Dt.outTop")

load(file = "./Archive/AllShapes/Dt.outProf")
load(file = "./Archive/AllShapes/Dt.outSide")
load(file = "./Archive/AllShapes/Dt.outTop")

# Manipulate -------------------------------------------------------------------
manProf <- outProf %>%
  coo_slidedirection("N") %>%
  coo_center() %>%
  coo_smooth(50) %>%
  coo_sample(200)

manSide <- outSide %>%
  coo_alignxax() %>%
  coo_slidedirection("W") %>%
  coo_center() %>%
  coo_smooth(200) %>%
  coo_sample(400)

manTop <- outTop %>%
  coo_alignxax() %>%
  coo_slidedirection("W") %>%
  coo_center() %>%
  coo_smooth(200) %>%
  coo_sample(400)

# Elliptical Fourier Transform -------------------------------------------------
# - normalized side and top view - "better" results
efProf <- efourier(manProf, nb.h = 11, norm = FALSE, smooth.it = 0,
                   start = TRUE, verbose = TRUE)
efSide <- efourier(manSide, nb.h = 14, norm = TRUE, smooth.it = 0,
                   start = TRUE, verbose = TRUE)
efTop <- efourier(manTop, nb.h = 11, norm = TRUE, smooth.it = 0,
                  start = TRUE, verbose = TRUE)

# ANALYSIS =====================================================================
# PCA --------------------------------------------------------------------------
pcProf <- PCA(efProf)
pcSide <- PCA(efSide)
pcTop <- PCA(efTop)

# Scree plots
scree(pcProf, 1:5)
scree_min(pcProf, 0.98)
sp <- scree_plot(pcProf, 1:4)
pdf(file = "./AllShapes/pcContribProf.pdf", height = 5)
PCcontrib(pcProf, nax = 1:3, sd.r = c(-1, -0.5, 0, 0.5, 1))
dev.off()

scree(pcSide, 1:5)
scree_min(pcSide, 0.98)
ss <- scree_plot(pcSide, 1:4)
pdf(file = "./AllShapes/pcContribSide.pdf", height = 2.5, width = 10)
PCcontrib(pcSide, sd.r = c(-1.5, -1, -0.5, 0, 0.5, 1, 1.5))
dev.off()

scree(pcTop, 1:5)
scree_min(pcTop, 0.98)
st <- scree_plot(pcTop, 1:4)
pdf(file = "./AllShapes/pcContribTop.pdf", height = 2.5, width = 10)
PCcontrib(pcTop, nax = 1:3, sd.r = c(-1, -0.5, 0, 0.5, 1))
dev.off()

tp <- textGrob("(a) Prof (profil)")
ts <- textGrob("(b) Side (bokorys)")
tt <- textGrob("(c) Top (nárys)")

lay <- rbind(c(1,3,5),
             c(1,3,5),
             c(1,3,5),
             c(1,3,5),
             c(1,3,5),
             c(2,4,6))

pdf(file = "./AllShapes/screePlots.pdf", width = 10, height = 4)
grid.arrange(sp, tp, ss, ts, st, tt, layout_matrix = lay)
dev.off()

rm(list = "sp", "ss", "st", "tp", "ts", "tt", "lay")

# Plot PCA ---------------------------------------------------------------------
plot(pcProf, fac = "Morph")

# KMEANS -----------------------------------------------------------------------
# Count number of clusters K and perform kmeans clustering
# - elbow method (wss - within-clusters sum of squares)
# - stolen and modified from rbloggers (DataScience+, by Sunny Anand)
k.max <- 8

# Prof
wssProf <- sapply(1:k.max,
              function(k){kmeans(pcProf$x, k, nstart=50,
                                     iter.max = 15)$tot.withinss})

plot(1:k.max, wssProf,
     type="b", pch = 19, frame = FALSE,
     xlab="Number of clusters K (Prof)",
     ylab="Total within-clusters sum of squares")

# Side
wssSide <- sapply(1:k.max,
              function(k){kmeans(pcSide$x, k, nstart=50,
                                 iter.max = 15)$tot.withinss})

plot(1:k.max, wssSide,
     type="b", pch = 19, frame = FALSE,
     xlab="Number of clusters K (Side)",
     ylab="Total within-clusters sum of squares")

# Top
wssTop <- sapply(1:k.max,
              function(k){kmeans(pcTop$x, k, nstart=50,
                                 iter.max = 15)$tot.withinss})

plot(1:k.max, wssTop,
     type="b", pch = 19, frame = FALSE,
     xlab="Number of clusters K (Top)",
     ylab="Total within-clusters sum of squares")

# K means clustering
KMEANS(pcProf, 4, nax = 1:2)
KMEANS(pcSide, 2)
KMEANS(pcTop, 3)

# Hierarchical clustering ------------------------------------------------------
CLUST(pcProf, fac = "SalProfTvar", type = "phylogram",
      hclust_method = "ward.D2", tip_labels = "SalProfTvar")
CLUST(pcSide, fac = "SalTylBok", type = "phylogram",
      hclust_method = "ward.D2", tip_labels = "SalTylBok")
CLUST(pcTop, fac = "RM", type = "phylogram",
      hclust_method = "ward.D2", tip_labels = "RM")

# # Linear dicriminant analysis ------------------------------------------------
# plot(LDA(pcProf, fac = "Morph"))
# plot(LDA(pcSide, fac = "Morph"))
# plot(LDA(pcTop, fac = "Cult"))

# END ==========================================================================
graphics.off()
rm(list = ls())
gc()
.rs.restartR()
q("no")


library(jsonlite)

main <- function() {

#### Fetch command line arguments
myArgs <- commandArgs(trailingOnly = TRUE)

#### myArgs is a character vector of all arguments
###print(myArgs)
###print(class(myArgs))
data<-fromJSON(myArgs[2])
##print("JSON ")
##print(data[2])
##print(class(data[1]))
dd<-rnorm(10)
#print(dd)
x2_imp <-lapply(dd, function(x){x*x})
#print(x2_imp)
result<-lapply( data, function(x) {x**3})

print(list(result))
result<-toJSON(result)
print(result[1])
print(class(result))
return(result)
#  args <- commandArgs(trailingOnly = TRUE)

#  for (filename in args) {
#    dat <- read.csv(file = filename, header = FALSE)
#    mean_per_patient <- apply(dat, 1, mean)
#    cat(mean_per_patient, sep = "\n")
#  }
}

main()


#!/usr/bin/env Rscript

# Read the inputs
# 1. bed depth file
# 2. reference lengths <chr> <length> per line tsv
# 3. strata key
# 4. output file (.png or .pdf)
args=commandArgs(trailingOnly=TRUE)
if(length(args)<4) {
  stop("Must supply input depth, reference lengths, strata key, and output files\n",call.=FALSE)
}

# decide output type
filex = substr(args[4],nchar(args[4])-2,nchar(args[4]))
if(filex=="pdf") {
  pdf(args[4],bg="#FFFFFF")
} else if (filex=="png") {
  png(args[4],bg="#FFFFFF")
} else {
    stop("Unsupported type for output file.\n",call.=FALSE)
}

mytrans<-function(pos,clen,minlen,maxlen) {
  # find range it should cover
  tot = max((9/10)*(clen/maxlen)+(1/10),(1/10))
  return((pos/clen)*tot)
}

d<-read.csv(args[2],sep="\t",header=FALSE)
#ordered_names = as.vector(d[order(names(chrlens)),1])
#ordered_lens = as.vector(d[order(names(chrlens)),2])
ordered_names = as.vector(d[order(d[,1]),1])
ordered_lens = as.vector(d[order(d[,1]),2])
minlen = min(ordered_lens)
maxlen = max(ordered_lens)
chr = cbind.data.frame(ordered_names,ordered_lens)
longest = max(chr[,2])

dstrata<-read.csv(args[3],header=TRUE,sep="\t")

layout(rbind(c(1,2)),heights=c(1),widths=c(4,1))
par(mar=c(5,1,1,1))
plot(1,type="n",xlim=c(1,length(ordered_names)),ylim=c(0,1),bty="n",xaxt="n",yaxt="n",xlab="",ylab="")
par(las=2)
mtext(ordered_names,side=1,at=1:length(ordered_names))
par(las=1)
for (i in 1:length(ordered_names)) {
  clen = ordered_lens[i]
  rect(i-0.4,0,i+0.4,mytrans(chr[i,2],clen,minlen,maxlen))
}
e<-read.csv(gzfile(args[1]),sep="\t",header=FALSE)
f<-e[order(e[,4]),]
colfunc<-colorRampPalette(c("#00000088","#0000FF88","#FF000088"))
colarray<-colfunc(length(dstrata[,1]))
cind = i
for(i in 1:length(f[,1])) {
  cind = match(f[i,1],ordered_names)
  clen = ordered_lens[cind]
  #print(f[i,4])
  fcol = colarray[f[i,4]]
  #print(fcol)
  rect(cind-0.4,mytrans(f[i,2],clen,minlen,maxlen),cind+0.4,mytrans(f[i,3],clen,minlen,maxlen),col=fcol,border=fcol,lwd=0.01)
}
par(mar=c(10,0,10,5))
plot(1,type="n",xlim=c(0,2),ylim=c(0,1),xaxt="n",yaxt="n",xlab="",ylab="",bty="n")
mindepth = min(dstrata[1,])
maxdepth = max(dstrata[1,])
z = 0
step = 1/length(f[,4])
legend(-1,1,legend=dstrata[,1],fill=rev(colarray),xpd=TRUE,bty='n')
dev.off()


# TODO: Allow empty range field, Allow plate ranges
#
wellrange <- function(range,first="row"){
	#Check format
	if (!grepl("[A-Za-z]+\\d+-[A-Za-z]+\\d+",range)) {
		warning("Range must be of format A2-C4\n")
	}
	#Split out the start and end of the range
	range <- unlist(strsplit(range,"-"))
	if (length(range) > 2) { warning("More than one dash in range given") }
	range_start = range[1]
	range_end = range[2]
	range_start_row = toupper(sub("\\d+","",range_start))
	range_start_col = as.integer(sub("[A-Za-z]+","",range_start))
	range_end_row = toupper(sub("\\d+","",range_end))
	range_end_col = as.integer(sub("[A-Za-z]+","",range_end))
	# Append A for 1536 well plates
	letters = c(LETTERS,paste("A",LETTERS,sep=""))
	row_range = letters[which(letters==range_start_row):which(letters==range_end_row)]
	col_range = seq(from=range_start_col, to=range_end_col)

	if (first=="row") {
		first = row_range
		second = col_range
		label1="Row"
		label2="Column"
	} else {
		first = col_range
		second = row_range
		label2="Row"
		label1="Column"
	}
	output = data.frame(matrix(nrow=1,ncol=2))
	for (i in first) {
		for (j in second) {
			output <- rbind(output,c(i,j))
		}
	}
	names(output) <- c(label1,label2)
	#First row has NA values
	output <- output[-1,]
	#Sort by first then second (i.e. row then column default)
	#nchar needed to handle AA, AB... rows
	output[order(nchar(output[,1]),output[,1],as.integer(output[,2])),]
}

condition_wells <- function(wells,cname,value) {
	df <- wellrange(as.character(wells))
	df[,as.character(cname)]=value
	df

}

add_zero_to_single <- function(x) {
	if (as.integer(x) < 10) {
		paste("0",as.character(x),sep="")
	} else {
		x
	}
}

annotate_plate <- function(df,type=96,plate=1,area=2,condition=3,value=4) {
# For stuff replicated across plates, can use this with by functions
# DF provided needs Plate, Area, Condition, Value columns with indexes as in default args

	# set up the plate types
	nplates = length(unique(df[,plate]))
	if (type == 96) {
		fullplate = "A1-H12"
	} else {
		if (type == 384) {
			fullplate <- "A1-P24"
		} else {
			if (type == 1536) {
				fullplate <- "A1-AF48"
			}
		}
	}
	wells = wellrange(fullplate)
	# Apply the annotation
	# If Area is empty, apply to whole plate
	df[df[,area] == "",area] <- fullplate

	# If Plates field is empty, apply to all plates
	plate_empty <- df[is.na(df[,plate]),]
	if (nrow(plate_empty) != 0) {
	# Remove old empty plate rows
		df <- df[!is.na(df[,plate]),]

	# Makes a list of duplicate data frames, one for each plate
		new_rows <- lapply(unique(df[,plate]), function(x,pe) { temp = pe; temp$Plate = x; temp },pe=plate_empty)

	# Add the new ones
		new_rows$new = df
		df <- do.call(rbind,new_rows)

	}
	plate_ranges <- df[grep("-",df[,plate]),]
	# TODO: get range, make duplicate DF rows for each plate in range (as above)

	# Remove any lines where the condition or value is NA

	# Set up the plates data frame
	lst = list()
	for (i in unique(df[,plate])) {
		lst[[i]] = wells
		lst[[i]][,"Plate"] <- i
	}
	plates <- do.call(rbind, lst)

	#anno is a list of data frames
	#Now merge all of these with the plates data frame
	annolist = list()
	for (i in unique(df[,condition])) {
		anno <- df[df[,condition] == i,]
		# Expand well ranges
		anno <- apply(anno,1,function(x) {dft <- condition_wells(x[area],x[condition],x[value]); dft$Plate = x[plate]; dft})
	#	anno$plates <- plates
	#	annolist[[i]] <- Reduce(function(x,y) merge(x,y,by=c("Plate","Row","Column"),all=T), anno)
		tempplates <- plates
		for (j in anno) {
			tempplates <- merge(tempplates,j,all=T)
		}
		# Generates NAs for some reason, remove
		tempplates <- tempplates[!is.na(tempplates[,4]),]
		annolist[[i]] <- tempplates
	}
	red <- Reduce(function(x,y) merge(x,y,all=T),annolist)
	red <- red[!apply(red,1,function(x) any(is.na(x))),]
	# Add leading zeros and make a Well column by combining row + zerocolumn
	red$Well <- paste(red$Row, sapply(red$Column,add_zero_to_single),sep="")
	red[order(nchar(red$Row),red$Row,as.integer(red$Column)),]
}


library("RCurl")
library("rjson")
source('C:\\Program Files\\R\\R-3.3.1\\library\\Functions.R');

getPIPointWebId <- function(piDataArchive, piPointName) {
    path = paste(c("\\\\", piDataArchive, "\\" , piPointName))
	compl_url= paste(c("/points?path=", path),collapse="");
	x = getHttpRequest(compl_url)
	x$WebId
}

getInterpolatedValues <- function(startTime, endTime, interval, webId1, webId2, webId3) {
	webIdsString= paste(c(webId1, webId2, webId3),collapse="&webId=");
	print(webIdsString)
	compl_url= paste(c("/streamsets/interpolated?starttime=",startTime,"&endtime=",endTime,"&interval=",interval,"&webId=", webIdsString),collapse="");
	compl_url
	x = getHttpRequest(compl_url)
}

getHttpRequest  <- function(compl_url) {
	base_url = 'https://marc-web-sql.marc.net/piwebapi'
	url = paste(c(base_url, compl_url),collapse="");
	w=getURL(url,httpheader = c(Authorization = "Basic bsdgyYy5hZG06a2s="), ssl.verifypeer = FALSE);
	x=fromJSON(w);
}

tag1name = 'FAC.OAK.Weather-Inside_Humidity-Val.PV';
tag2name = 'FAC.OAK.Weather-Inside_Temperature-Val.PV';
tag3name = 'FAC.OAK.Weather-Outside_Temperature-Val.PV';
webId1 = getPIPointWebId('marc-pi2016',tag1name);
webId2 = getPIPointWebId('marc-pi2016',tag2name);
webId3 = getPIPointWebId('marc-pi2016',tag3name);
values = getInterpolatedValues('1-Oct-2012','1-Nov-2012','1h', webId1, webId2, webId3);

i=1;
v1 = 1: length(values$Items[[1]]$Items)
v2 = 1: length(values$Items[[2]]$Items)
v3 = 1: length(values$Items[[3]]$Items)

for (value in  values$Items[[1]]$Items){
  v1[i] = value$Value
 i = i + 1
}

i=1;
for (value in  values$Items[[2]]$Items){
  v2[i] = value$Value
 i = i + 1
}

i=1;
for (value in  values$Items[[3]]$Items){
  v3[i] = value$Value
 i = i + 1
}

impact3<-data.frame(v1,v2,v3);
tn3<-c(tag1name,tag2name,tag3name);
PI_Multi_Correlation3(impact3,tn3);

Chapter10 - Retrieving PI Data into R/rCurl/piwebapi.r


\name{merge_dendrogram}
\alias{merge_dendrogram}
\title{
Merge Dendrograms
}
\description{
Merge Dendrograms
}
\usage{
merge_dendrogram(x, y, only_parent = FALSE, ...)
}
\arguments{

  \item{x}{The parent dendrogram.}
  \item{y}{The children dendrograms. They are connected to the leaves of the parent dendrogram. So the length of \code{y} should be as same as the number of leaves of the parent dendrogram.}
  \item{only_parent}{Whether only returns the parent dendrogram where the height and node positions have been adjusted by children dendrograms.}
  \item{...}{Other arguments.}

}
\details{
Do not retrieve the order of the merged dendrogram. It is not reliable.
}
\examples{
m1 = matrix(rnorm(100), nr = 10)
m2 = matrix(rnorm(80), nr = 8)
m3 = matrix(rnorm(50), nr = 5)
dend1 = as.dendrogram(hclust(dist(m1)))
dend2 = as.dendrogram(hclust(dist(m2)))
dend3 = as.dendrogram(hclust(dist(m3)))
dend_p = as.dendrogram(hclust(dist(rbind(colMeans(m1), colMeans(m2), colMeans(m3)))))
dend_m = merge_dendrogram(dend_p, list(dend1, dend2, dend3))
grid.dendrogram(dend_m, test = TRUE)

dend_m = merge_dendrogram(dend_p, list(dend1, dend2, dend3), only_parent = TRUE)
grid.dendrogram(dend_m, test = TRUE)

require(dendextend)
dend1 = color_branches(dend1, k = 1, col = "red")
dend2 = color_branches(dend2, k = 1, col = "blue")
dend3 = color_branches(dend3, k = 1, col = "green")
dend_p = color_branches(dend_p, k = 1, col = "orange")
dend_m = merge_dendrogram(dend_p, list(dend1, dend2, dend3))
grid.dendrogram(dend_m, test = TRUE)
}


#==========
#convert sp lines to dataframe
#==========
  lines2dataframe<-function(lines){
	  a<-data.frame()
	  k<-1
	  for(i in 1:length(lines)){
		  for(j in 1:length(lines@lines[[i]]@Lines)){
			  l<-data.frame(lines@lines[[i]]@Lines[[j]]@coords,
						rep(k,length(lines@lines[[i]]@Lines[[j]]@coords[,1])),
						rep(lines@lines[[i]]@ID,length(lines@lines[[i]]@Lines[[j]]@coords[,1])))

			  a<-rbind(a,l)
			  k<-k+1
		}
	}

	names(a)<-c("lon","lat","group","id")
	return(a)
}


install.packages("WDI")
install.packages("wbstats")
library(WDI)
library(wbstats)

df = data.frame(
  Year=c(2013, 2013, 2013),
  Country=c("Arab World","Caribbean States", "Central Europe"),
  LifeExpectancy=c(71, 72, 76))

df
head(df)
df[2, "Country"]
summary(df)

df$Year <- as.factor(df$Year)

df <- data.frame(

#  data.table(
  wb(indicator = c("SP.POP.TOTL",
                   "SP.DYN.LE00.IN",
                   "SP.DYN.TFRT.IN"), mrv = 60)
)

df$date <- as.factor(df$date)

summary(df)

# Installation of Rserve
install.packages("Rserve")
library(Rserve)
Rserve()

# Iris
head(iris)
IrisBySpecies <- split(iris,iris$Species)

output <- list()

for(n in names(IrisBySpecies)){

  ListData <- IrisBySpecies[[n]]

  output[[n]] <- data.frame(species=n,

                            MinPetalLength=min(ListData$Petal.Length),

                            MaxPetalLength=max(ListData$Petal.Length),

                            MeanPetalLength=mean(ListData$Petal.Length),

                            NumberofSamples=nrow(ListData))

  output.df <- do.call(rbind,output)

}

print(output.df)


#' Flexible RD Plot
#' @export
#'
rdplot <- function(object, ...) {
  UseMethod("rdplot")
}

#'
#' @param object object
#' @param usemod numeric vector. which models do you want to plot?
#' @param treat_label string vector of treatment and control label
#' @param ate_label_size In-plot text size
#' @param ate_label_digits decimal places of in-plot ATE result.
#' @param ate_label_format string of label format of in-plot ATE result.
#'   The format produces labels according to a unique grammar.
#'   If you want to embed a numerical value related to the estimation result,
#'   you need to enclose it in {}.
#'   \itemize{
#'     \item `{estimate}`: embed coefficient value (Local ATE)
#'     \item `{std.error}`: embed standard error of coefficient
#'     \item `{statistic}`: embed z-score of coefficient
#'     \item `{p.value}`: embed p-value of coefficient
#'     \item `{star}`: show *** if p-value <= 0.01;
#'       ** if p-value <= 0.05; * if p-value <= 0.1
#'   }
#' @param outcome_label Outcome label in plot title
#' @param ylim numeric vector of limits of y-axis
#' @param vjust numeric. Adjust in-plot text vertically
#' @param hjust numeric. Adjust in-plot text horizontally
#' @param xlab label of x-axis
#' @param ylab label of y-axis
#' @param patchwork logical.
#'   add a list of plots into one composition by `patchwork::wrap_plots`
#' @param ncol the dimensions of the grid to create.
#'   argument of `patchwork::wrap_plots`
#' @param nrow the dimensions of the grid to create.
#'   argument of `patchwork::wrap_plots`
#' @param \dots arguments of [simplegg()]
#'
#' @importFrom stats aggregate
#' @importFrom stats predict
#' @importFrom patchwork wrap_plots
#' @importFrom patchwork plot_layout
#' @importFrom ggplot2 theme
#' @importFrom rlang quo
#' @importFrom rlang enquos
#' @importFrom rlang quo_is_missing
#' @importFrom rlang eval_tidy
#' @export
#' @examples
#' running <- sample(1:100, size = 1000, replace = TRUE)
#' cov1 <- rnorm(1000, sd = 2); cov2 <- rnorm(1000, mean = -1)
#' y0 <- running + cov1 + cov2 + rnorm(1000, sd = 10)
#' y1 <- 2 + 1.5 * running + cov1 + cov2 + rnorm(1000, sd = 10)
#' y <- ifelse(running <= 50, y1, y0)
#' bin <- ifelse(y > mean(y), 1, 0)
#' w <- sample(c(1, 0.5), size = 1000, replace = TRUE)
#' raw <- data.frame(y, bin, running, cov1, cov2, w)
#'
#' set_optDiscRD(
#'   y + bin ~ running,
#'   discRD.cutoff = 50,
#'   discRD.assign = "smaller"
#' )
#'
#' est <- global_lm(data = raw, weights = w)
#'
#' rdplot(
#'   est,
#'   usemod = c(1, 2),
#'   treat_label = c("Treated", "Control"),
#'   outcome_label = switch(x,
#'     "1" = "Simulated outcome",
#'     "2" = "Simulated outcome > 0"
#'   ),
#'   ylab = "Weighted Average",
#'   ate_label_size = 4
#' )
#'
#' @name rdplot
#'
rdplot.list_global_lm <- function(object,
                                  usemod,
                                  treat_label = c("treated", "control"),
                                  ate_label_size = 5,
                                  ate_label_digits = 3,
                                  ate_label_format,
                                  outcome_label,
                                  ylim,
                                  vjust = 0,
                                  hjust = 0,
                                  xlab = "Running variable",
                                  ylab = "Average",
                                  patchwork = TRUE,
                                  ncol = NULL,
                                  nrow = NULL,
                                  ...) {
  # observed data aggregated by mass points
  x <- i <- NULL
  vars <- c("outcome", "weights", "d")
  aggregate_quo <- rlang::quo({
    data <- recover_data(object, i)
    data$outcome <- data$outcome * data$weights
    agdt <- aggregate(data[, vars], by = list(x = data$x), mean)
    agdt$outcome <- agdt$outcome / agdt$weights
    agdt$x <- agdt$x + object$result[[i]]$RD.info$cutoff
    agdt$d <- factor(agdt$d, levels = c(1, 0), labels = treat_label)
    agdt
  })

  # prediction data
  prediction_quo <- rlang::quo({
    data <- recover_data(object, i)
    newdt <- data[, !(names(data) %in% vars)]
    newdt <- newdt[!duplicated(newdt), ]
    predict(object$result[[i]], newdata = newdt)
  })

  # subset condition for prediction data
  condmake <- rlang::quo({
    switch(object$result[[i]]$RD.info$assign,
      "greater" = rlang::quo(x >= 0),
      "smaller" = rlang::quo(x <= 0)
    )
  })

  # In-plot label about result of local ATE
  if (missing(ate_label_format)) {
    label <- "Local ATE: {estimate}{star}({std.error})"
  } else {
    label <- ate_label_format
  }

  label_quo <- rlang::quo({
    res <- object$result[[i]]
    label_maker(res, label, ate_label_digits)
  })

  # Other arguments for plot manipulation
  pargs <- rlang::enquos(
    ate_label_size = ate_label_size,
    outcome_label = outcome_label,
    ylim = ylim,
    vjust = vjust,
    hjust = hjust,
    xlab = xlab,
    ylab = ylab
  )

  pargs <- Filter(Negate(rlang::quo_is_missing), pargs)

  # Arguments for template
  tmparg <- list(...)

  # draw plots
  if (missing(usemod)) usemod <- seq_len(length(object$result))

  plist <- lapply(usemod, function(m) {
    # eval arguments
    args <- list()
    args$aggregate <- rlang::eval_tidy(aggregate_quo, list(i = m))
    pred <- rlang::eval_tidy(prediction_quo, list(i = m))
    cond <- rlang::eval_tidy(condmake, list(i = m))
    bool <- rlang::eval_tidy(cond, pred)
    args$predict1 <- pred[bool, ]
    args$predict0 <- pred[!bool, ]
    args$ate_label <- rlang::eval_tidy(label_quo, list(i = m))
    args$cutoff <- object$result[[m]]$RD.info$cutoff

    # eval pargs
    eval_pargs <- lapply(pargs, rlang::eval_tidy, list(x = as.character(m)))
    args <- append(args, eval_pargs)

    # draw plot
    do.call("rdplot_internal_cutoff", append(args, tmparg))
  })

  if (patchwork) {
    patchwork::wrap_plots(plist, ncol = ncol, nrow = nrow) +
      patchwork::plot_layout(guides = "collect") &
      ggplot2::theme(legend.position = "bottom")
  } else {
    plist
  }
}

#'
#' @name rdplot
#' @param force logical. Whether to ignore error about estimation
#'
#' @importFrom stats aggregate
#' @importFrom patchwork wrap_plots
#' @importFrom patchwork plot_layout
#' @importFrom ggplot2 theme
#' @importFrom rlang quo
#' @importFrom rlang enquos
#' @importFrom rlang quo_is_missing
#' @importFrom rlang eval_tidy
#' @export
#' @examples
#' nonpara <- local_lm(
#'   submod = 1,
#'   data = raw,
#'   kernel = "uniform",
#'   bw = 5,
#'   order = 1:3
#' )
#'
#' rdplot(
#'   nonpara,
#'   usemod = 2,
#'   outcome_label = switch(x,
#'     "1" = "Order = 1",
#'     "2" = "Order = 2",
#'     "3" = "Order = 3"
#'   )
#' )
#'
rdplot.list_local_lm <- function(object,
                                 usemod,
                                 treat_label = c("treated", "control"),
                                 ate_label_size = 5,
                                 ate_label_digits = 3,
                                 ate_label_format,
                                 outcome_label,
                                 ylim,
                                 vjust = 0,
                                 hjust = 0,
                                 xlab = "Running variable",
                                 ylab = "Average",
                                 patchwork = TRUE,
                                 ncol = NULL,
                                 nrow = NULL,
                                 force = TRUE,
                                 ...) {
  # observed data aggregated by mass points
  i <- NULL
  vars <- c("outcome", "sweight", "d")
  aggregate_quo <- rlang::quo({
    data <- recover_data(object, i)
    data$outcome <- data$outcome * data$sweight
    agdt <- aggregate(data[, vars], by = list(x = data$x), mean)
    agdt$outcome <- agdt$outcome / agdt$sweight
    agdt$x <- agdt$x + object$result[[i]]$RD.info$cutoff
    agdt$d <- factor(agdt$d, levels = c(1, 0), labels = treat_label)
    agdt
  })

  # prediction data
  predict1_quo <- rlang::quo({
    fit <- fit_local_lm(
      object$result[[i]]$treat, extend = 0, force = force
    )
    colnames(fit)[colnames(fit) == "yhat"] <- "yhat1"
    fit
  })

  predict0_quo <- rlang::quo({
    fit <- fit_local_lm(
      object$result[[i]]$control, extend = 0, force = force
    )
    colnames(fit)[colnames(fit) == "yhat"] <- "yhat0"
    fit
  })

  # In-plot label about result of local ATE
  if (missing(ate_label_format)) {
    label <- "Local ATE: {estimate}{star}({std.error})"
  } else {
    label <- ate_label_format
  }

  label_quo <- rlang::quo({
    res <- object$result[[i]]
    label_maker(res, label, ate_label_digits)
  })

  # Other arguments for plot manipulation
  pargs <- rlang::enquos(
    ate_label_size = ate_label_size,
    outcome_label = outcome_label,
    ylim = ylim,
    vjust = vjust,
    hjust = hjust,
    xlab = xlab,
    ylab = ylab
  )

  pargs <- Filter(Negate(rlang::quo_is_missing), pargs)

  # Arguments for template
  tmparg <- list(...)

  # draw plots
  if (missing(usemod)) usemod <- seq_len(length(object$result))

  plist <- lapply(usemod, function(m) {
    # eval arguments
    args <- list()
    args$aggregate <- rlang::eval_tidy(aggregate_quo, list(i = m))
    args$predict1 <- rlang::eval_tidy(predict1_quo, list(i = m))
    args$predict0 <- rlang::eval_tidy(predict0_quo, list(i = m))
    args$ate_label <- rlang::eval_tidy(label_quo, list(i = m))
    args$cutoff <- object$result[[m]]$RD.info$cutoff

    # eval pargs
    eval_pargs <- lapply(pargs, rlang::eval_tidy, list(x = as.character(m)))
    args <- append(args, eval_pargs)

    # draw plot
    do.call("rdplot_internal_cutoff", append(args, tmparg))
  })

  if (patchwork) {
    patchwork::wrap_plots(plist, ncol = ncol, nrow = nrow) +
      patchwork::plot_layout(guides = "collect") &
      ggplot2::theme(legend.position = "bottom")
  } else {
    plist
  }
}


# Legibility and Clarity

rm(list=ls())
library(ggplot2)
library(dplyr)
library(reshape2)
library(gridExtra)
library(survival)
library(ggfortify)

#######################################################
## Novartis look and feel functions
#######################################################
Novartis.Color.Palette <- structure(
  c(  "#0460A9", "#CDDFEE", "#9BBFDD", "#68A0CB", "#03487F", "#023054",
      "#E74A21", "#FADBD3", "#F5B7A6", "#F1927A", "#AD3819", "#742510",
      "#EC9A1E", "#FBEBD2", "#F7D7A5", "#F4C278", "#B17416", "#764D0F",
      "#8D1F1B", "#E8D2D1", "#D1A5A4", "#BB7976", "#6A1714", "#46100E",
      "#7F7F7F", "#E5E5E5", "#CCCCCC", "#B2B2B2", "#5F5F5F", "#404040",
      "#CCCCCC", "#F5F5F5", "#EBEBEB", "#E0E0E0", "#999999", "#666666",
      "#404040", "#D9D9D9", "#B3B3B3", "#8C8C8C", "#303030", "#202020"
  ),.Dim = c(6L, 7L),
  .Dimnames = list(c("Hue", "Tint3", "Tint2", "Tint1", "Shade1", "Shade2"),
                   c("Novartis Blue", "Sienna", "Apricot", "Carmine",
                     "Gray", "Light Gray", "Dark Gray")))

ggColor <- function(n.colors = 50, color.values = c("Hue", "Tint1", "Shade1"),
                    color.hues = c(1:4)){
  color.vec <- as.vector(t(Novartis.Color.Palette[color.values,color.hues]))

  rep.colors <- 1
  if(n.colors > length(color.vec)){
    rep.colors <- ceiling(n.colors/length(color.vec))
  }

  ggcolor <- scale_color_manual(values = rep(color.vec,rep.colors))
  return(ggcolor)
}

ggFill <- function(n.colors = 42, color.values = c("Hue", "Tint1", "Shade1"),
                   color.hues = c(1:4)){
  color.vec <- as.vector(t(Novartis.Color.Palette[color.values,color.hues]))

  rep.colors <- 1
  if(n.colors > length(color.vec)){
    rep.colors <- ceiling(n.colors/length(color.vec))
  }

  ggcolor <- scale_fill_manual(values = rep(color.vec,rep.colors))
  return(ggcolor)
}

## Set theme
theme_set(theme_minimal(base_size=18))
th <- theme(panel.grid.minor=element_blank(),
            panel.grid.major=element_blank(),
            axis.title.y=element_blank(),
            axis.text.y=element_blank(),
            axis.title.x=element_blank(),
            axis.text.x=element_blank(),
            strip.background = element_rect(fill = "lightgrey", colour = "grey50"),
            panel.background = element_rect(fill = "white", colour = "grey50")
)

###############################################################################
## Annotated dose response curve
## Label axes with clear measurement units and
## provide annotations that support the message.
###############################################################################

## make data
set.seed(12345666)
Dose = seq(0,10,0.1)
DAY = floor(Dose/24)
K1 = 0.2
K2 = 0.8
Response = 100*(Dose/1)/(Dose/1 + 1)
my.data <- data.frame(Dose = Dose, Response = Response,
                      ymin = Response - 0.1*Response - 5,
                      ymax = Response + 0.1*Response + 5,
                      obs = Response +
                        5*rnorm(length(Response)) +
                        0.1*rnorm(length(Response))*Response,
                      DAY = DAY)

## plot
a1 <- ggplot(data = my.data, aes(x = Dose, y = Response)) +
  geom_point(data = my.data[Dose%in%c(0.1,1,2.5,5,10),],
                      aes(x=Dose, y=obs),size = 4) +
  geom_errorbar(data = my.data[Dose%in%c(0.1,1,2.5,5,10),],
                aes(x=Dose, ymin=obs-5-0.1*obs, ymax = obs+5+0.1*obs),size = 1) +
  xlab("Dose") +
  ylab("Response") +
  coord_cartesian(ylim = c(-10,120)) +
  geom_line(size = 1) +
  geom_ribbon(aes(ymin = ymin, ymax=ymax), fill = rgb(0.5,0.5,0.5), alpha = 0.5) +
  geom_point(data = my.data[Dose%in%c(0.1,1,2.5,5,10),],
             aes(x=Dose, y=obs),size = 4) +
  geom_errorbar(data = my.data[Dose%in%c(0.1,1,2.5,5,10),],
                aes(x=Dose, ymin=obs-5-0.1*obs, ymax = obs+5+0.1*obs),size = 1) +
  theme_bw(base_size = 16) +
  theme(panel.grid.minor=element_blank(),
        panel.grid.major=element_blank(),
        legend.position="none",
        axis.text.x=element_text(size = 12)
  )

ggsave(a1, file="GWLeg_a1.png", width = 80, height = 80, units = "mm", dpi = 300)

## Add informative annotations
a2 <- a1 + geom_hline(yintercept = 80, color = "red", linetype = "dashed", size = 1, alpha = 0.4)+
  geom_ribbon(data = data.frame(x=c(0,10), y=c(80,80), ymin = c(70,70), ymax = c(90,90)),
              aes(x = x, y=y, ymin = ymin, ymax = ymax), fill = "red", alpha = 0.2)+
  scale_x_continuous(breaks = c(0.1,1,2.5,5,10), labels = c(0.1,1,2.5,5,10)) +
  geom_line(data = data.frame(x = c(2.5, 8), y = c(-7,-7)), aes(x=x, y=y), color = "red") +
  geom_point(data = data.frame(x = 4, y=-7), aes(x=x, y=y), color = "red", size = 2) +
  annotate("text", label = "Target dose", x = 8, y = 0, color = "red") +
  annotate("text", label = "Active control", x = 8, y = 60, color = "red") +
  xlab("Dose (mg)") + ylab("Response") +
  theme(panel.grid.major=element_line(color = "lightgrey", size = 0.4))

a2
ggsave(a2, file="GWLeg_a2.png", width = 80, height = 80, units = "mm", dpi = 300)

###############################################################################
## Simple survival plot
## Use font size to create a visual hierarchy
###############################################################################

## data
df <- lung
df$sex <- plyr::mapvalues(df$sex, c(1,2),c("Male","Female"))
df$sex <- factor(df$sex, levels = c("Male","Female"))
fit <- survfit(Surv(time, status) ~ sex, data = df)

b1 <-autoplot(fit, conf.int = FALSE, censor = FALSE, surv.size = 2) +
  theme_minimal() +
  ggColor() +
  labs(title="Survival Analysis") +
  xlab("Time (years)") +
  ylab("Survival Rate (%)")+
  theme(plot.title = element_text(hjust = 0.5),
        axis.ticks = element_blank(),
        axis.line = element_blank(),
        panel.grid.minor.y=element_blank(),
        panel.grid.major.y=element_blank(),
        panel.background=element_blank(),
        axis.text.x=element_text(size=10),
        axis.text.y=element_text(size=12),
        legend.title = element_blank(),
        legend.position=c(0.75,0.75),
        legend.text = element_text(size = 12),
        title=element_text(size=8),
        axis.title.x = element_text(size = 16, face = "bold"),
        axis.title.y = element_text(size = 12)
  )
ggsave(b1, file="GWLeg_b1.png", width = 80, height = 80, units = "mm", dpi = 300)

b2 <-autoplot(fit, conf.int = FALSE, censor = FALSE, surv.size = 2) +
  theme_minimal() + ggColor() +
  labs(title="Survival Analysis") +
  xlab("Time (years)") +
  ylab("Survival Rate (%)")+
  theme(plot.title = element_text(hjust = 0.5),
        axis.ticks = element_blank(),
        axis.line = element_blank(),
        #axis.text.y=element_blank(),
        panel.grid.minor.y=element_blank(),
        panel.grid.major.y=element_blank(),
        panel.background=element_blank(),
        axis.text.x=element_text(size=10),
        axis.text.y=element_text(size=12),
        legend.title = element_blank(),
        legend.position=c(0.75,0.75),
        legend.text = element_text(size = 12),
        title=element_text(face="bold", size=14)
  )

ggsave(b2, file="GWLeg_b2.png", width = 80, height = 80, units = "mm", dpi = 300)

####################################################################################
## Simple bar chart
## Don't use too small or too condensed text, Dont capitalize everything
####################################################################################

# create toy data
DF <- data.frame(
  lab = c("C4", "C3", "C2", "C1"),
  value = c(0.05,0.15,0.3,0.5),
  Category = c(4,3,2,1)
)

c1 <- ggplot(DF, aes(reorder(lab,value), value)) +
  geom_bar(width = 0.85, stat = "identity", color = "white") +
  geom_text(aes(x=lab, y=value, label=value),nudge_y=0.1, size=6.5) +
  scale_y_continuous(limits = c(0, 1)) +
  labs(title="Subgroup incidence rate") +
  theme(plot.title = element_text(hjust = 0.5),
        axis.ticks = element_blank(),
        axis.line = element_blank(),
        axis.title=element_blank(),
        panel.grid.minor.y=element_blank(),
        panel.grid.major.y=element_blank(),
        axis.text.x=element_text(size=18),
        axis.text.y=element_text(size=10),
        legend.position="none",
        title=element_text(face="bold", size=8)
        ) +
  coord_flip()

ggsave(c1, file="GWLeg_c1.png", width = 80, height = 80, units = "mm", dpi = 300)

c2 <- ggplot(DF, aes(reorder(lab,value), value)) +
  geom_bar(width = 0.65, stat = "identity",color = "white") +
  geom_text(aes(x=lab, y=value, label=value),nudge_y=0.15, size=4) +
  scale_y_continuous(limits = c(0, 1)) +
  labs(title="Subgroup \nincidence rate") +
  theme(plot.title = element_text(hjust = 0.5),
        axis.ticks = element_blank(),
        axis.line = element_blank(),
        axis.title=element_blank(),
        panel.grid.minor.y=element_blank(),
        panel.grid.major.y=element_blank(),
        panel.background=element_blank(),
        axis.text.x=element_text(size=10),
        axis.text.y=element_text(size=12),
        legend.position="none",
        title=element_text(face="bold", size=14)
        )  +
  coord_flip()

ggsave(c2, file="GWLeg_c2.png", width = 80, height = 80, units = "mm", dpi = 300)

############################################################################
## Simple forest plot
## Use sans serif fonts
############################################################################

# Make data
df <- data.frame(Dose=c(100, 200, 400, 800))
df$Response <- df$Dose/(df$Dose + 200)
df$ymin <- df$Response*exp(0.2)
df$ymax <- df$Response*exp(-0.2)

# plot
d1 <- ggplot(data = df) +
  geom_point(aes(x = Dose, y = Response), size = 4) +
  geom_errorbar(aes(x= Dose, ymin = ymin, ymax = ymax)) +
  scale_y_continuous(limits = c(0, 1)) +
  ggtitle("Dose Reponse") +
  theme_minimal(base_size = 18) +
  theme(title=element_text(face="bold",size=18, family="serif"),
        plot.title = element_text(hjust = 0.5),
        axis.title = element_text( family="serif"),
        axis.text = element_text(family = "serif", size = 12)
        )

ggsave(d1, file="GWLeg_d1.png", width = 80, height = 80, units = "mm", dpi = 300)

d2 <- ggplot(data = df) +
  geom_point(aes(x = Dose, y = Response), size = 4) +
  geom_errorbar(aes(x= Dose, ymin = ymin, ymax = ymax)) +
  scale_y_continuous(limits = c(0, 1)) +
  ggtitle("Dose Reponse") +
  theme_minimal(base_size = 18) +
  theme(title=element_text(size=18),
        axis.text = element_text(size = 12),
        plot.title = element_text(hjust = 0.5)
        )

ggsave(d2, file="GWLeg_d2.png", width = 80, height = 80, units = "mm", dpi = 300)

######################################################################################
## Simple bar chart
## Display text with enough contrast to be visible.
## Favor dark text on light backgrounds over light on dark whenever possible.
######################################################################################

# create toy data
DF <- data.frame(lab = c("Category 4", "Category 3", "Category 2", "Category 1"),
                 value = c(0.05,0.15,0.3,0.5),
                 Category = c(4,3,2,1)
                 )

e1 <- ggplot(DF[DF$lab!="Category 4",], aes(reorder(Category,lab), value)) +
  geom_bar(width = 0.65, stat = "identity",color = "white") +
  geom_text(aes(x=Category, y=value, label=value*100,fontface="bold"),
            nudge_y=-0.05, size=7, color = "white") +
  scale_y_continuous(limits = c(0, 1)) +
  geom_hline(yintercept = 0, colour = "wheat4", linetype=1, size=0.8)+
  theme(plot.title = element_text(hjust = 0.5),
        axis.ticks = element_blank(),
        axis.line = element_blank(),
        axis.text.y=element_blank(),
        axis.text.x = element_blank(),
        axis.title=element_blank(),
        panel.grid.minor.x=element_blank(),
        panel.grid.major.x=element_blank(),
        panel.background=element_blank(),
        legend.position="none",
        title=element_text(face="bold", size=14)
        )

ggsave(e1, file="GWLeg_e1.png", width = 80, height = 80, units = "mm", dpi = 300)

e2 <- ggplot(DF[DF$lab!="Category 4",], aes(reorder(Category,lab), value)) +
  geom_bar(width = 0.65, stat = "identity",color = "white") +
  geom_text(aes(x=Category, y=value, label=value*100),
            nudge_y=0.05, size=7, color = "black") +
  scale_y_continuous(limits = c(0, 1)) +
  geom_hline(yintercept = 0, colour = "wheat4", linetype=1, size=0.8) +
  theme(plot.title = element_text(hjust = 0.5),
        axis.ticks = element_blank(),
        axis.line = element_blank(),
        axis.text.y=element_blank(),
        axis.text.x = element_blank(),
        axis.title=element_blank(),
        panel.grid.minor.x=element_blank(),
        panel.grid.major.x=element_blank(),
        panel.background=element_blank(),
        legend.position="none",
        title=element_text(face="bold", size=14)
        )

ggsave(e2, file="GWLeg_e2.png", width = 80, height = 80, units = "mm", dpi = 300)

##########################################################################################
## Simple scatter plot
## Bold and italics should only be used for layering.
## Emphasizing everything means nothing gets emphasized.
##########################################################################################

## make data
set.seed(12345666)
my_data <- data.frame(Bodyweight = 90 + 20*c(-runif(50), runif(50)))
my_data$Exposure <- ((my_data$Bodyweight/90)^-0.75)*exp(0.1*rnorm(length(my_data$Bodyweight)))
my_data$BODYWEIGHT = my_data$Bodyweight
my_data$EXPOSURE <- my_data$Exposure

f1 <- ggplot(my_data, aes(x = BODYWEIGHT, y = EXPOSURE)) +
  geom_smooth(method = "lm")+
  geom_point() +
  theme_minimal(base_size = 18 ) +
  ggtitle("EXPOSURE \nVS BODYWEIGHT") +
  theme(panel.grid.minor=element_blank(),
        legend.position="none",
        axis.ticks = element_blank(),
        axis.text.y=element_blank(),
        axis.text.x=element_blank(),
        axis.title = element_text(face = "bold.italic",size = 18),
        plot.title = element_text(hjust = 0.5, face = "bold.italic",size = 18)
  )

ggsave(f1, file="GWLeg_f1.png", width = 80, height = 80, units = "mm", dpi = 300)

f2 <- ggplot(my_data, aes(x = Bodyweight, y = Exposure)) +
  geom_smooth(method = "lm")+
  geom_point() +
  theme_minimal(base_size = 16 ) +
  ggtitle("Exposure \nvs. Bodyweight")+
  theme(panel.grid.minor=element_blank(),
        legend.position="none",
        axis.ticks = element_blank(),
        axis.text.y=element_blank(),
        axis.text.x=element_blank(),
        plot.title = element_text(hjust = 0.5)
        )

ggsave(f2, file="GWLeg_f2.png", width = 80, height = 80, units = "mm", dpi = 300)

######################################################################################
## Simple bar chart
## Try not to set types at an angle to avoid clashing as this decreases legibility.
## First think of alternative solutions such as transposing the graph, abbreviations,
## or reducing the number of labels to what is essential.
########################################################################################

# make data
df <- data.frame(trt=c("Treatment 1", "Treatment 2", "Treatment 3"),
cause=c(4,6,10),
highlight = c(2,1,2))

g1 <- ggplot(df, aes(x=trt, y=cause))  +
  geom_bar(width=0.5,  stat = "identity") +
  theme(axis.title=element_blank()) +
  scale_y_continuous(breaks=c(0, 5, 10))

ggsave(g1, file="GWLeg_g1.png", width = 80, height = 80, units = "mm", dpi = 300)

g2 <- ggplot(df, aes(x=trt, y=cause))  +
  geom_bar(width=0.5,  stat = "identity") +
  theme(axis.title=element_blank()) +
  scale_y_continuous(breaks=c(0, 5, 10))  +
  theme(axis.text.x = element_text(angle = 45, hjust = 1, size = 12),
        axis.text.y=element_text(size=12))

ggsave(g2, file="GWLeg_g2.png", width = 80, height = 80, units = "mm", dpi = 300)

g3 <- ggplot(df, aes(x=trt, y=cause)) +
  geom_bar(width=0.5,  stat = "identity") +
  theme(axis.title=element_blank(),
        axis.text.x=element_text(size=12),
        axis.text.y=element_text(size=12)) +
  scale_y_continuous(breaks=c(0, 5, 10)) +
  coord_flip()

ggsave(g3, file="GWLeg_g3.png", width = 80, height = 80, units = "mm", dpi = 300)


calcTargetClusterQuals <- function( seuratObj, targetCellType = "M"){

# this snippet calculates the cluster quality of the target cluster, see Supplementary Methods
# the clusters are assigned cell by cell by isTargetCell.r
# written by Vsevolod J. Makeev 2017 - 2021

source("R/isTargetCell.r")

cellClusters 	<- sapply( levels( seuratObj@ident), function(x) WhichCells( seuratObj, ident = x))
clusterQuals	<- sapply( cellClusters, function(x) { nCells <- length(which( sapply( x, isTargetCell, seuratObj = seuratObj, targetCellType = targetCellType))); if(nCells ==0) 0 else ( 1 + nCells)/sqrt(1+ length(x))})

return( clusterQuals)
}


#' @title Rank abundance plot
#'
#' @description Generates a rank abundance curve (rank abundance vs cumulative read abundance), optionally with standard deviation from mean intervals.
#'
#' @param data (\emph{required}) Data list as loaded with \code{\link{amp_load}}.
#' @param group_by (\emph{required}) Group the samples by a variable in the metadata.
#' @param showSD Show standard deviation from mean or not. (\emph{default:} \code{TRUE})
#' @param log10_x Log10-transform the x-axis or not. Often most variation is observed among the most abundant OTU's, log10-transforming the x-axis will highlight this better. (\emph{default:} \code{TRUE})
#'
#' @return A ggplot2 object.
#' @import ggplot2
#'
#' @export
#'
#' @details Currently only OTU level is supported.
#'
#' @seealso
#' \code{\link{amp_load}}
#'
#' @examples
#' # Load example data
#' data("AalborgWWTPs")
#'
#' # Rank abundance plot
#' amp_rankabundance(AalborgWWTPs, group_by = "Plant", showSD = TRUE, log10_x = TRUE)
#' @author Kasper Skytte Andersen \email{ksa@@bio.aau.dk}
#' @author Mads Albertsen \email{MadsAlbertsen85@@gmail.com}
amp_rankabundance <- function(data,
                              group_by,
                              showSD = TRUE,
                              log10_x = TRUE) {
  ### Data must be in ampvis2 format
  #is_ampvis2(data)

  # melt
  d <- amp_export_long(
    normaliseTo100(data),
    metadata_vars = group_by,
    tax_levels = "OTU"
  )

  # group up and summarise
  d[, groupSum := sum(count), by = c("OTU", group_by)]
  setorderv(d, c(group_by, "groupSum"), order = -1)
  d[, prop := groupSum / sum(groupSum) * 100, by = group_by]
  d[, cumProp := cumsum(prop), by = group_by]
  d[, rank := as.integer(!duplicated(groupSum)), by = c("OTU", group_by)]
  d[, rank := cumsum(rank), by = group_by]
  d[, sd := sd(count, na.rm = TRUE), by = c("OTU", group_by)]
  d <- d[, .SD[.N], by = c("OTU", group_by)]

  # generate plot
  plot <- ggplot(
    d,
    aes_string(
      x = "rank",
      y = "cumProp",
      group = group_by,
      color = group_by
    )
  ) +
    geom_line(size = 1) +
    ylim(0, 100) +
    xlab("Rank abundance") +
    ylab("Cumulative read abundance (%)") +
    theme_classic() +
    {
      if (isTRUE(showSD)) {
        geom_ribbon(
          aes_string(
            ymin = "cumProp - sd",
            ymax = "cumProp + sd",
            fill = group_by
          ),
          alpha = 0.2,
          size = 0
        )
      }
    } +
    {
      if (isTRUE(log10_x)) {
        scale_x_log10()
      }
    }
  return(plot)
}


args<-commandArgs(TRUE)
dataset <- read.csv(args[1])
filename = gsub(".csv", "", args[1])
fileNameEt <- paste(filename, "_AVG.csv", sep="")
avgLat <- rowMeans(cbind(dataset$LAT0,dataset$LAT1 ,dataset$LAT2 ,dataset$LAT3 ,dataset$LAT4,dataset$LAT5,dataset$LAT6,dataset$LAT7,dataset$LAT8,dataset$LAT9))
avgA <- rowMeans(cbind(dataset$MEMA0,dataset$MEMA1 ,dataset$MEMA2 ,dataset$MEMA3 ,dataset$MEMA4,dataset$MEMA5,dataset$MEMA6,dataset$MEMA7,dataset$MEMA8,dataset$MEMA9))
avgB <- rowMeans(cbind(dataset$MEMB0,dataset$MEMB1 ,dataset$MEMB2 ,dataset$MEMB3 ,dataset$MEMB4,dataset$MEMB5,dataset$MEMB6,dataset$MEMB7,dataset$MEMB8,dataset$MEMB9))
write.table(cbind(dataset, avgLat, avgB, avgA),  append=TRUE, sep=";", dec=",", row.names = FALSE, file = fileNameEt )