################################################################################################################################################
#                                                Script to create vars for the diversity domain                                                #                                                                                #
# II) Local Diversity (Intersection of catchments)                                                                                #
# Vars: % of                                                                                #
# 1. multiples (independent, small multiples [<10], large multiples [>10]),                                                                    #
# 2. retail diversity (comparison + convenience)                                                                                #
# 3. services diversity (leisure + services)                                                                                #
# 4. total number of stores                                                                                #
# 5. most popular comparison, convenience and leisure chains                                                                                #
#                                                                                #
# Calculate total number of retail units per Area and TC and then divide each TC's by total in the area                                        #
# Highest prob per TC based on comp and conv to calc population stats                                                                          #
################################################################################################################################################

library(data.table)
library(sf)
library(stringr)

source("~/Dropbox/git/retail_typology/create_variables/attractive_list.r")

##### 1. Functions ############################################################################################################################

cluster_neighs <- function(lookup, cluster_id){
  if (! all(c("cluster_id.x", "cluster_id.y") %in% names(lookup))){
    stop("column names in lookup should be cluster_id.x and cluster_id.y")
  }
  # with the following every neighbouring retail centre is a competitor
  unique(c(cluster_id, lookup[cluster_id.x == cluster_id,]$cluster_id.y, lookup[cluster_id.y == cluster_id, ]$cluster_id.x))

  # with the following small retail centres are not competitors of large ones, but large ones are competitors
  # unique(c(cluster_id, lookup[cluster_id.x == cluster_id,]$cluster_id.y))
}

produce_pcts <- function(Dt, lookup, expr_numerator, expr_denominator, query){
  out <- data.table(id = unique(Dt$cluster_id), pct = 100)
  setkey(out, pct)
  for(i in as.integer(1:nrow(out))){
    cl <- out$id[i]
    clusters <- cluster_neighs(lookup, cl)
    if (length(clusters) > 1){
      set(out,
          i,
          "pct",
          100 * eval(parse(text = expr_numerator)) / eval(parse(text = expr_denominator))
      )
    }
  }
  out[is.na(pct), pct := 0]
  out
}

multiples_pct <- function(Dt, lookup, store_names){
  produce_pcts(Dt = Dt, lookup = lookup,
               expr_numerator = "Dt[cluster_id == cl, sum(store_name %in% query)]",
               expr_denominator = "Dt[cluster_id %in% clusters, sum(store_name %in% query)]",
               query = store_names)
}

diversity_pct <- function(Dt, lookup){
  produce_pcts(Dt = Dt, lookup = lookup,
               expr_numerator = "Dt[cluster_id == cl, length(unique(subcat))]",
               expr_denominator = "Dt[cluster_id %in% clusters, length(unique(subcat))]",
               query = NULL)

}

department_stores_pct <- function(Dt, lookup){
  produce_pcts(Dt = Dt, lookup = lookup,
               expr_numerator = "Dt[cluster_id == cl, sum(subcat == query)]",
               expr_denominator = "Dt[cluster_id %in% clusters, sum(subcat == query)]",
               query = "Department Stores")
}

attractive_pct <- function(Dt, lookup){
  produce_pcts(Dt = Dt,lookup = lookup,
               expr_numerator = "Dt[cluster_id == cl, length(na.omit(unique(attractive_retailers)))]",
               expr_denominator = "Dt[cluster_id %in% clusters, length(na.omit(unique(attractive_retailers)))]",
               query = NULL)
}

##### 2. Input data ###########################################################################################################################

lookup <- fread("~/Dropbox/liverpool/retail_typology/data/lookup_competitors.csv")
setnames(lookup, names(lookup), c("cluster_id.x", "cluster_id.y"))

all(unique(lookup$cluster_id.y) %in% unique(lookup$cluster_id.x)) # F
# The reason for the above result is that some big centres have only small neighbours, the latter are not competitors for the former

ru <- st_read("~/Dropbox/liverpool/catchments/catchments2/retail_units/retail_units_all_data_area_id_names_fin.shp", stringsAsFactors = F)
ru2 <- as.data.frame(ru)
setDT(ru2)
ru2 <- ru2[cluster_id %in% unique(c(lookup$cluster_id.x, lookup$cluster_id.y)),]
setkey(ru2, cluster_id)
ru2[, store_name2 := str_to_lower(str_trim(store_name))]

comp_conv <- ru2[classifica %in% c("Comparison", "Convenience") & ! category %in% c("Chemists, Toiletries & Health", "Discount & Surplus Stores") & ! store_name2 %in% c("halfords cycle republic", "sue ryder care"), ]
leis_serv <- ru2[classifica %in% c("Leisure", "Service") | store_name2 %in% c("halfords cycle republic", "sue ryder care"), ]

count_store_names <- table(comp_conv$store_name)

##### 3. Independent multiples (1 unique store name for comparison and convenience) ############################################################

independent_stores <- names(which(count_store_names == 1))
indie <- multiples_pct(Dt = comp_conv, lookup = lookup, store_names = independent_stores)
setnames(indie, 1:2, c("cluster_id", "indie_pct"))

##### 3. Small multiples ( > 1 & <= 10 stores for comparison and convenience) ##################################################################

small_multi_names <- names(which(count_store_names > 1 & count_store_names <= 10))
small_multi <- multiples_pct(Dt = comp_conv, lookup = lookup, store_names = small_multi_names)
setnames(small_multi, 1:2, c("cluster_id", "local_small_multi_pct"))

##### 4. Large multiples ( > 10 stores for comparison and convenience) #########################################################################

large_multi_names <- names(which(count_store_names > 10))
large_multi <- multiples_pct(Dt = comp_conv, lookup = lookup, store_names = large_multi_names)
setnames(large_multi, 1:2, c("cluster_id", "local_large_multi_pct"))

##### 5. Retail diversity (number of unique subcategory / total number of subcategory for comparison and convenience) ##########################

retail_diversity <- diversity_pct(Dt = comp_conv, lookup = lookup)
setnames(retail_diversity, 1:2, c("cluster_id", "local_retail_diversity_pct"))

##### 6. Services diversity (number of unique subcategory / total number of subcategory for leisure and services) ##############################

services_diversity <- diversity_pct(Dt = leis_serv, lookup = lookup)
setnames(services_diversity, 1:2, c("cluster_id", "local_services_diversity_pct"))

##### 7. Department stores (total number of stores) ############################################################################################

department_stores <- department_stores_pct(Dt = comp_conv, lookup = lookup)
setnames(department_stores, 1:2, c("cluster_id", "local_departm_stores_pct"))

##### 8. Attractive comparison (number of unique attractive stores / total number of unique attractive stores) #################################

comparison_stores_lookup <- as.data.frame(do.call(rbind, lapply(names(attractive_comparison_list),
                                                                function(store_name) cbind(store_name, attractive_comparison_list[[store_name]]))),
                                          stringsAsFactors = F)
names(comparison_stores_lookup) <- c("retailer_name", "retailer_store_names")
setDT(comparison_stores_lookup)

if ("attractive_retailers" %in% names(comp_conv)) comp_conv[, attractive_retailers := NULL]
all(comparison_stores_lookup$retailer_store_names %in% unique(comp_conv$store_name2)) # False, we removed chemists etc see above
comp_conv[comparison_stores_lookup, attractive_retailers := i.retailer_name, on = c(store_name2 = "retailer_store_names")]

attractive_comparison <- attractive_pct(Dt = comp_conv, lookup = lookup)
setnames(attractive_comparison, c("id", "pct"), c("cluster_id", "local_comparison_pct"))

##### 9. Attractive leisure (number of unique attractive stores / total number of unique attractive stores) ###################################

leisure_lookup_table <- as.data.frame(do.call(rbind, lapply(names(leisure_list),
                                                            function(store_name) cbind(store_name, leisure_list[[store_name]]))),
                                      stringsAsFactors = F)
names(leisure_lookup_table) <- c("retailer_name", "retailer_store_names")
setDT(leisure_lookup_table)

if ("attractive_retailers" %in% names(leis_serv)) leis_serv[, attractive_retailers := NULL]
all(leisure_lookup_table$retailer_store_names %in% unique(leis_serv$store_name2)) # True
leis_serv[leisure_lookup_table, attractive_retailers := i.retailer_name, on = c(store_name2 = "retailer_store_names")]
attractive_leisure <- attractive_pct(Dt = leis_serv, lookup = lookup)
setnames(attractive_leisure, c("id", "pct"), c("cluster_id", "local_leisure_pct"))

##### 10. Attractive consumer services (number of unique attractive stores / total number of unique attractive stores) ########################

consumer_lookup_table <- as.data.frame(do.call(rbind, lapply(names(consumer_list),
                                                             function(store_name) cbind(store_name, consumer_list[[store_name]]))),
                                       stringsAsFactors = F)
names(consumer_lookup_table) <- c("retailer_name", "retailer_store_names")
setDT(consumer_lookup_table)

if ("attractive_retailers" %in% names(leis_serv)) leis_serv[, attractive_retailers := NULL]
all(consumer_lookup_table$retailer_store_names %in% unique(leis_serv$store_name2)) # True
leis_serv[consumer_lookup_table, attractive_retailers := i.retailer_name, on = c(store_name2 = "retailer_store_names")]
attractive_consumer <- attractive_pct(Dt = leis_serv, lookup = lookup)
setnames(attractive_consumer, c("id", "pct"), c("cluster_id", "local_consumer_pct"))

##### 11. Attractive convenience (number of unique attractive stores / total number of unique attractive stores) ##############################

convenience_lookup_table <- as.data.frame(do.call(rbind, lapply(names(convenience_list),
                                                                function(store_name) cbind(store_name, convenience_list[[store_name]]))),
                                          stringsAsFactors = F)
names(convenience_lookup_table) <- c("retailer_name", "retailer_store_names")
setDT(convenience_lookup_table)

if ("attractive_retailers" %in% names(comp_conv)) comp_conv[, attractive_retailers := NULL]
all(convenience_lookup_table$retailer_store_names %in% unique(comp_conv$store_name2)) # F
# length_conv <- length(unique(convenience_lookup_table[retailer_store_names %in% unique(comp_conv$store_name2), ]$retailer_name))
comp_conv[convenience_lookup_table, attractive_retailers := i.retailer_name, on = c(store_name2 = "retailer_store_names")]
attractive_convenience <- attractive_pct(Dt = comp_conv, lookup = lookup)
setnames(attractive_convenience, c("id", "pct"), c("cluster_id", "local_convenience_pct"))

##### 11. Put everything together #############################################################################################################

out <- department_stores[attractive_comparison, on = "cluster_id"]
out <- attractive_consumer[out, on = "cluster_id"]
out <- attractive_convenience[out, on = "cluster_id"]
out <- attractive_leisure[out, on = "cluster_id"]
out <- indie[out, on = "cluster_id"]
out <- large_multi[out, on = "cluster_id"]
out <- small_multi[out, on = "cluster_id"]
out <- retail_diversity[out, on = "cluster_id"]
out <- services_diversity[out, on = "cluster_id"]
out[is.na(local_services_diversity_pct), c("local_services_diversity_pct", "local_leisure_pct", "local_consumer_pct") := list(0, 0, 0)]

fwrite(out, "~/Dropbox/liverpool/retail_typology/analysis/indicators/local_diversity.csv")


### ivmodel: Generates an instance of ivmodel
###          In this package, our IV model is
###          Y_i = beta_0 + D_i * beta_1 + X_i^T * gamma + epsilon_i
###          E(epsilon_i | Z_i, X_i) = 0
### INPUT: Y, outcome (n * 1 vector)
###        D, exposure (n * 1 vector)
###        Z, instruments (n * L matrix)
###        X, baseline and exogenous covariates (n * p matrix)
###        intercept, should we include the intercept term?
###        beta0: null value for beta
###        alpha: 1 - alpha confidence interval
###        k: values for the k-class estimator
###        heteroSE: heteroskedastic SE?
###        clusterSE: clustered SE?
###        clusterID, if clusterSE is TRUE, then one must provide a vector of
###                   length that's identical to the sample size.
###                   For example, if n = 6 and clusterID = c(1,1,1,2,2,2),
###                   there would be two clusters where the first cluster
###                   is formed by the first three observations and the
###                   second cluster is formed by the last three observations
###                   clusterID can be numeric, character, or factor.
###        deltarange: for sensitivity analysis.
### OUTPUT: ivmodel object which contains a clean-up version of Y,D,Z,X (if available)
ivmodel <- function(Y,D,Z,X,intercept=TRUE,
                    beta0=0,alpha=0.05,k=c(0,1),
                    manyweakSE = FALSE, heteroSE = FALSE, clusterID = NULL,
                    deltarange = NULL, na.action = na.omit) {

  # Error checking: check to see if necessary inputs are there!
  if(missing(Y)) stop("Y is missing!")
  if(missing(D)) stop("D is missing!")
  if(missing(Z)) stop("Z is missing!")

  # Error checking: check Y and D
  if( (!is.vector(Y) && !is.matrix(Y) && !is.data.frame(Y)) || (is.matrix(Y) && ncol(Y) != 1) || (is.data.frame(Y) && ncol(Y) != 1) || (!is.numeric(Y))) stop("Y is not a numeric vector.")
  if( (!is.vector(D) && !is.matrix(D) && !is.data.frame(Y)) || (is.matrix(D) && ncol(D) != 1) || (is.data.frame(D) && ncol(D) != 1) || (!is.numeric(D))) stop("D is not a numeric vector.")
  Y = as.numeric(Y); D = as.numeric(D)
  if(length(Y) != length(D)) stop("Dimension of Y and D are not the same!")

  # Error checking: check Z and convert "strings" into factors
  Z = data.frame(Z); stringIndex = sapply(Z,is.character); Z[stringIndex] = lapply(Z[stringIndex],as.factor)
  if(nrow(Z) != length(Y)) stop("Row dimension of Z and Y are not equal!")
  colnames(Z) = paste("Z",colnames(Z),sep="")

  # Add intercept as X
  if(intercept && !missing(X)) X = data.frame(X,1)
  if(intercept && missing(X)) X = data.frame(rep(1,length(Y)))

  # Error checking: check X and convert "strings" into factors
  if(!missing(X)) {
    X = data.frame(X); stringIndex = sapply(X,is.character); X[stringIndex] = lapply(X[stringIndex],as.factor)
	if(nrow(X) != length(Y)) stop("Row dimension of X and Y are not equal!")
	colnames(X) = paste("X",colnames(X),sep="")
  }

  # Coalesce all data into one data.frame
  if(!missing(X)) {
    allDataOrig = cbind(Y,D,Z,X)
  } else {
    allDataOrig = cbind(Y,D,Z)
  }

  # NA handling
  if(identical(na.action, na.fail) | identical(na.action, na.omit) | identical(na.action, na.pass)){
    allDataOrig = na.action(allDataOrig)
    naindex = rep(TRUE, nrow(allDataOrig))
	naindex[apply(is.na(allDataOrig), 1, any)] = NA
  }else if(identical(na.action, na.exclude)){
    naindex = rep(TRUE, nrow(allDataOrig))
	naindex[apply(is.na(allDataOrig), 1, any)] = NA
	allDataOrig = na.action(allDataOrig)
  }else{
    stop("Wrong input of NA handling!")
  }

  # Fit adjustment model
  ff = terms(Y ~ D + . -1,data=allDataOrig)
  mf = model.frame(ff,allDataOrig)

  # Declare Y and D
  Y = as.matrix(mf$Y); colnames(Y) = "Y"
  D = as.matrix(mf$D); colnames(D) = "D"

  # Extract Z and X
  allData = sparse.model.matrix(ff,allDataOrig); attr(allData,"assign") = NULL; attr(allData,"contrasts") = NULL
  Zindex = grep(paste("^",colnames(Z),sep="",collapse="|"),colnames(allData))
  Z = allData[,Zindex,drop=FALSE]; colnames(Z) = sub("^Z","",colnames(Z))
  if(!missing(X)) {
    Xindex = grep(paste("^",colnames(X),sep="",collapse="|"),colnames(allData)); X = allData[,Xindex,drop=FALSE]; colnames(X) = sub("^X","",colnames(X))
  }
  # Check to see if there's enough data points after removing missing values
  if(nrow(Y) <= 1) stop("Too much missing data!")

  n = length(Y)
  if(!missing(X)){
    ### clean X and project Y, D, Z
    qrX<-qr(X)
    p = qrrank(qrX)
    if(p==0)
      stop("vector in X are all 0")
    #if(p<ncol(X))
      #X<-qr.Q(qrX)[, 1:p]%*%qrRM(qrX)[1:p, 1:p]
    Yadj = as.matrix(qr.resid(qrX,Y)); Dadj = as.matrix(qr.resid(qrX,D)); Zadj = as.matrix(qr.resid(qrX,Z))
    ### clean Zadj
    ZadjQR = qr(Zadj)
    L = qrrank(ZadjQR)
    if(L==0)
      stop("No useful instrumental variables")
    if(L==1) {
      Zadj = qr.Q(ZadjQR)[, 1:L] * as.numeric(qrRM(ZadjQR)[1:L,1:L])
    }
    if(L<ncol(Z) && L> 1){
      Zadj<-qr.Q(ZadjQR)[, 1:L]%*%qrRM(ZadjQR)[1:L, 1:L]  ### shall we update the Z by doing qr(X, Z)?
      #qrXZ<-qr(cbind(X, Z))
      #Z<-(qr.Q(qrXZ)[, 1:(p+L)]%*%qrRM(qrXZ)[1:(p+L), 1:(p+L)])[,(p+1):(p+L)]
    }
    ivmodelObject = list(call = match.call(),n=n,L=L,p=p,Y=Y,D=D,Z=Z,X=X,Yadj=Yadj,Dadj=Dadj,Zadj=Zadj, ZadjQR = ZadjQR)

  }else{
    p = 0
    Yadj = Y; Dadj = D; Zadj = as.matrix(Z)
    ### only need to clean Z
    ZadjQR = qr(Zadj)
    L = qrrank(ZadjQR)
    if(L==0)
      stop("No useful instrumental variables")
    if(L == 1) {
      Z <- Zadj <-qr.Q(ZadjQR)[, 1:L] * as.numeric(qrRM(ZadjQR)[1:L, 1:L])
    }
    if(L<ncol(Z) && L > 1)
      Z<-Zadj<-qr.Q(ZadjQR)[, 1:L]%*%qrRM(ZadjQR)[1:L, 1:L]

    ivmodelObject = list(call = match.call(),n=n,L=L,p=p,Y=Y,D=D,Z=Z,X=NA,Yadj=Yadj,Dadj=Dadj,Zadj=Zadj, ZadjQR = ZadjQR)
  }

  class(ivmodelObject) = "ivmodel"

  ivmodelObject$naindex = naindex
  ivmodelObject$alpha = alpha
  ivmodelObject$beta0 = beta0
  ivmodelObject$deltarange = deltarange

  ivmodelObject$AR = AR.test(ivmodelObject,beta0=beta0,alpha=alpha)
  ivmodelObject$ARsens = ARsens.test(ivmodelObject,beta0=beta0,alpha=alpha,deltarange=deltarange)
  ivmodelObject$kClass = KClass(ivmodelObject,beta0=beta0,alpha=alpha,k=k,heteroSE=heteroSE,clusterID=clusterID) ## Don't use many weak IV asymptotics for OLS and TSLS
  ivmodelObject$LIML = LIML(ivmodelObject,beta0=beta0,alpha=alpha,manyweakSE=manyweakSE,heteroSE=heteroSE,clusterID=clusterID)
  ivmodelObject$Fuller = Fuller(ivmodelObject,beta0=beta0,alpha=alpha,manyweakSE=manyweakSE,heteroSE=heteroSE,clusterID=clusterID)
  ivmodelObject$CLR = CLR(ivmodelObject,beta0=beta0,alpha=alpha)

  return(ivmodelObject)
}


source("sample/R/heatmap_f.r") ##reading tiny R script
cols <- colorRampPalette(c("white","darkblue")) ##setting colors from white to darkblue

df <- read.delim ("sample/chip2/chip2_around_anno_mm10_halfwid5000winsize500step100_all.txt") ##reading output file of ga_reads_summit_all
set.seed(127); df.r <- df[sample(1:nrow(df), 2500),] ##randomly picking up 2500 genes
ot <- read.delim ("sample/order_table.txt", header=F) ##order table for sorting...

df.r.sort <- df.r[ot[,1],] ##sorting

df.r.sort.norm <- return_mat_norm_all(df.r.sort, 0.99) ##normalization considering all peaks, where top 99% and more was set to 1
png("sample/chip2/chip2_around_anno_mm10_halfwid5000winsize500step100_all.png",height=1000)
image(seq(from=-5000, to=5000, by = 100),1:nrow(df.r.sort.norm),as.matrix(t(df.r.sort.norm)), col= cols(100), main="Read density of chip2 around TSS", xlab="Distance from TSS (bp)", ylab="Genes", xlim=c(-5000,5900), bty="n") ; abline(v=0)
rect(5200, seq(from=10, to=1000, by=10), 5700, seq(from=20, to=1010,by=10),col=cols(100),border="transparent")
text(x=5800, y=10, "0")
text(x=5800, y=1000, "1")
dev.off()


#aggregate SSP data

library(openxlsx)
library(stringr)
require(utils)
library(data.table)
library(reshape2)
library(plyr)

Population = read.xlsx("../data/SSP_v9_clean.xlsx", sheet = "Population", startRow = 1, colNames = TRUE, skipEmptyRows = TRUE, rowNames = FALSE)

GDP = read.xlsx("../data/SSP_v9_clean.xlsx", sheet = "GDP PPP", startRow = 1, colNames = TRUE, skipEmptyRows = TRUE, rowNames = FALSE)

PPP2MER = read.xlsx("../data/SSP_v9_clean.xlsx", sheet = "PPP2MER", startRow = 1, colNames = TRUE, skipEmptyRows = TRUE, rowNames = FALSE)[1:2]

#choose SSP
Population <- subset(Population, SCENARIO=="SSP2_v9_130325")
GDP <- subset(GDP, SCENARIO=="SSP2_v9_130325")

###SSP is GDP not CONSUMPTION!! ==> take 20% savings rate!!
GDP[, 9:26]  <- GDP[, 9:26]*0.8

#create SSP_pop
SSP_pop <- as.data.frame(t(Population[, 9:26]))
SSP_pop <- SSP_pop[rep(1:nrow(SSP_pop),each=5),]
SSP_pop[90:285, ] <- SSP_pop[90, ]
write.table(SSP_pop, file = "../output/SSP_pop.csv", row.names=FALSE, col.names=FALSE, sep=",")

#create SSP_cpc
#compute per capita GDP (here: original SSP that is PPP)
SSP_cpc <- 1000*as.data.frame(t(GDP[, 9:26]))/as.data.frame(t(Population[, 9:26]))
SSP_cpc <- SSP_cpc[rep(1:nrow(SSP_cpc),each=5),]
SSP_cpc[90:285, ] <- SSP_cpc[90, ]
write.table(SSP_cpc, file = "../output/SSP_cpc.csv", row.names=FALSE, col.names=FALSE, sep=",")

############# ALTERNATIVE: CPC for SSPs based on MER
GDP_MER <- merge(GDP, PPP2MER, by="REGION")
GDP_MER[, 9:26] <- GDP_MER[, 9:26]*GDP_MER$PPP2MER
SSP_cpc_MER <- 1000*as.data.frame(t(GDP_MER[, 9:26]))/as.data.frame(t(Population[, 9:26]))
SSP_cpc_MER <- SSP_cpc_MER[rep(1:nrow(SSP_cpc_MER),each=5),]
SSP_cpc_MER[90:285, ] <- SSP_cpc_MER[90, ]
write.table(SSP_cpc_MER, file = "../output/SSP_cpc_MER.csv", row.names=FALSE, col.names=FALSE, sep=",")

#SSP_sigmasquared just set all zero!
SSP_sigmasquared <- SSP_cpc*0
write.table(SSP_sigmasquared, file = "../output/SSP_sigmasquared.csv", row.names=FALSE, col.names=FALSE, sep=",")

#now aggregate across model regions
GDP_long <- melt(GDP[, 3:26], value.name="GDP", id.var=c("REGION", "FUND_region", "RICE_region"), variable.name="year")
Population_long <- melt(Population[, 3:26], value.name="Population", id.var=c("REGION", "FUND_region", "RICE_region"), variable.name="year")
#Full_Data <- merge(GDP_long, Population_long, by=c("year", "REGION", "FUND_Region", "RICE_region"))
Full_Data <- GDP_long
Full_Data$Population <- Population_long$Population
Full_Data$CPC = 1000*Full_Data$GDP/Full_Data$Population
#add MER values
Full_Data <- merge(Full_Data, PPP2MER, by="REGION")
Full_Data$GDPMER = Full_Data$GDP * Full_Data$PPP2MER
Full_Data$CPCMER = 1000*Full_Data$GDPMER/Full_Data$Population

#create fund_sigmasquared.csv => MER
fund_sigmasquared <- ddply(Full_Data, .(year, FUND_region), summarise, s2=weighted.mean(log(CPCMER)^2, Population, na.rm = TRUE)-weighted.mean(log(CPCMER), Population, na.rm = TRUE)^2)
fund_sigmasquared <- dcast(fund_sigmasquared, FUND_region ~ year, value.var="s2")
write.table(fund_sigmasquared[,4:22], file = "../output/fund_sigmasquared_2010_2100.csv", row.names=FALSE, col.names=FALSE, sep=",")

#create rice_sigmasquared.csv => PPP
rice_sigmasquared <- ddply(Full_Data, .(year, RICE_region), summarise, s2=weighted.mean(log(CPC)^2, Population, na.rm = TRUE)-weighted.mean(log(CPC), Population, na.rm = TRUE)^2)
rice_sigmasquared <- dcast(rice_sigmasquared, RICE_region ~ year, value.var="s2")
write.table(rice_sigmasquared[,4:22], file = "../output/rice_sigmasquared_2010_2100.csv", row.names=FALSE, col.names=FALSE, sep=",")

#now full 300 year yearly data
rice_sigmasquared <- as.data.frame(t(rice_sigmasquared[,5:22]))
rice_sigmasquared <- rice_sigmasquared[rep(1:nrow(rice_sigmasquared),each=5),]
rice_sigmasquared[90:285, ] <- rice_sigmasquared[90, ]
write.table(rice_sigmasquared, file = "../output/RICE_sigmasquared.csv", row.names=FALSE, col.names=FALSE, sep=",")
fund_sigmasquared <- as.data.frame(t(fund_sigmasquared[,5:22]))
fund_sigmasquared <- fund_sigmasquared[rep(1:nrow(fund_sigmasquared),each=5),]
fund_sigmasquared[90:285, ] <- fund_sigmasquared[90, ]
write.table(fund_sigmasquared, file = "../output/FUND_sigmasquared.csv", row.names=FALSE, col.names=FALSE, sep=",")


## This is a very trivial demo  of
## the RUnit test case execution system:
## ---------------------------------

## functions to be tested (usually defined in a different
## file from where the test cases are located):

## centigrade to Fahrenheit
c2f <- function(c) return(9/5 * c + 32)

## Fahrenheit to centigrade
f2c <- function(f) return(5/9 * f - 32)  ## ups, a bug (brackets missing)

## test functions:
## ---------------------

.setUp <- function() {  ## called before each test case, see also .tearDown()
  print(".setUp")
}

test.c2f <- function() {
  checkEquals(c2f(0), 32)
  checkEquals(c2f(10), 50)
  ## check that an error is created for a bogus argument
  checkException(c2f("xx"))
}

test.f2c <- function() {
  checkEquals(f2c(32), 0)
  checkEquals(f2c(50), 10)
  ## check that an error is created for a bogus argument
  checkException(f2c("xx"))
}

test.errordemo <- function() {
  stop("this is just to show what an error looks like as opposed to a failure")
}

## How to run the tests (do not uncomment in this file,
## but execute the commands at the R prompt):
## All you have to do is to adapt the directory locations.
## ------------------------------------------------

## define the test suite:
#testsuite.cf <- defineTestSuite("cfConversion", dirs="directoryOfThisFile")

## run test suite:
#testResult <- runTestSuite(testsuite.cf)

## print text protocol to console:
#printTextProtocol(testResult)

## print HTML version to a file:
#printHTMLProtocol(testResult, fileName="someFileName.html")

## In this case we also have a shortcut
#runTestFile("directoryOfThisFile/runitcfConversion.r")


# PREREQS
# pacman -S gcc-fortran extras/libgit2

# Set up: install  RStan
install.packages("rstan", repos = "https://cloud.r-project.org/", dependencies = TRUE)

# install rethinking

install.packages("remotes")
remotes::install_github("stan-dev/cmdstanr")

install.packages(c("coda","mvtnorm","devtools","dagitty"))
library(devtools)
devtools::install_github("rmcelreath/rethinking")


#!/usr/bin/env Rscript
options(stringAsfactors = FALSE, useFancyQuotes = FALSE)

# Taking the command line arguments
args <- commandArgs(trailingOnly = TRUE)

if(length(args)==0)stop("No file has been specified! Please select a file for performing groupFWHM!\n")
require(xcms)
require(CAMERA)
previousEnv<-NA
output<-NA
sigma<-8
perfwhm<-0.6
intval<-"maxo"
for(arg in args)
{
  argCase<-strsplit(x = arg,split = "=")[[1]][1]
  value<-strsplit(x = arg,split = "=")[[1]][2]
  if(argCase=="input")
  {
    previousEnv=as.character(value)
  }
  if(argCase=="sigma")
  {
    sigma=as.numeric(value)
  }
  if(argCase=="perfwhm")
  {
    perfwhm=as.numeric(value)
  }
  if(argCase=="intval")
  {
    intval=as.character(value)
  }
  if(argCase=="output")
  {
    output=as.character(value)
  }

}
if(is.na(previousEnv) | is.na(output)) stop("Both input and output need to be specified!\n")

load(file = previousEnv)

toBeGroupedFWHM<-get(varNameForNextStep)

xcmsSetGroupedFWHM<-groupFWHM(toBeGroupedFWHM,sigma = sigma,perfwhm = perfwhm,intval = intval)

preprocessingSteps<-c(preprocessingSteps,"GroupedFWHM")

varNameForNextStep<-as.character("xcmsSetGroupedFWHM")

save(list = c("xcmsSetGroupedFWHM","preprocessingSteps","varNameForNextStep"),file = output)


MGRAST_suggest_test <<- function (data_file, groups_file, data_type=c("raw", "normalized"), paired = FALSE, file_out="suggest_stat_test.out")
  {

    ### SUB TO WRITE OUTPUT
    write_out = function (sig_test, data_type, paired, num_samples, num_groups, file_out){
      #print("got here")
      write(paste("suggested test is =", sig_test,    sep = "\t"), file = file_out)
      write(paste("data-type         =", data_type,   sep = "\t"), file = file_out, append = TRUE)
      write(paste("paired            =", paired,      sep = "\t"), file = file_out, append = TRUE)
      write(paste("num-samples       =", num_samples, sep = "\t"), file = file_out, append = TRUE)
      write(paste("num-groups        =", num_groups,  sep = "\t"), file = file_out, append = TRUE)
    }

    my_data = data.matrix(read.table(data_file, row.names=1, header=TRUE, sep="\t", comment.char="", quote=""))
    my_groups = data.matrix(scan(file = groups_file, what = "character", sep = "\t", quiet=TRUE))
    num_groups = nlevels(as.factor(my_groups))
    num_samples = dim(my_data)[2]

    sig_test = NA

    ### CHECK DATA FOR MINIMUM STATISTICAL REQUIREMENTS
    if(num_groups==1|num_samples<=2|num_samples!=dim(my_data)[1]){
      write("Minimum analysis requirements not met - no test could be selected:\n", file = file_out)
      write(paste("data_type   =", data_type, sep = "\t"  ), file = file_out, append = TRUE)
      write(paste("paired      =", paired, sep = "\t"     ), file = file_out, append = TRUE)
      write(paste("num_samples =", num_samples, sep = "\t"), file = file_out, append = TRUE)
      write(paste("num_groups  =", num_groups, sep = "\t" ), file = file_out, append = TRUE)
      write(("\nSingle sample analyses are not supported.
The minimum analysis requirements are:
     (1) at least two groups of samples(metagenomes)
     (2) at least one group with two or more samples."
             ),                               file = "suggest_stat_test.out", append = TRUE)
    }

     ### CHOOSE MOST APPROPRIATE TEST
    if (data_type=="normalized"){
      if(num_groups==2){
        if(paired==TRUE){
          sig_test = "t-test-paired" # t_test
          write_out(sig_test, data_type, paired, num_samples, num_groups, file_out)
        }else{
          sig_test = "t-test-un-paired" # t_test
          write_out(sig_test, data_type, paired, num_samples, num_groups, file_out)
        }
      }else if (num_groups>2){
        if(paired==TRUE){
          sig_test = "repeat-measures-ANOVA_(not-yet-supported)" # ANOVA
          write_out(sig_test, data_type, paired, num_samples, num_groups, file_out)
        }else{
          sig_test = "ANOVA-one-way" # ANOVA
          write_out(sig_test, data_type, paired, num_samples, num_groups, file_out)
        }
      }
    }else if (data_type=="raw"){
      if (num_groups==2){
        if(paired==TRUE){
          sig_test = "Wilcoxon-paired" # wilcoxon
          write_out(sig_test, data_type, paired, num_samples, num_groups, file_out)
        }else{
          sig_test = "Mann-Whitney_un-paired_Wilcoxon" # wilcoxon
          write_out(sig_test, data_type, paired, num_samples, num_groups, file_out)
        }
      }else if (num_groups>2){
        if(paired==TRUE){
          sig_test = "Friedman-test_(not-yet-supported)" # kruskal_wallis
          write_out(sig_test, data_type, paired, num_samples, num_groups, file_out)
        }else{
          sig_test = "Kruskal-Wallis" # kruskal_wallis
          write_out(sig_test, data_type, paired, num_samples, num_groups, file_out)
        }
      }
    }else{
      sig_test = "NONE___try_again"
      write_out(data_type, num_samples, num_groups, sig_test, file_out)
    # stop("No test could be selected")
    }
  }


rm(list = ls())

# A fake tree
tree <- c("i", "a", "i", "f", "f", "b", "f", "c", "h", "i", "i", "g", "g", "d", "g", "e") #, "j", "i")
# tree <- c(tree, "i", "c")
lvls <- match(tree, letters)
tree <- matrix(lvls, ncol=2, byrow = TRUE)
set.seed(1)
plot(igraph::graph_from_edgelist(tree), layout = igraph::layout_as_tree)
tree <- matrix(lvls, ncol=2, byrow = TRUE)

list_offpring <- function(x, Data) {
  sapply(Data$I, function(y) x[which(x[,1] == y), 2])
}

list_parent <- function(x, Data) {
  sapply(Data$I, function(y) x[which(x[,2] == y), 1L])
}

# Peeling algorithm
prune <- function(i, Data, f) {

  if (Data$idx[i] != 0)
    return(NULL)

  # Peeling the offspring
  for (j in Data$Off[[i]])
    prune(j, Data, f)

  if (Data$idx[i] != 0)
    return(NULL)

  # Increasing counters
  Data$next_i(i)

  # Calling the user function
  f(i, Data)

  # Fetching the parent
  for (p in Data$Par[[i]])
    prune(p, Data, f)

  return(Data)
}

# Some random function to count the number of steps
# Function to recode the tree
recode_tree <- function(i, D) {

  # Initializing the tree
  if (!length(D$new_tree)) {
    D$new_tree <- NULL
    D$Nnode    <- which(sapply(D$Off, length) > 0)
  }

  if (length(D$Off[[i]]))
    D$new_tree <- rbind(
      D$new_tree,
      cbind(D$count, D$idx[D$Off[[i]]])
    )

}

# Step 1, listing offspring and parent
# n <- 500
# tree <- ape::rtree(n)$edge

#' Creates a peeling object
#' @param tree An integer matrix with two columns. The edgelist
#' @return An environemt to be passed to `prune`:
#' - `off` Current idnumber
newprune <- function(tree) {

  n <- max(tree)

  # Creating variables
  Data       <- new.env()
  Data$count <- 0L
  Data$I     <- 1L:n
  Data$idx  <- integer(n)

  lockBinding("count", Data)
  lockBinding("I", Data)
  lockBinding("idx", Data)

  # This function increases the counter and sets the id in the corresponding
  # slot. This is for internal use only
  Data$next_i <- function(i) {
    unlockBinding("count", Data)
    unlockBinding("idx", Data)

    Data$count   <- Data$count + 1L
    Data$idx[i] <- Data$count

    lockBinding("count", Data)
    lockBinding("idx", Data)
  }
  lockBinding("next_i", Data)

  # Listing offpring and parent
  Data$Off   <- list_offpring(tree, Data)
  Data$Par   <- list_parent(tree, Data)

  lockBinding("Off", Data)
  lockBinding("Par", Data)

  Data

}

ans <- microbenchmark::microbenchmark(
  prune(1, newprune(tree), recode_tree),
  unit = "ms", times = 1000)

ans <- newprune(tree)
prune(8, ans, recode_tree)

oldpar <- par(no.readonly = TRUE)
par(mfrow=c(1, 2))
set.seed(1);plot(igraph::graph_from_edgelist(tree), layout = igraph::layout_as_tree)
set.seed(1);plot(igraph::graph_from_edgelist(ans$new_tree), layout = igraph::layout_as_tree)
par(oldpar)


words <- readLines("words.txt")
Length <- nchar(words)
hist_dat <- table(Length)
write.table(hist_dat, "histogram.tsv",
						sep = "\t", row.names = FALSE, quote = FALSE)


model_preciprec <- function (Sdry_t1 = 0.0,
         Sdry = 0.0,
         Swet = 0.0,
         Swet_t1 = 0.0,
         Sdepth_t1 = 0.0,
         Sdepth = 0.0,
         Mrf = 0.0,
         precip = 0.0,
         Snowaccu = 0.0,
         rho = 100.0){
    #'- Name: Preciprec -Version: 1.0, -Time step: 1
    #'- Description:
    #'            * Title: Precipitation ReCalculation
    #'            * Author: STICS
    #'            * Reference: doi:http://dx.doi.org/10.1016/j.agrformet.2014.05.002
    #'            * Institution: INRA
    #'            * Abstract: recalculation of precipitation
    #'- inputs:
    #'            * name: Sdry_t1
    #'                          ** description : water in solid state in the snow cover in previous day
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'            * name: Sdry
    #'                          ** description : water in solid state in the snow cover
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'            * name: Swet
    #'                          ** description : water in liquid state in the snow cover
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'            * name: Swet_t1
    #'                          ** description : water in liquid state in the snow cover in previous day
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 100.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'            * name: Sdepth_t1
    #'                          ** description : snow cover depth Calculation in previous day
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : m
    #'                          ** uri :
    #'            * name: Sdepth
    #'                          ** description : snow cover depth Calculation
    #'                          ** inputtype : variable
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : m
    #'                          ** uri :
    #'            * name: Mrf
    #'                          ** description : liquid water in the snow cover in the process of refreezing
    #'                          ** inputtype : variable
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : mmW/d
    #'                          ** uri :
    #'            * name: precip
    #'                          ** description : current precipitation
    #'                          ** inputtype : variable
    #'                          ** variablecategory : auxiliary
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min : 0.0
    #'                          ** max : 5000.0
    #'                          ** unit : mmW
    #'                          ** uri :
    #'            * name: Snowaccu
    #'                          ** description : snowfall accumulation
    #'                          ** inputtype : variable
    #'                          ** variablecategory : rate
    #'                          ** datatype : DOUBLE
    #'                          ** default : 0.0
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : mmW/d
    #'                          ** uri :
    #'            * name: rho
    #'                          ** description : The density of the new snow fixed by the user
    #'                          ** inputtype : parameter
    #'                          ** parametercategory : constant
    #'                          ** datatype : DOUBLE
    #'                          ** default : 100
    #'                          ** min :
    #'                          ** max :
    #'                          ** unit : kg/m**3
    #'                          ** uri :
    #'- outputs:
    #'            * name: preciprec
    #'                          ** description : recalculated precipitation
    #'                          ** variablecategory : state
    #'                          ** datatype : DOUBLE
    #'                          ** min : 0.0
    #'                          ** max : 500.0
    #'                          ** unit : mmW
    #'                          ** uri :
    preciprec <- precip
    if (Sdry + Swet < Sdry_t1 + Swet_t1)
    {
        preciprec <- preciprec + ((Sdepth_t1 - Sdepth) * rho) - Mrf
    }
    preciprec <- preciprec - Snowaccu
    return (list('preciprec' = preciprec))
}


#####################################################################################################
#################### Aim: download and prepare Lx and lx from life-tables
#####################################################################################################
rm(list=ls())
dev.off()

library(eurostat)
library(sjmisc)
library(tidyr)
library(dplyr)

data.dir <- "C:\\Users\\Magdalena\\demography\\happyindex\\data\\EUROSTAT"
setwd(data.dir)

ltdat <- get_eurostat("demo_mlifetable", time_format = "num")

###the same country numbers as in SILC
csymb <- c("AT", "BE", "BG", "CH", "CY", "CZ", "DK", "EE","EL","ES","FI", "FR", "HR", "HU", "IE", "IT", "LT", "LU", "LV", "NL", "NO", "PL","PT",
            "RO", "RS", "SE", "SI", "SK","UK")
cno <- 1:29
ltdat$cno <- 0

for (i in 1:length(cno)){
  ltdat$cno[ltdat$geo==csymb[i]] <- cno[i]
}

Lx <- ltdat %>%
  dplyr::filter(indic_de == "PYLIVED", time==2018, geo %in% csymb, sex!="T")%>%
  mutate(age=replace(age,age=="Y_GE85", "Y85")) %>%
  mutate(age2=as.numeric(substr(age,2,3))) %>%
  mutate(agegr=0)%>%
  mutate(sex=replace(sex,sex=="F","W")) %>%  #the same order of sex as in SILC
  dplyr::filter(age2>=15) %>%
  select(geo,cno,sex,age2,agegr,values)

#replace age groups as in prevalence
ages <- c(15,30,40,seq(50,80,5))

for (i in 1:length(ages)){
  Lx$agegr[Lx$age2>=ages[i]] <- ages[i]
}

l15 <- ltdat %>%
  dplyr::filter(indic_de == "SURVIVORS", time==2018, geo %in% csymb, age=="Y15",sex!="T") %>%
  mutate(sex=replace(sex,sex=="F","W")) %>%  #the same order of sex as in SILC
  select(geo,cno,sex,values)

write.table(Lx, "Lx.csv", sep=",")
write.table(l15, "l15.csv", sep=",")


library(ggplot2)
library(ggvis)
library(dplyr)
library(rgdal)
library(mosaic)
library(maptools)
library(ggmap)
library(mapproj)
library(munsell)

source(file = 'lib/uvozi.zemljevid.r', encoding = 'UTF-8')
source('lib/libraries.r', encoding = 'UTF-8')
source('uvoz/uvoz_s.r', encoding = 'UTF-8')

#Brezposelnost v Sloveniji na splošno
osnovni_graf <- ggplot(slovenija, aes(x=leto, y=brezposelnost))+
  ggtitle('Brezposelnost glede na celotno Slovenijo v 1000')+
  geom_bar(stat = 'identity', position = 'dodge')

#Graf stopnje brezposelnosti skozi leta glede na staistične
vec_graf <- ggplot(data = graf_regije, mapping = aes(x=regija, y=stopnja_brezposelnosti, fill=factor(leto))) +
  labs(fill='leto') +
  ggtitle('Brezposelnost na 1000 prebivalcev po regijah') +
  geom_bar(stat = 'identity', position = 'dodge') +
  labs(x = 'Regija', y = 'Stopnja brezposelnosti') +
  theme(axis.text.x = element_text(angle = 90, size = 8))

#Zemljevid brezposelnosti po statističnih regijah glede na 1000 ljudi
  #za leto 2010

Slovenija <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/SVN_adm_shp.zip",
                             "SVN_adm1") %>% fortify()
colnames(Slovenija)[12]<-'regija'
Slovenija$regija <- gsub('GoriÅ¡ka', 'Goriška', Slovenija$regija)
Slovenija$regija <- gsub('KoroÅ¡ka', 'Koroška', Slovenija$regija)
Slovenija$regija <- gsub('Notranjsko-kraÅ¡ka', 'Primorsko-notranjska', Slovenija$regija)
Slovenija$regija <- gsub('Obalno-kraÅ¡ka', 'Obalno-kraška', Slovenija$regija)
Slovenija$regija <- gsub('Spodnjeposavska', 'Posavska', Slovenija$regija)

zemljevid.brezposelnost.2010 <- ggplot() +
  geom_polygon(data = right_join(brezposelnost.2010,Slovenija, by = c('regija')),
               aes(x = long, y = lat, group = group, fill = stopnja_brezposelnosti))+
  xlab("") + ylab("") + ggtitle('Brezposelnost v letu 2010') +
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank()) +
  scale_fill_gradient(low = '#DEA1D6', high='#D002B4', limits=c(3,12))

  #za leto 2018

zemljevid.brezposelnost.2018 <- ggplot() +
  geom_polygon(data = right_join(brezposelnost.2018,Slovenija, by = c('regija')),
               aes(x = long, y = lat, group = group, fill = stopnja_brezposelnosti))+
  xlab("") + ylab("") + ggtitle('Brezposelnost v letu 2018') +
  theme(axis.title=element_blank(), axis.text=element_blank(), axis.ticks=element_blank(), panel.background = element_blank()) +
  scale_fill_gradient(low = '#DEA1D6', high='#D002B4',limits=c(3,12))

#Grafki brezposelnosti v Sloveniji glede na stopnjo dosežene izobrazbe

graf_izobrazba <- ggplot(data = izobrazba, mapping = aes(x=leto, y=brezposelnost)) +
  ggtitle('Brezposelnost glede na stopnjo dosežene izobrazbe') +
  geom_point() +
  #facet_grid( Drzava~.) +
  facet_wrap(izobrazbe~., ncol=3) +
  theme(axis.text.x = element_text(angle = 90, size = 6))


# Assigning names to the list for each of the objects

# Vector with numerics from 1 up to 10
my_vector <- 1:10

# Matrix with numerics from 1 up to 9
my_matrix <- matrix(1:9, ncol = 3)

# First 10 elements of the built-in data frame mtcars
my_df <- mtcars[1:10,]

# Adapt list() call to give the components names
my_list <- list(vec = my_vector, mat = my_matrix, df = my_df)

# Print out my_list
my_list


'

In the file "second_stage_estimation.r", we compute IV estimates for log GDP
per capita with expropriation risk as the first stage dependent variable.

We also compute confidence intervals for a usual Wald statistic and confidence
intervals for the Anderson-Rubin (1949) statistic.

The file requires to be called with a model specification as the argument,
a corresponding json-file must exist in PATH_IN_MODEL_SPECS. That file
needs to define a dictionary with keys:

    * INSTD - the dependent variable (in the first stage)
    * INSTS - the instrument
    * KEEP_CONDITION - any sampling restrictions
    * DUMMIES - additional dummy variables to be used as controls

The r-file loops over various specifications with geographic controls /
restrictions as defined in PATH_IN_MODEL_SPECS/geography.json. Finally,
it stores a dataframe with estimation results.

'

rm(list=ls())
options(digits=3)

source("project_paths.r")
source(paste(PATH_IN_MODEL_CODE, "functions.r", sep="/"))

# Load required libraries.
library(foreign)
library(zoo)
library(car)
library(rjson)
library(sandwich)
library(lmtest)
library(AER)
library(ivpack)

# Load model and geographic specification.
model_name <- commandArgs(trailingOnly = TRUE)
model_json <- paste(model_name, "json", sep=".")
model <- fromJSON(file=paste(PATH_IN_MODEL_SPECS, model_json, sep="/"))
geography <- fromJSON(file=paste(PATH_IN_MODEL_SPECS, "geography.json", sep="/"))

# Initilize output dataframe for results.
results = data.frame(matrix(nrow = 5, ncol = 7))
row.names(results) <- c(
    "Expropriation risk $(\\alpha)$ ",
    "Wald 95\\% conf.",
    "region ",
    "AR \\textquotedblleft 95\\%\\textquotedblright conf.",
    "region"
)

# Loop over geographical specifications.
for (i in 1:7) {

    # Load data.
    data <- read.table(
        file = paste(PATH_OUT_DATA, "ajrcomment_all.txt", sep="/"),
        header = TRUE
    )

    # Implement model-specific restrictions.
    if (model$KEEP_CONDITION != "") {
        data <- subset(data, eval(parse(text = model$KEEP_CONDITION)))
    }

    # Implement geographical constraints.
    GEO_COND <- paste("GEO_KEEP_CONDITION_", i, sep="")
    if (geography[[GEO_COND]] != "") {
        data <- subset(data, eval(parse(text = geography[[GEO_COND]])))
    }
    GEO_CONTROLS <- paste("GEO_CONTROLS_", i, sep="")

    # Set up variables for regression.
    y <- model$DEPVAR
    x <- model$INSTD
    instr <- model$INSTS
    dummies <- model$DUMMIES
    geo_controls <- geography[[GEO_CONTROLS]]

    # Set up regression formula.
    reg_formula <- as.formula(
      paste(y, " ~ ", x, dummies, geo_controls, " | ", instr, dummies, geo_controls, sep="")
    )
    reg <- ivreg(formula = reg_formula, data = data, x = TRUE)

    # Write regression results for iteration 'i' to output dataframe.
    if (is.na(anderson.rubin.ci(reg, conflevel=.95)[2])) {
        results[i] = c(
            round(reg$coef[[2]], 2),
            wald.ci(reg, 0.05, data[ ,instr]),
            "",
            paste("$", anderson.rubin.ci(reg, conflevel=.95)[1], "$", sep=""),
            ""
        )

    } else {
        results[i] = c(
            round(reg$coef[[2]], 2),
            wald.ci(reg, 0.05, data[ ,instr]),
            "",
            anderson.rubin.ci(reg, conflevel=.95)[1],
            anderson.rubin.ci(reg, conflevel=.95)[2]
        )
    }
}

# Save data to disk.
write.table(
    results,
    file = paste(
        PATH_OUT_ANALYSIS,
        paste("second_stage_estimation_", model_name, ".txt", sep=""),
        sep = "/"
    ),
    col.names = TRUE
)


myargs <- commandArgs(trailingOnly = TRUE)

if( !require(chron) ) {
  install.packages("chron", repos="http://cran.us.r-project.org")
}

source("Thornthwaite_Mather_cell_class.R")

rpd <- function( val1, val2 ) {
  meanval <- mean(val1, val2)
  if ( is.na( meanval ) ) {

    retval <- 0.0

  } else {

    retval <- ( abs(val1) - abs(val2) ) / meanval * 100.

  }
}

TOLERANCE <- 0.01

swb_exe <- myargs[1]

swb_ctl <- "recharge_single_cell.ctl"

my_control_file <- c(
  "GRID 1 1 2165054. 255067. 161.1",
  "GRID_LENGTH_UNITS FEET",
  "GROWING_SEASON 133 268 T",
  "SUPPRESS_SCREEN_OUTPUT",
  "OUTPUT_FUTURE_PATH ",
  "OUTPUT_PATH ",
  "INITIAL_ABSTRACTION_METHOD HAWKINS",
  "PRECIPITATION SINGLE_STATION",
  "TEMPERATURE SINGLE_STATION",
  "FLOW_DIRECTION CONSTANT 1",
  "SOIL_GROUP CONSTANT 1",
  "LAND_USE CONSTANT 1",
  "LAND_USE_LOOKUP_TABLE LU_LOOKUP_single_cell.txt",
  "WATER_CAPACITY CONSTANT 3.0",
  "INITIAL_SOIL_MOISTURE CONSTANT 100",
  "INITIAL_SNOW_COVER CONSTANT 0",
  "RUNOFF C-N DOWNHILL",
  "DUMP_VARIABLES 1 1",
  "ET T-M 43",
  "SM T-M EQUATIONS",
  "SOLVE Coshocton_climate_1999.txt test_ future_ T T",
  "EOJ")

writeLines(text=my_control_file,
           con=swb_ctl)

# first run SWB

if (.Platform$OS.type == "windows") {

  retval <- shell(cmd=paste(swb_exe,swb_ctl, " > swb_command_line_echo.txt", sep=" "),
                intern=TRUE,
                ignore.stdout=FALSE)

} else {

  retval <- system(command=paste(swb_exe,swb_ctl, " > swb_command_line_echo.txt", sep=" "),
                  intern=TRUE,
                  ignore.stdout=FALSE)
}

climate_1999 <- read.table("Coshocton_climate_1999.txt", header=FALSE, skip=1)
colnames(climate_1999) <- c("Month","Day","Year","TMean","Precip","RHMean","TMax","TMin","WindVel","RHMin","PctSun")
climate_1999$Date <- as.Date(paste(climate_1999$Year,climate_1999$Month,climate_1999$Day,sep="-"))

# now run the equivalent procedures in R
mean_monthly_temps <- monthly_temps(climate_1999)

mean_monthly_temps_C <- FtoC(mean_monthly_temps)

i <- TM_i(mean_monthly_temps_C)
I <- TM_I(i)
a <- TM_a(I)

df <- climate_1999

mycel <- cellclass(RootingDepth=2,
                   AWC=3,
                   latitude=43.,
                   grow_start=133,
                   grow_stop=268)

mycel$initialize(sm_init=6,
                 snowcover_init=0,
                 max_int_growing=0.05,
                 max_int_nongrowing=0.)

mycel$init_tm(df)

mycel$opendaily("simple_TM_calculation.csv")

for (n in 1:nrow(df)) {

  mycel$updateprecip(grossprecip=df$Precip[n],
                     tmax=df$TMax[n],
                     tmin=df$TMin[n])

  mycel$processprecip(n)

  mycel$processet(df$Month[n], df$Day[n], df$Year[n] )

  mycel$massbalance()

  mycel$dumpdaily(df$Date[n])

}

v_in <- read.csv("SWB_daily_MEAN_values.csv", header=TRUE, as.is=TRUE, skip=2)
v_base <- read.csv(mycel$filename, header=TRUE, as.is=TRUE)

v_in$Date<-as.Date(v_in$Date,format="%m/%d/%Y")
v_in$Year <- format(v_in$Date, format="%Y")

v_base$Date<-as.Date(v_base$Date,format="%m/%d/%Y")
v_base$Year <- format(v_base$Date, format="%Y")

# ensure vector lengths are the same, assuming the date ranges are comparable
v_base <- v_base[v_base$Date %in% v_in$Date, ]

colnames(v_base)[colnames(v_base) == "REFERENCE_ET"] <- "POT_ET"
colnames(v_in)[colnames(v_in) == "REFERENCE_ET"] <- "POT_ET"

lTEST <- TRUE

for (i in sort(unique(v_in$Year))) {

  vb <- subset(v_in,v_in$Year==i)  # swb results
  vbb <- subset(v_base,v_base$Year==i)  # R script results

  if (nrow(vbb) < nrow(vb)) next

  for (j in 2:(ncol(vb)-1)) {

    y<-vb[ ,j ]  # swb results

    if ( any(colnames(vbb)==colnames(vb)[j] ) ) {
      x<-as.vector( unlist( vbb[which(colnames(vbb)==colnames(vb)[j] ) ]  ) )

      diffvals <- abs(y) - abs(x)

      cat(paste(colnames(vb)[j]),":", signif(max(diffvals), digits=3), "\n", sep="")

      if (any(diffvals > TOLERANCE ) ) {

        indices <- which(diffvals > TOLERANCE)
        for (index in indices) {
          cat(colnames(vb)[j],":", format(vb[index,"Date"], "%m-%d-%Y"),
             " swb: ",y[index], " R calc: ",x[index],"  rpd: ",rpd(y[index],x[index]),"\n")
        }

        lTEST <- FALSE
      }

    }

  }

}

if( lTEST == TRUE ) {
  cat("PASS")
} else {
  cat("FAIL")
}


library(ggplot2)

my.tableName = readline(prompt="Enter table name: ")
print(paste("You chose to import", my.tableName))

#create data frame with the given data
df = read.table(my.tableName, sep = ";",header = TRUE)

#ignore dots and replace commas with dots. treat this as numeric
df$Ποσό <- as.numeric(gsub(",", ".", gsub("\\.", "", df$Ποσό)))

#get subset of Amount where prefix is X and replace with the negative value
df$Ποσό[df$Πρόσημο.ποσού == "Χ"] <- -df$Ποσό[df$Πρόσημο.ποσού == "Χ"]

df[order(as.Date(df$Ημ.νία,format = "%d/%m/%y")),]
View(df)

attach(df)
plot(df$Ημ.νία,cumsum(df$Ποσό),type = "o", col="blue")
sapply(df,mode)


# This script loads the results and reproudce fig 5 of the paper

rm(list=ls())
dir()
Npred = 10
p_fold = "./plots/"
dir.create(p_fold,showWarnings = F)

# change here if you want only one
sexes = c("MALE", "FEMALE")
trace_plots = T

pl_list = list()
for (wh in sexes){
	#wh = "FEMALE"

	fPIC =F
	source("./nimble_model_integral.r")
	source("./post_proc_util.r")

	load(sprintf("./mcmc_res%s.RData",wh))
	#pred_c = pred

	#pred = get_rec_pred(10,pars,hyp)
	Y = pars$data
	hyp = list(N_countries = dim(Y)[1],
		   Time = dim(Y)[3],
		   n = 111, x = seq(0,110)+0.5)

	# Evaluate difference
	pars = add_w(pars)
	(cc = dimnames(pars$data)[[1]])

	pred = get_pred_ppd(Npred,pars,hyp)
	cc = dimnames(Y)[[1]]
	years = dimnames(Y)[[3]]

	require(ggplot2)
	require(latex2exp)
	require(plyr)

	parsw = add_w(pars)
	predw = add_w(pred)

	#+++++++++++++++++++++
	# Focus now on moments
	#+++++++++++++++++++++
	parsw = add_skew_moments(parsw)
	predw = add_skew_moments(predw)

	df_pl = get_df_summ(parsw,predw, countries = cc, func = "median",  w = T,log=F,moments = T )
	df_qq = get_df_ic_h(parsw,predw, countries = cc, level = .8, w = T, log = F, upper = F, moments = T)
	df_QQ = get_df_ic_h(parsw,predw, countries = cc, level = .8, w = T, log = F, moments = T)
	{
		df_comb = reshape2::melt(df_pl,id.var = c("x"))
		df_comb_QQ = reshape2::melt(df_QQ,id.var = c("x"))
		df_comb_QQ$q = "Q"
		df_comb_qq = reshape2::melt(df_qq,id.var = c("x"))
		df_comb_qq$q = "q"

		from_strings = c("w0", "w1",    "w2", "mu" ,  "sigma" , "sn_mean", "sn_sd", "alpha")
		to_strings = c(TeX("$\\pi_{0t}$"), TeX("$\\pi_{1t}$"), TeX("$\\pi_{2t}$"),
			       TeX("$\\mu_{t}$"), TeX("$\\sigma_{t}$"),
			       TeX("$\\tilde{\\mu}^{SN}_{t}$"),
			       TeX("$\\tilde{\\sigma}^{SN}_{t}$"),
			       TeX("$\\alpha_{t}$"))

		df_comb$variable = mapvalues(df_comb$variable,
					     from = from_strings,
					     to = to_strings)
		df_comb$L1 = mapvalues(df_comb$L1, from = c("DEUTW", "FRATNP", "GBRTENW"), to = c("DEU", "FRA", "GBR"))

		df_comb_qq$variable = mapvalues(df_comb_qq$variable,
						from = from_strings,
						to = to_strings)
		df_comb_qq$L1 = mapvalues(df_comb_qq$L1,from = c("DEUTW", "FRATNP", "GBRTENW"), to = c("DEU", "FRA", "GBR"))

		df_comb_QQ$variable = mapvalues(df_comb_QQ$variable,
						from = from_strings,
						to = to_strings)
		df_comb_QQ$L1 = mapvalues(df_comb_QQ$L1, from = c("DEUTW", "FRATNP", "GBRTENW"), to = c("DEU", "FRA", "GBR"))

		require(dplyr)
		data_test = df_comb %>%
			group_by(variable) %>% summarise(m = min(value), M = max(value))

		tmp = years
		(years = c(years[-length(years)], seq(as.numeric(years[length(years)]), len = dim(pred$xi)[3]+1, by =  diff(as.numeric(years))[1])))
		df_comb$x = as.numeric(years[df_comb$x])
		df_comb_QQ$x = as.numeric(years[df_comb_QQ$x])
		df_comb_qq$x = as.numeric(years[df_comb_qq$x])

		df_comb$sex = wh
		df_comb_QQ$sex = wh
		df_comb_qq$sex = wh

		smooth_p = F # if you want to smooth results
		{
			plw =
				ggplot(df_comb) +
				facet_wrap(~sex+variable,scales="free_y",nrow=2,labeller = label_parsed) +
				geom_vline(xintercept = as.numeric(years[hyp$Time]),lty = 3)+

				{if(smooth_p) list(
						   geom_smooth(data=df_comb_QQ,  aes(x,y=value,group=L1, color = L1),lty=3,show.legend=F,se=F) ,
						   geom_smooth(data=df_comb_qq,  aes(x,y=value,group=L1, color = L1),lty=3,show.legend=F,se=F),
						   geom_smooth(aes(x,y=value,group=L1,color=L1),se = F)
				)
						} +
						{if(!smooth_p) list(
								    geom_line(data=df_comb_QQ,  aes(x,y=value,group=L1, color = L1),lty=3,show.legend=F) ,
								    geom_line(data=df_comb_qq,  aes(x,y=value,group=L1, color = L1),lty=3,show.legend=F),
								    geom_line(aes(x,y=value,group=L1,color=L1))
						)
				} +
					#scale_color_manual(values=cbbPalette)+
					theme_bw(base_size = 16) +
					xlab("") + ylab("")+
					scale_x_continuous(breaks = seq(as.numeric(years)[1], as.numeric(tail(years,1)), by = 5)) +
					#scale_x_continuous(breaks = as.numeric(years)[round(seq(1,length(years),by = 5))] ) +
					theme(axis.text.x = element_text(angle = 90,vjust = 1),
					      strip.text.x = element_text(size=16),
					      legend.position = ifelse(wh == "MALE", "none", "bottom"),
					      legend.text = element_text(size=12),
					      legend.box = "horizontal",
					      legend.background = element_rect(fill="lightgray", size=0.5, linetype="solid"),
					      legend.title = element_blank(),
					      legend.key = element_rect(colour = 'black')) +
guides(col = guide_legend(nrow = 2))
		}
	}
	pl_list = c(pl_list, list(plw))
}

library(gtable)
library(ggplot2)

combo_plot = rbind(ggplotGrob(pl_list[[1]] + theme(strip.text.x = element_text(size=16) ) ),
		   ggplotGrob(pl_list[[2]] + theme(strip.text.x = element_text(size=16) )))

plot(combo_plot)

ggsave(combo_plot, file = "forecast_comb.png", width = 20, height = 17)


.setUp <- function() {}
.tearDown <- function() {}

test.number <- function()
{
	json <- "0"
	x <- fromJSON( json )
	checkIdentical( x, 0 )

	json <- "-0"
	x <- fromJSON( json )
	checkIdentical( x, 0 )

	json <- "15.05"
	x <- fromJSON( json )
	checkIdentical( x, 15.05 )

	json <- "-10.3"
	x <- fromJSON( json )
	checkIdentical( x, -10.3 )

	json <- "-0.3"
	x <- fromJSON( json )
	checkIdentical( x, -0.3 )

	json <- "0.3e3"
	x <- fromJSON( json )
	checkIdentical( x, 300 )

	json <- "0.2e+4"
	x <- fromJSON( json )
	checkIdentical( x, 2000 )

	json <- "0.1e-4"
	x <- fromJSON( json )
	checkIdentical( x, 0.00001 )

	# TODO check for invalid entries like 0.1e-4.5?
	failing_json <- c( ".3", "-.3", "0.1e" )
	for( bad_json in failing_json ) {
		x <- try( fromJSON( bad_json ), silent = TRUE )
		checkTrue( any( class( x ) == "try-error" ) )
	}
}


##CTE534_Índices=group
##Imagen=raster
##NIR=number 4
##SWIR2=number 10
##NBRI=output raster
##showplots

NBRI <- raster::overlay(Imagen[[NIR]],
                        Imagen[[SWIR2]],
                        fun=function(x,y){(x-y)/(x+y)})
plot(NBRI)


options("scipen"=100, "digits"=4)

yng <- df_describers[, c("full.name.of.describer", "min", "max_corrected", "spp_N")]
yng$mid <- as.integer((yng$max_corrected - yng$min) / 2) + yng$min

# spp_N includes valid species and synonyms

summary(yng$mid)
breaks <- c(seq(1750, 2020, 50), 2020)
yng$age_bin <- cut(yng$min, breaks=breaks, include.lowest=TRUE, right=FALSE)
labels <- c(paste0(breaks[1:5], "-", breaks[2:6]-1), paste0("After ", breaks[6]))
yng$age_bin <- factor(
    yng$age_bin, levels=levels(yng$age_bin), labels=labels
)

yng[is.na(age_bin),]$mid

summary(yng$spp_N)
breaks <- c(seq(1,10, 2), seq(11, 100, 20), seq(101, 700, 200), 6200)
yng$spp_bin <- cut(yng$spp_N, breaks=breaks, include.lowest=TRUE, right = FALSE)

labels <- unlist(lapply(levels(yng$spp_bin), function(x) {
    first <- gsub("\\[", "", strsplit(as.character(x), ",")[[1]][1])
    second <- as.integer(gsub("\\)", "", strsplit(as.character(x), ",")[[1]][2]))-1
    ifelse(is.na(second),
        paste0(">", first),
        paste0(first, "-", second)
    )
}))

yng$spp_bin <- factor(
    yng$spp_bin, levels=levels(yng$spp_bin), labels=labels
)

unique(yng$age_bin)
unique(yng$spp_bin)

yng <- yng[order(spp_bin, age_bin)]

summary <- yng[, {
    total = .N
    .SD[,.(frac = .N/total), by=age_bin]
}, by=spp_bin]

p <- ggplot(summary, aes(x = spp_bin, y = frac*100, fill = age_bin)) +
  geom_bar(stat="identity", width = 0.7, color="black", size=.2) +
  labs(x = "Number of species", y = "Percentage of PTEs (%)\n", fill = "First\npublication date") +
  theme_minimal(base_size = 11) +
  scale_y_continuous(breaks=ybreaks20) +
  scale_x_discrete() +
  theme(
      panel.grid.major.x = element_blank(),
      axis.text = element_text(size=10, angle=90, hjust=1, vjust=0)
    ) +
  scale_fill_brewer(palette="Greys")

ggsave(
    paste0(dir_plot, 'fig-7a.png'), p, units="cm",
    width=17, height=8, dpi=300
)

summary <- yng[, {
    total = .N
    .SD[,.(frac = .N/total), by=spp_bin]
}, by=age_bin]

library(RColorBrewer)
getPalette <- colorRampPalette(brewer.pal(9, "Greys"))

p <- ggplot(summary, aes(x = age_bin, y = frac*100, fill = spp_bin)) +
  geom_bar(stat="identity", width = 0.7, color="black", size=.2) +
  labs(x = "\nFirst publication date", y = "Percentage of PTEs (%)\n", fill = "Number of species") +
  theme_minimal(base_size = 11) +
  scale_y_continuous(breaks=ybreaks10) +
  scale_x_discrete() +
  theme(
      panel.grid.major.x = element_blank(),
      axis.text.x = element_text(size=10)
    ) +
  scale_fill_manual(values=getPalette(length(levels(yng$spp_bin))))

ggsave(
    paste0(dir_plot, 'fig-7b.png'), p, units="cm",
    width=17, height=12, dpi=300
)

summary[age_bin=="After 2000"]


args <- commandArgs(trailingOnly = TRUE)
if (length(args) != 3) {
    cat("Usage: plot_pca.R <input_prefix> <name_table> <output_file>\n",
        file=stderr())
    quit(status=1)
}

library(ggplot2)
library(ggrepel)

expanded.range <- function(values, expand.by=0.2)
{
    r <- range(values)
    p <- abs(r[2] - r[1]) * expand.by

    return(r + c(-0.5, 0.5) * p)
}

calc.lims <- function(x, y)
{
    x <- expanded.range(x)
    y <- expanded.range(y)
    xlen <- x[2] - x[1]
    ylen <- y[2] - y[1]

    if (xlen < ylen) {
        x <- x + c(-0.5, 0.5) * (ylen - xlen)
    }

    return(x)
}

plot.pca <- function(input_prefix, names.table=NULL)
{
    d <- read.table(paste(input_prefix, "evec", sep="."), as.is=TRUE)
    v <- read.table(paste(input_prefix, "eval", sep="."), as.is=TRUE)

    pc1 <- round(v$V1[1] / sum(v$V1), 3)
    pc2 <- round(v$V1[2] / sum(v$V1), 3)

    d$V1 <- sapply(strsplit(d$V1, ":", fixed=TRUE), function(x) x[1])
    d <- d[, 1:3]
    colnames(d) <- c("Name", "X", "Y")

    colors <- read.table(names.table, comment.char="", header=TRUE)
    final <- merge(d, colors)

    pp <- ggplot(final)
    pp <- pp + geom_text_repel(aes(x=X, y=Y, label=Name))

    pp <- pp + geom_point(aes(x=X, y=Y), color=final$Color, size=3)

    pp <- pp + xlab(sprintf("PC1: %.1f%%", pc1 * 100))
    pp <- pp + ylab(sprintf("PC2: %.1f%%", pc2 * 100))

    pp <- pp + theme_minimal()
    pp <- pp + xlim(calc.lims(final$X, final$Y))
    pp <- pp + ylim(calc.lims(final$Y, final$X))

    # Force 1:1 aspect ratio for the PCA plot; this must be done in
    # order to prevent misrepresenting distances on different axes.
    pp <- pp + coord_fixed()

    return(pp)
}

input_prefix <- args[1]
names_table <- args[2]
output_prefix <- args[3]

pdf(file=paste(output_prefix, ".pdf", sep=""))
plot.pca(input_prefix, names_table)
dev.off()

# bitmap is preferred, since it works in a headless environment
bitmap(paste(output_prefix, ".png", sep=""), height=6, width=6, res=96, taa=4, gaa=4)
plot.pca(input_prefix, names_table)
dev.off()


13500,23,46986,0,1,90,1,0,2000,3,1165
Age = c(23)
KM = c(46986)
FuelType1 = c(0)
FuelType2 = c(1)
HP = c(90)
MetColor = c(1)
Automatic = c(0)
CC = c(2000)
Doors = c(3)
Weight = c(1165)
query = data.frame(Age,KM,FuelType1,FuelType2,HP,MetColor,Automatic,CC,Doors,Weight)
predict(fit, query)

20950,25,31461,0,0,192,0,0,1800,3,1185
Age = c(25)
KM = c(31461)
FuelType1 = c(0)
FuelType2 = c(0)
HP = c(192)
MetColor = c(0)
Automatic = c(0)
CC = c(1800)
Doors = c(3)
Weight = c(1185)
query = data.frame(Age,KM,FuelType1,FuelType2,HP,MetColor,Automatic,CC,Doors,Weight)
predict(fit, query)


      s<-"A B C
      1 2 1
      2 22 3
      0 0 -1
      2 12 2
      0 0 -1
      20 2 5
      1 3 1
      0 2 2"
      d<-read.delim(textConnection(s),sep=" ",header=T)

      require(dplyr)

      mutate(d,rn=row_number()) %>% filter(C==-1)

      bind_rows(slice(d, 1:2) %>% mutate(grp=1),slice(d,4) %>%mutate(grp=2), slice(d,6:n()) %>% mutate(grp=3))

# Solution

      d %>% mutate(grp = cumsum(C == -1) + 1) %>% filter(C != -1)


## Plot figure 3

# For each sampling method - random or targeted
# For each fire regime (e1, e2, e3, e4)
# For NFR, MFIall, MFI10% MFI25%
# For sample size 10,25,50,100,250,500,census,real

# function to make a mini data frame of our chosen variables
library(ggplot2)

make_plot_frame=function(this_data,x,names){
  this_of=subset(this_data,select=x)
  this_of=unlist(this_of)
  this_names=factor(rep(names,each=100),levels=names)
  this_of=data.frame(value=this_of,var=this_names)
  this_of
}

## Random Figure

data_l1=read.csv("e1_l1/sim_list_stats1.csv")
data_l2=read.csv("e1_l2/sim_list_stats1.csv")
data_l3=read.csv("e1_l3/sim_list_stats1.csv")
data_l4=read.csv("e1_l4/sim_list_stats1.csv")

# Window 1 - MFI = all

col_seq=rep(c("blue","red","darkgreen","orange"),4)
vars=c("MFI_25_T","MFI_50_T","MFI_100_T","MFI_250_T")
names=c("25","50","100","250")
this_frame1=make_plot_frame(data_l1,vars,names)
this_frame1$MFI=1

this_frame2=make_plot_frame(data_l2,vars,names)
this_frame2$MFI=5

this_frame3=make_plot_frame(data_l3,vars,names)
this_frame3$MFI=10

this_frame4=make_plot_frame(data_l4,vars,names)
this_frame4$MFI=20

this_frame_a=rbind(this_frame1,this_frame2,this_frame3,this_frame4)
this_frame_a$Filter="MFI (All)"

vars=c("MFI_25_T_2o","MFI_50_T_2o","MFI_100_T_2o","MFI_250_T_2o")
names=c("25","50","100","250")
this_frame1=make_plot_frame(data_l1,vars,names)
this_frame1$MFI=1

this_frame2=make_plot_frame(data_l2,vars,names)
this_frame2$MFI=5

this_frame3=make_plot_frame(data_l3,vars,names)
this_frame3$MFI=10

this_frame4=make_plot_frame(data_l4,vars,names)
this_frame4$MFI=20

this_frame_b=rbind(this_frame1,this_frame2,this_frame3,this_frame4)
this_frame_b$Filter="MFI (>2)"

vars=c("MFI_25_T_10","MFI_50_T_10","MFI_100_T_10","MFI_250_T_10")
names=c("25","50","100","250")
this_frame1=make_plot_frame(data_l1,vars,names)
this_frame1$MFI=1

this_frame2=make_plot_frame(data_l2,vars,names)
this_frame2$MFI=5

this_frame3=make_plot_frame(data_l3,vars,names)
this_frame3$MFI=10

this_frame4=make_plot_frame(data_l4,vars,names)
this_frame4$MFI=20

this_frame_c=rbind(this_frame1,this_frame2,this_frame3,this_frame4)
this_frame_c$Filter="MFI (10%)"

vars=c("MFI_25_T_25","MFI_50_T_25","MFI_100_T_25","MFI_250_T_25")
names=c("25","50","100","250")
this_frame1=make_plot_frame(data_l1,vars,names)
this_frame1$MFI=1

this_frame2=make_plot_frame(data_l2,vars,names)
this_frame2$MFI=5

this_frame3=make_plot_frame(data_l3,vars,names)
this_frame3$MFI=10

this_frame4=make_plot_frame(data_l4,vars,names)
this_frame4$MFI=20

this_frame_d=rbind(this_frame1,this_frame2,this_frame3,this_frame4)
this_frame_d$Filter="MFI (25%)"

this_frame=rbind(this_frame_a,this_frame_b,this_frame_c,this_frame_d)

this_frame$Filter=factor(this_frame$Filter,levels=c("MFI (All)","MFI (>2)","MFI (10%)","MFI (25%)"))

#aa=boxplot(value~MFI + var,data=this_frame,ylab=expression(MFI[all]),col=col_seq,border=col_seq,outline=FALSE)
pdf("Fig3.pdf",width=8,height=8)
p <- ggplot(this_frame, aes(factor(MFI), value))
p= p + geom_boxplot(aes(fill = factor(MFI),var),outlier.shape = NA) + facet_wrap( ~ Filter)+ coord_cartesian(ylim = c(0,75)) + scale_fill_manual(values = c("blue","red","darkgreen","orange"))
p=p+ theme_bw() + theme(panel.grid.major = element_line(colour = "white"),panel.grid.minor = element_line(colour = "white"))
p+labs(x = "Sample Size",y="Mean Fire Interval",fill="Actual MFI")
dev.off()


#' @title Calculate Area Under the ROC Curve from Leave-One-Out Cross-Validation
#'
#' @description
#' This function calculates the AUC for each selected subset of features from DMBC cross-validation results, and output the set of features which provide the greatest AUC.
#' @param CV The output object from loocv()
#' @export
#' @return A data frame of 6 columns, comparison group1 label, comparison group2 label, number of features included in the model, AUC, AUC * prior probability, and selected features.
#' @examples
#' data(training)
#'
#' #### using 10-fold cross-validation ###
#' Cal_AUC(tfcv(training))
#'
#' #### using leave-one-out cross-validation ###
#' Cal_AUC(loocv(training))

Cal_AUC <- function(CV=cv){
  HighestRank_allRow <- min(sapply(CV,function(x) max(as.numeric(x$feature_rank)+1)))
#  HighestRank_allRow <- max(sapply(CV,function(x) max(as.numeric(x$feature_rank))))
  auc_res <- list()
  for (NumberOfFeature in 1:HighestRank_allRow) {
    tryCatch({
      tmp <- lapply(CV,function(x) data.frame(x[x$feature_rank == NumberOfFeature,]))
      RankData = Reduce(function(...) merge(...,all=T),tmp)
     # AUC_Area= auc(roc(as.numeric(as.vector(RankData$Poster_Type1)), as.factor(RankData$Type1Label)))
      #AUC_Prior_Area= auc(roc(as.numeric(as.vector(RankData$Poster_Prio_Type1)), as.factor(RankData$Type1Label)))
      AUC_Area= auc(roc(as.numeric(as.vector(RankData$Type1_Posterior_Prb)), as.factor(RankData$Type1Label)))
      fnum <- sort(table(unlist(strsplit(as.character(RankData$SelectedFeatures),";"))),decreasing = T)
      features <- names(fnum[1:NumberOfFeature])
     # auc_res[[NumberOfFeature]] <- data.frame(RankData[1,1:2], NumberOfFeature, AUC_Area, AUC_Prior_Area,Features=paste(features,collapse = ";"))
      auc_res[[NumberOfFeature]] <- data.frame(RankData[1,1:2], NumberOfFeature, AUC_Area,Features=paste(features,collapse = ";"))

    }, error=function(e){cat("ERROR :",conditionMessage(e), "\n")})
  }
  return(Reduce(function(...) merge(...,all=T),auc_res))
}


#!/usr/bin/env Rscript
options(error=recover)

#this script prints out PDF pcoa plots and distance matrices, given an OTU table, phylogenetic tree, and metadata

source("UniFrac.r")
library(ape)
library(phangorn)
library(vegan)

otu.tab <- read.table("data/td_OTU_tag_mapped_lineage.txt", header=T, sep="\t", row.names=1, comment.char="", check.names=FALSE)

#remove taxonomy column to make otu count matrix numeric
taxonomy <- otu.tab$taxonomy
otu.tab <- otu.tab[-length(colnames(otu.tab))]
otu.tab <- t(as.matrix(otu.tab))

#sort taxa from most to least abundant
taxaOrder <- rev(order(apply(otu.tab,2,sum)))
taxonomy <- taxonomy[taxaOrder]
otu.tab <- otu.tab[,taxaOrder]

# read and root tree (rooted tree is required)
tree <- read.tree("data/fasttree_all_seed_OTUs.tre")
tree <- midpoint(tree)

# read metadata
MyMeta<- read.table("data/metadata.txt", header=T, sep="\t", row.names=1, comment.char="", check.names=FALSE)

# filter OTU table and metadata so that only samples which appear in both are retained
otu_indicies <- match(rownames(MyMeta),rownames(otu.tab))
otu_indicies <- otu_indicies[!is.na(otu_indicies)]
otu.tab <- otu.tab[otu_indicies,]
MyMetaOrdered <- MyMeta[match(rownames(otu.tab),rownames(MyMeta)),]

#rarefy data for unweighted unifrac
otu.tab.rarefy <- rrarefy(otu.tab, min(apply(otu.tab,1,sum)))

#calculate distance matrix
unweighted <- getDistanceMatrix(otu.tab.rarefy,tree,method="unweighted",verbose=TRUE)
weighted <- getDistanceMatrix(otu.tab,tree,method="weighted",verbose=TRUE)
information <- getDistanceMatrix(otu.tab,tree,method="information",verbose=TRUE)
ratio_no_log <- getDistanceMatrix(otu.tab,tree,method="ratio_no_log",verbose=TRUE)

#output distance matrices
write.table(unweighted,file="output/unweighted_distance_matrix.txt",sep="\t",quote=FALSE)
write.table(weighted,file="output/weighted_distance_matrix.txt",sep="\t",quote=FALSE)
write.table(information,file="output/information_distance_matrix.txt",sep="\t",quote=FALSE)
write.table(ratio_no_log,file="output/ratio_no_log_normalize_distance_matrix.txt",sep="\t",quote=FALSE)

#conditions (bv - bacterial vaginosis as scored by nugent/amsel, i - intermediate, n - normal/healthy)
groups <- MyMetaOrdered$n_status #levels bv, i, n
originalgroups <- groups
# change conditions so that samples which are more than 50% one taxa are colored by that taxa
otuSum <- apply(otu.tab,1,sum)
otuMax <- apply(otu.tab,1,max)
otuWhichMax <- apply(otu.tab,1,which.max)
otuDominated <- which(otuMax > otuSum/2)

otuMaxTax <- taxonomy[otuWhichMax]
#otuDominated <- c(otuDominated[which(as.numeric(otuMaxTax[otuDominated])==32)],otuDominated[which(as.numeric(otuMaxTax[otuDominated])==33)])

taxonomyGroups <- as.character(groups)
taxonomyGroups[otuDominated] <- as.character(otuMaxTax[otuDominated])

taxonomyGroups <- as.factor(taxonomyGroups)

groups <- taxonomyGroups

# assign appropriate names to single taxa dominated groups
newLevels <- levels(taxonomyGroups)
splittaxa <- strsplit(levels(taxonomyGroups),split=";")

for (i in 1:length(splittaxa)) {
	if (length(splittaxa[[i]])>1) {
		newLevels[i] <- paste(splittaxa[[i]][length(splittaxa[[i]])-1],splittaxa[[i]][length(splittaxa[[i]])])
	}
	else {
		newLevels[i] <- splittaxa[[i]][1]
	}
}

levels(taxonomyGroups) <- newLevels

unweighted.pcoa <- pcoa(unweighted)
weighted.pcoa <- pcoa(weighted)
information.pcoa <- pcoa(information)
ratio_no_log.pcoa <- pcoa(ratio_no_log)

#function to get variance explained for the PCOA component labels
getVarExplained <- function(vector) {
	rawVarEx <- apply(vector,2,function(x) sd(x)*sd(x))
	totalVarExplained <- sum(rawVarEx)
	varEx <- rawVarEx/totalVarExplained
	return(varEx)
}

unweighted.varEx <- getVarExplained(unweighted.pcoa$vectors)
weighted.varEx <- getVarExplained(weighted.pcoa$vectors)
information.varEx <- getVarExplained(information.pcoa$vectors)
ratio_no_log.varEx <- getVarExplained(ratio_no_log.pcoa$vectors)

#get vector version of distance matrices for correlation plots below
unweighted.vector <- unlist(unweighted[lower.tri(unweighted,diag=TRUE)])
weighted.vector <- unlist(weighted[lower.tri(weighted,diag=TRUE)])
information.vector <- unlist(information[lower.tri(information,diag=TRUE)])
ratio_no_log.vector <- unlist(ratio_no_log[lower.tri(ratio_no_log,diag=TRUE)])

pdf("output/pcoa_plots.pdf")

#plot pcoa plots
plot(unweighted.pcoa$vectors[,1],unweighted.pcoa$vectors[,2], col=groups,main="Unweighted UniFrac\nprincipal coordinates analysis",xlab=paste("First Component", round(unweighted.varEx[1],digits=3),"variance explained"),ylab=paste("Second Component", round(unweighted.varEx[2],digits=3),"variance explained"),pch=19,cex.lab=1.4,cex.main=2)
plot(weighted.pcoa$vectors[,1],weighted.pcoa$vectors[,2], col=groups,main="Weighted UniFrac\nprincipal coordinates analysis",xlab=paste("First Component", round(weighted.varEx[1],digits=3),"variance explained"),ylab=paste("Second Component", round(weighted.varEx[2],digits=3),"variance explained"),pch=19,cex.lab=1.4,cex.main=2)
legend(0.2,0.32,levels(taxonomyGroups),col=palette(),pch=19)
plot(information.pcoa$vectors[,1],information.pcoa$vectors[,2], col=groups,main="Information UniFrac\nprincipal coordinates analysis",xlab=paste("First Component", round(information.varEx[1],digits=3),"variance explained"),ylab=paste("Second Component", round(information.varEx[2],digits=3),"variance explained"),pch=19,cex.lab=1.4,cex.main=2)
plot(ratio_no_log.pcoa$vectors[,1],ratio_no_log.pcoa$vectors[,2], col=groups,main="Ratio UniFrac\nprincipal coordinates analysis",xlab=paste("First Component", round(ratio_no_log.varEx[1],digits=3),"variance explained"),ylab=paste("Second Component", round(ratio_no_log.varEx[2],digits=3),"variance explained"),pch=19,cex.lab=1.4,cex.main=2)

#plot correlation between different UniFrac modes
plot(unweighted.vector,information.vector,main="unweighted vs. information UniFrac")
plot(weighted.vector,information.vector,main="weighted vs. information UniFrac")
plot(unweighted.vector,weighted.vector,main="unweighted vs. weighted UniFrac")
plot(ratio_no_log.vector,information.vector,main="ratio vs. information UniFrac")
plot(ratio_no_log.vector,weighted.vector,main="ratio vs. weighted UniFrac")

dev.off()