#' RNAi
#'
#' RNAi Package to do stuff
#'
#' @name RNAi
#'
#'

require(dplyr)

# mapper for hypergeometric distribution
# with lower.tail, return value is P[X > x], therefore x-1 as first argument
rsa.phyper.map <- function(row) {
  phyper(row[1]-1, row[2], row[3], row[4],
         lower.tail=F, log.p=T)
}

# b<-590 to 591 reaches the 1E-2180  lowest p-value limit
# a
# phyper(b, a-b, 30203, 1090, lower.tail=FALSE, log.p = TRUE)

# calculate p-values for each siRNA of a gene
# by default, return only data for the siRNA with the smallest p-value
# with full=T, all data is returned
rsa.prob <- function(x, N, full) {
  nr <- nrow(x)
  x <- x[order(x$rank),]
  a <- seq_len(nr)
  b <- x$rank
  c <- N-b
  d <- nr
  counts <- cbind(a,b,c,d)
  p <- apply(counts, 1, rsa.phyper.map)/log(10)

  if (full) {
    idx <- seq_len(nr)
  } else {
    idx <- which.min(p)
  }

  return(cbind(x, counts, p)[idx,])
}

#' rsa
#'
#'
#' @author Florian Nigsch, Gregory McAllister
#' @name rsa
#' @param rsadat data frame containing a minimum of gene id and value
#' @param gene.column column name in rsadat specifying the gene identifier
#' @param vale.column column name in rsadat specifying the value
#' @param activator boolean specifying whether the screen is an activator or inhibitor.  Activator will ranking such that numerically smaller values get lower ranks (ie are better)
#' @param full boolean specifying whether to return all objects and their associated p-values.  This will also return counts from the hypergeometric
#' @param subset boolean (T = limit data frame returned to gene identifier and LogP)
#' @return data frame
#' @references A probability-based approach for the analysis of large-scale RNAi screens
#'   Nature Methods - 4, 847 - 849 (2007), doi:10.1038/nmeth1089
#'   Paper: \url{http://www.nature.com/nmeth/journal/v4/n10/full/nmeth1089.html}
#'   SuppInfo: \url{http://www.nature.com/nmeth/journal/v4/n10/extref/nmeth1089-S1.pdf}
#'
#' @seealso \code{rsa.gnf}
#'
#' @export

rsa <- function(rsadat, activator=F, full=F, gene.column="gene", value.column="value", subset=F, drugseq=F,drugseq.ties='average') {

  switch <- ifelse(activator, -1, 1)

  if(drugseq) {
    ties.met<-drugseq.ties #default = 'average' which performs well upon manual review.
  } else {
    ties.met<-"min"
  }

  rsadat$rank <- rank(rsadat[,value.column] * switch, ties.method=ties.met)

  res <- by(rsadat, rsadat[,gene.column], rsa.prob, nrow(rsadat), full)

  res <- do.call("rbind", res)

  if(full)
    return(res)

  if (subset){
    tmp <- res[,c(gene.column,"p")]
    colnames(tmp)[2] <- "LogP"
    return(tmp)
  }else{
    tmp <- res[,!colnames(res) %in% c("rank","a","b","c","d")]
    colnames(tmp)[which(colnames(tmp)=="p")] <- "LogP"
    return(tmp)
  }

}

q1q3 <- function(dat){
  result <- quantile(dat$my_value,probs=c(0.25,0.75),na.rm=T)
  return (c(result[1],result[2]))
}

q0q1q3q4 <-function(dat){
  result <- quantile(dat$my_value,probs=c(0,0.25,0.75,1),na.rm=T)
  return (c(result[1],result[2],result[3],result[4]))
}

logq0q1q2q3q4<-function(dat){
  result <- quantile(dat$my_logvalue,probs=c(0,0.25,0.5,0.75,1),na.rm=T)
  return (c(result[1],result[2],result[3],result[4],result[5]))
}

#' score.screen.ZY.RQz
#'
#' Generate gene level scores for a single RNAi screen.  Runs RSA in both directions and generates Q1/Q3 per gene.
#'
#' @name score.screen
#' @param x data frame containing at least a gene column and score column
#' @param gene.column column name in rsadat specifying the gene identifier
#' @param vale.column column name in rsadat specifying the value
#' @param both.directions boolean indicating whether to calculate "RSA Up" as well
#'
#' @export

score.screen.ZY.RQz <- function(data,gene.column="gene",value.column="value",log.column="Log2FoldChange",drugseq=F,drugseq.ties='average') {
  if(drugseq){print('RSA setup for DRUG-seq: ties.methods is set to average in place of min in CRISPR/siRNA screens')}
  x.rsa.d <- rsa(data,gene.column=gene.column,value.column=value.column,subset=T,drugseq=drugseq,drugseq.ties=drugseq.ties)
  x.rsa.d <- unique(x.rsa.d[,c(gene.column,"LogP")])
  colnames(x.rsa.d)[2] <- "logP_RSA_Down"

  x.rsa.u <- rsa(data,gene.column=gene.column,value.column=value.column,subset=T,activator=T,drugseq=drugseq,drugseq.ties=drugseq.ties)
  x.rsa.u <- unique(x.rsa.u[,c(gene.column,"LogP")])
  colnames(x.rsa.u)[2] <- "logP_RSA_Up"

  #y <- ddply(data,gene.column,function(x) { quantile(x[,value.column],probs=c(0.25,0.75))})
  # remove plyr dependency - there are probably more elegant code for this thou...
  data$my_gene <- data[,gene.column]
  data$my_value <- data[,value.column]
  data$my_logvalue<- data[,log.column]
  data2<- select(data,my_gene,my_logvalue)
  data <- select(data,my_gene,my_value)
  #updated from q1q3 to q0q1q3q4 on 2017-11-20
  #y <- by(data,data$my_gene,q1q3)
  y <- by(data,data$my_gene,q0q1q3q4)
  y2<- by(data2,data2$my_gene,logq0q1q2q3q4)

  y <- as.data.frame(do.call(rbind,y))
  y$gene<-rownames(y)

  y2 <- as.data.frame(do.call(rbind,y2))
  y2$gene<-rownames(y2)

  #y <- y[c(5,1,2)]
  #colnames(y) <- c(gene.column,"rz_score_Q1","rz_score_Q3")
  #updated from above on 2017-11-20
  y <- y[c(5,1,2,3,4)]
  colnames(y) <- c(gene.column,"rz_score_min","rz_score_Q1","rz_score_Q3","rz_score_max")

  y2 <- y2[c(6,1,2,3,4,5)]
  colnames(y2) <- c(gene.column,"Min log2FoldChange","Q1 log2FoldChange","Median log2FoldChange","Q3 log2FoldChange","Max log2FoldChange")

  all <- merge(x.rsa.d,x.rsa.u,by=gene.column,all=T)

  zN<-by(data,data$my_gene,tally)
  zN <- as.data.frame(do.call(rbind,zN))
  zN$gene<-rownames(zN)
  zN <- zN[c(2,1)]
  colnames(zN)<-c(gene.column,"N")

  data_temp_D<-subset(data,data$my_value<=(-2.0))
  data_temp_D3<-subset(data,data$my_value<=(-3.0))
  data_temp_D4<-subset(data,data$my_value<=(-4.0))

  if(dim(data_temp_D)[1]==0) {
  } else {
    zD<-by(data_temp_D,data_temp_D$my_gene,tally)
    zD <- as.data.frame(do.call(rbind,zD))
    zD$gene<-rownames(zD)
    zD <- zD[c(2,1)]
    colnames(zD)<-c(gene.column,"z2_count_Down")
  }

  if(dim(data_temp_D3)[1]==0) {
  } else {
    zD3<-by(data_temp_D3,data_temp_D3$my_gene,tally)
    zD3 <- as.data.frame(do.call(rbind,zD3))
    zD3$gene<-rownames(zD3)
    zD3 <- zD3[c(2,1)]
    colnames(zD3)<-c(gene.column,"z3_count_Down")
  }

  if(dim(data_temp_D4)[1]==0) {
  } else {
    zD4<-by(data_temp_D4,data_temp_D4$my_gene,tally)
    zD4 <- as.data.frame(do.call(rbind,zD4))
    zD4$gene<-rownames(zD4)
    zD4 <- zD4[c(2,1)]
    colnames(zD4)<-c(gene.column,"z4_count_Down")
  }

  data_temp_U<-subset(data,data$my_value>=(2.0))
  data_temp_U3<-subset(data,data$my_value>=(3.0))
  data_temp_U4<-subset(data,data$my_value>=(4.0))

  if(dim(data_temp_U)[1]==0) {
  } else {
    zU<-by(data_temp_U,data_temp_U$my_gene,tally)
    zU <- as.data.frame(do.call(rbind,zU))
    zU$gene<-rownames(zU)
    zU <- zU[c(2,1)]
    colnames(zU)<-c(gene.column,"z2_count_Up")
  }

  if(dim(data_temp_U3)[1]==0) {
  } else {
    zU3<-by(data_temp_U3,data_temp_U3$my_gene,tally)
    zU3 <- as.data.frame(do.call(rbind,zU3))
    zU3$gene<-rownames(zU3)
    zU3 <- zU3[c(2,1)]
    colnames(zU3)<-c(gene.column,"z3_count_Up")
  }

  if(dim(data_temp_U4)[1]==0) {
  } else {
    zU4<-by(data_temp_U4,data_temp_U4$my_gene,tally)
    zU4 <- as.data.frame(do.call(rbind,zU4))
    zU4$gene<-rownames(zU4)
    zU4 <- zU4[c(2,1)]
    colnames(zU4)<-c(gene.column,"z4_count_Up")
  }

  all <- merge(all,y,by=gene.column,all=T)
  all <- merge(all,y2,by=gene.column,all=T)

  all <- merge(all,zN,by=gene.column,all=T)

  if(dim(data_temp_D)[1]==0) {
    all$z2_count_Down<-(0)
  } else {
    all <- merge(all,zD,by=gene.column,all=T)
  }

  if(dim(data_temp_U)[1]==0) {
    all$z2_count_Up<-(0)
  } else {
    all <- merge(all,zU,by=gene.column,all=T)
  }

  if(dim(data_temp_D3)[1]==0) {
    all$z3_count_Down<-(0)
  } else {
    all <- merge(all,zD3,by=gene.column,all=T)
  }

  if(dim(data_temp_U3)[1]==0) {
    all$z3_count_Up<-(0)
  } else {
    all <- merge(all,zU3,by=gene.column,all=T)
  }

  if(dim(data_temp_D4)[1]==0) {
    all$z4_count_Down<-(0)
  } else {
    all <- merge(all,zD4,by=gene.column,all=T)
  }

  if(dim(data_temp_U4)[1]==0) {
    all$z4_count_Up<-(0)
  } else {
    all <- merge(all,zU4,by=gene.column,all=T)
  }

  all[is.na(all$z2_count_Down),'z2_count_Down']<-0
  all[is.na(all$z2_count_Up),'z2_count_Up']<-0
  all[is.na(all$z3_count_Down),'z3_count_Down']<-0
  all[is.na(all$z3_count_Up),'z3_count_Up']<-0
  all[is.na(all$z4_count_Down),'z4_count_Down']<-0
  all[is.na(all$z4_count_Up),'z4_count_Up']<-0

  invisible(all)
}


# Scratchpad for data exploration. Used to be part of classify-*.r scripts.
library(caret)

source("pixel-based/utils/load-sampling-data.r")
source("pixel-based/utils/covariate-names.r")

Data = LoadTrainingAndCovariates()
Data.df = Data
class(Data.df) = "data.frame"
rm(Data)
Data.df = AddZeroValueColumns(Data.df)

ClassNames = GetIIASAClassNames(TRUE)
CovariateNames = GetUncorrelatedPixelCovars() #names(Data[which(names(Data)=="min"):(length(Data)-1)])
CovariateNames = GetAllPixelCovars()

# Explore correlations
Covariates[findCorrelation(cor(Data.df[,CovariateNames]), cutoff = 0.75)]

library(corrplot)
DC = cor(Data.df[,c(1:17, 22:49)], use="complete.obs")
DP = cor.mtest(Data.df[,c(1:17, 22:49)])
corrplot(DC, p.mat=DP$p, method="ellipse", insig="blank")
# Trend and intercept are colinear, mean.ndvi and its quantiles (including min max) are highly correlated
# Then red with swir, osavi with ndvi, ndvi.mean with ndvi, evi with ndmi, blue with swir and ndvi, si with co
# TRI and roughness are also correlated with slope
# And NDMI, IQR are correleated with mean.ndvi
DC = cor(Data.df[,c(1:17, 25, 27:34, 39, 46:49)], use="complete.obs")
DP = cor.mtest(Data.df[,c(1:17, 25, 27:34, 39, 46:49)])
corrplot(DC, p.mat=DP$p, method="ellipse", insig="blank")
names(Data.df)[c(1:17, 25, 27:34, 39, 46:49)]

# Zero inflation
nearZeroVar(Data.df[,ClassNames], saveMetrics = TRUE)

# Impute values
apply(Data.df, 2, function(x){sum(is.na(x))}) / nrow(Data.df) * 100 # Most missing in terrain covars, 10%
library(yaImpute)
ImputeFormula = formula(co ~ co2+si2+trend+phase1+amplitude1+phase2+amplitude2+nir+elevation+slope+tpi+tri+roughness+x+y+location_id+rowid+aspect+mean.ndvi)
ImputeFormula = formula(location_id~min)
nrow(Data)
CompleteDataIdx = apply(Data, 1, function(x){!any(is.na(x))})
CompleteData = Data[CompleteDataIdx,]
nrow(CompleteData)

Data.df = Data
class(Data.df) = "data.frame"
Imputer = yai(x=Data.df[,c("x", "y")], y=Data.df[,c("min", "max")])
ExploreImputation = impute(Imputer, observed = FALSE)
names(ExploreImputation)
Data.df[which(is.na(Data.df$min)),]
nrow(Data)
nrow(ExploreImputation)

library(Hmisc)
Data$co = impute(Data$co)
Data$co2 = impute(Data$co2)
Data$si2 = impute(Data$si2)
Data$trend = impute(Data$trend)
Data$phase1 = impute(Data$phase1)
Data$amplitude1 = impute(Data$amplitude1)
Data$phase2 = impute(Data$phase2)
Data$amplitude2 = impute(Data$amplitude2)
Data$mean.ndvi = impute(Data$mean.ndvi)
Data$nir = impute(Data$nir)
Data$elevation = impute(Data$elevation)
Data$slope = impute(Data$slope)
Data$tpi = impute(Data$tpi)

# With caret - actually works
pp = preProcess(Data.df[,CovariateNames], method="bagImpute")
Imputed = predict(pp, Data.df[,CovariateNames])
head(Data.df[is.na(Data.df$elevation),CovariateNames])
head(Imputed[is.na(Data.df$elevation),])

# Drop values instead; all values that have no harmonics:
Data.df = Data.df[!is.na(Data.df$phase2),]
nrow(Data.df)
# And all values that don't have observations in 2017
Data.df = Data.df[!is.na(Data.df$nir),]
Data.df = Data.df[!is.na(Data.df$slope),]

apply(Data.df[,5:17], 2, function(x){sum(x==0)}) / nrow(Data.df) * 100 # 84% of all data is 0
apply(Data.df[,5:17], 2, function(x){sum(x==100)}) / nrow(Data.df) * 100 # Only bare soil has a lot (18%) of 100

## Imbalanced classes
table(Data.df[["dominant_lc"]])
# Drop lichen and moss
Data.df = Data.df[!Data.df$dominant_lc == "lichen_and_moss",]
# Also drop the level, otherwise sampling would try to sample from 0 points
Data.df$dominant_lc = droplevels(Data.df$dominant_lc)
# We'd lose only 81 points if we exclude wetlands as well, but they are present in Africa

# Test ROSE
library(ROSE)
# fails due to only supporting 2 classes
ovun.sample(paste("dominant_lc ~", paste(CovariateNames, collapse="+")), data=Data.df, method="over", N=max(table(Data.df[["dominant_lc"]]))*length(ClassNames))

# Test DMwR
library(DMwR)
# Crashes if we don't use droplevels beforehand, and crashes if a column is logical
SmoteSample = SMOTE(formula(paste("dominant_lc ~", paste(CovariateNames, collapse="+"))), data=Data.df[,c(ClassNames, "dominant_lc")], k=1)
str(SmoteSample)
# It seems to balance the last level of dominant_lc against all others, rather than balance all among themselves
table(SmoteSample[["dominant_lc"]])
Data.df[Data.df$dominant_lc == "wetland_herbaceous","wetland_herbaceous"]

# Test with just the water class
Data.df$no.water = Data.df$water == 0
Data.df$no.water = as.factor(Data.df$no.water)

Result1 = NULL
Result2 = NULL
for (i in 1:length(folds))
{
ValidationSet = Data.df[folds[[i]],]
TrainingSet = Data.df[-folds[[i]],]
WaterFormula = formula(paste("water ~", paste(CovariateNames, collapse="+")))
WaterFormulaBin = formula(paste("as.factor(no.water) ~", paste(CovariateNames, collapse="+")))
RFFullModelbin = ranger(WaterFormulaBin, data=TrainingSet)

CombinedPred = predict(RFFullModelbin, ValidationSet)$prediction
#plot(ValidationSet$no.water~CombinedPred) # This is in fact a perfect prediction
CombinedPred = as.numeric(!as.logical(CombinedPred)) # Turn FALSE into 1 and TRUE into 0
# Predict the cases where there is more than 0 water
RFIsWaterModel = ranger(WaterFormula, data=TrainingSet[CombinedPred == 1,])
CombinedPred[CombinedPred == 1] = predict(RFIsWaterModel, ValidationSet[CombinedPred == 1,])$prediction
Result1 = c(Result1, CombinedPred)
# Compare between single model and two-step model
RFFullModel = ranger(WaterFormula, data=TrainingSet)
Result2 = c(Result2, predict(RFFullModel, ValidationSet)$prediction)
}
AccuracyStats(c(Result1)[order(unlist(folds))], Data.df$water)
AccuracyStats(c(Result2)[order(unlist(folds))], Data.df$water)

plot(ValidationSet$water~predict(RFFullModel, ValidationSet)$prediction, col="blue")
points(ValidationSet$water~CombinedPred, col="green")
abline(0,1)

AccuracyStats(predict(RFFullModel, ValidationSet)$prediction, ValidationSet$water)
AccuracyStats(CombinedPred, ValidationSet$water) # MAE is better, but RMSE is worse


library(ggplot2)
data = read.table("maize_sorghum5p")

mypositions1 <- data.frame(
  id = c(c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data))),
  x=c(data$V1,data$V2,data$V4,data$V3),
  score=c(data$V5,data$V5,data$V5,data$V5),
  y=c(rep("sorghum", nrow(data)),rep("sorghum", nrow(data)),rep("maize", nrow(data)),rep("maize", nrow(data)))
)

changetoM <- function ( position ){
  100000 - position
}

p = ggplot(mypositions1, aes(x = x, y = y)) +  geom_polygon(aes( group = id, fill=score), alpha=0.4) +scale_fill_gradient(low="blue", high="red")+ scale_x_continuous(labels=changetoM) + labs(x="", y="", title="")+
  theme_bw() +theme_grey(base_size = 36) + theme(axis.line = element_blank(),
                                           panel.grid.major = element_blank(),
                                           panel.grid.minor = element_blank(),
                                           panel.border = element_rect(fill=NA,color="black", size=0.5, linetype="solid"),
                                           panel.background = element_blank(),
                                           axis.text.y = element_text( colour = "black"),
                                           axis.text.x = element_text(angle=300, hjust=0, vjust=1, colour = "black"))
p
png("maize_sorghum5p.png" , width=2000, height=450)
p
dev.off()
pdf("maize_sorghum5p.pdf" , width=33, height=7.5)
p
dev.off()

data = read.table("maize_sorghum5p_syntenic")

mypositions1 <- data.frame(
  id = c(c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data))),
  x=c(data$V1,data$V2,data$V4,data$V3),
  score=c(data$V5,data$V5,data$V5,data$V5),
  y=c(rep("sorghum", nrow(data)),rep("sorghum", nrow(data)),rep("maize", nrow(data)),rep("maize", nrow(data)))
)

changetoM <- function ( position ){
  100000 - position
}

p = ggplot(mypositions1, aes(x = x, y = y)) +  geom_polygon(aes( group = id, fill=(score^2)), alpha=0.4) +scale_fill_gradient(low="blue", high="red")+ scale_x_continuous(labels=changetoM) + labs(x="", y="", title="")+
  theme_bw() +theme_grey(base_size = 36) + theme(axis.line = element_blank(),
                                                 panel.grid.major = element_blank(),
                                                 panel.grid.minor = element_blank(),
                                                 panel.border = element_rect(fill=NA,color="black", size=0.5, linetype="solid"),
                                                 panel.background = element_blank(),
                                                 axis.text.y = element_text( colour = "black"),
                                                 axis.text.x = element_text(angle=300, hjust=0, vjust=1, colour = "black"))
p
png("maize_sorghum5p_syntenic.png" , width=2000, height=450)
p
dev.off()
pdf("maize_sorghum5p_syntenic.pdf" , width=33, height=7.5)
p
dev.off()

library(ggplot2)
data = read.table("93983.5queryo")

mypositions1 <- data.frame(
  id = c(c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data))),
  x=c(data$V1,data$V2,data$V4,data$V3),
  length=c(data$V5,data$V5,data$V5,data$V5),
  pvalue=c(data$V6,data$V6,data$V6,data$V6),
  y=c(rep("maize", nrow(data)),rep("maize", nrow(data)),rep("sorghum", nrow(data)),rep("sorghum", nrow(data)))
)

changetoM <- function ( position ){
  100000 - position
}

p = ggplot(mypositions1, aes(x = x, y = y)) +  geom_polygon(aes( group = id, fill=-log10(pvalue)), alpha=0.4) +
    scale_fill_gradient(low="blue", high="red")+ scale_x_continuous(labels=changetoM) + labs(x="", y="", title="")+
  theme_bw() +theme_grey(base_size = 36)  + theme(axis.line = element_blank(),
                                           panel.grid.major = element_blank(),
                                           panel.grid.minor = element_blank(),
                                           panel.border = element_rect(fill=NA,color="black", size=0.5, linetype="solid"),
                                           panel.background = element_blank(),
                                           axis.text.y = element_text( colour = "black"),
                                           axis.text.x = element_text(angle=300, hjust=0, vjust=1, colour = "black"))

png("SORBI_3009G024600_5_prime_rev_o.png" , width=2000, height=450)
p
dev.off()
pdf("SORBI_3009G024600_5_prime_rev_o.pdf" , width=33, height=7.5)
p
dev.off()

library(ggplot2)
data = read.table("SORBI_3009G024600_5_prime_rev_o_weighted")

mypositions1 <- data.frame(
  id = c(c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data))),
  x=c(data$V1,data$V2,data$V4,data$V3),
  length=c(data$V5,data$V5,data$V5,data$V5),
  pvalue=c(data$V6,data$V6,data$V6,data$V6),
  y=c(rep("maize", nrow(data)),rep("maize", nrow(data)),rep("sorghum", nrow(data)),rep("sorghum", nrow(data)))
)

changetoM <- function ( position ){
  100000 - position
}

library(ggplot2)
data = read.table("SORBI_3001G121600_5_prime_o")
data = data[which(data$V6<0.01),]
mypositions1 <- data.frame(
  id = c(c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data))),
  x=c(data$V1,data$V2,data$V4,data$V3),
  length=c(data$V5,data$V5,data$V5,data$V5),
  pvalue=c(data$V6,data$V6,data$V6,data$V6),
  y=c(rep("sorghum", nrow(data)),rep("sorghum", nrow(data)),rep("maize", nrow(data)),rep("maize", nrow(data)))
)

changetoM <- function ( position ){
  100000 - position
}

p = ggplot(mypositions1, aes(x = x, y = y)) +  geom_polygon(aes( group = id, fill=-log10(pvalue)), alpha=0.4) +
    scale_fill_gradient(low="blue", high="red")+ scale_x_continuous(limits = c(18000, 100000), labels=changetoM) + labs(x="", y="", title="")+
  theme_bw() +theme_grey(base_size = 36)  + theme(axis.line = element_blank(),
                                           panel.grid.major = element_blank(),
                                           panel.grid.minor = element_blank(),
                                           panel.border = element_rect(fill=NA,color="black", size=0.5, linetype="solid"),
                                           panel.background = element_blank(),
                                           axis.text.y = element_text( colour = "black"),
                                           axis.text.x = element_text(angle=300, hjust=0, vjust=1, colour = "black"))

png("SORBI_3001G121600_5_prime_o.png" , width=2000, height=450)
p
dev.off()
pdf("SORBI_3001G121600_5_prime_o.pdf" , width=33, height=7.5)
p
dev.off()

library(ggplot2)
data = read.table("SORBI_3009G024600_5_prime_many_to_many_seed_xtend")
data = data[which(data$V6<0.01),]
mypositions1 <- data.frame(
  id = c(c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data))),
  x=c(data$V1,data$V2,data$V4,data$V3),
  length=c(data$V5,data$V5,data$V5,data$V5),
  pvalue=c(data$V6,data$V6,data$V6,data$V6),
  y=c(rep("maize", nrow(data)),rep("maize", nrow(data)),rep("sorghum", nrow(data)),rep("sorghum", nrow(data)))
)

changetoM <- function ( position ){
  100000 - position
}

p = ggplot(mypositions1, aes(x = x, y = y)) +  geom_polygon(aes( group = id, fill=-log10(pvalue)), alpha=0.4) +
    scale_fill_gradient(low="blue", high="red")+ scale_x_continuous(limits = c(0, 100000), labels=changetoM) + labs(x="", y="", title="")+
  theme_bw() +theme_grey(base_size = 36)  + theme(axis.line = element_blank(),
                                           panel.grid.major = element_blank(),
                                           panel.grid.minor = element_blank(),
                                           panel.border = element_rect(fill=NA,color="black", size=0.5, linetype="solid"),
                                           panel.background = element_blank(),
                                           axis.text.y = element_text( colour = "black"),
                                           axis.text.x = element_text(angle=300, hjust=0, vjust=1, colour = "black"))

png("1o.png" , width=2000, height=450)
p
dev.off()
pdf("1o.pdf" , width=33, height=7.5)
p
dev.off()

library(ggplot2)
data = read.table("SORBI_3009G024600_5_prime_many_to_many_2gaps_o")

mypositions1 <- data.frame(
  id = c(c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data))),
  x=c(data$V1,data$V2,data$V4,data$V3),
  length=c(data$V5,data$V5,data$V5,data$V5),
  pvalue=c(data$V6,data$V6,data$V6,data$V6),
  y=c(rep("maize", nrow(data)),rep("maize", nrow(data)),rep("sorghum", nrow(data)),rep("sorghum", nrow(data)))
)

changetoM <- function ( position ){
  100000 - position
}

p = ggplot(mypositions1, aes(x = x, y = y)) +  geom_polygon(aes( group = id, fill=-log10(pvalue)), alpha=0.4) +
    scale_fill_gradient(low="blue", high="red")+ scale_x_continuous(limits = c(0, 100000), labels=changetoM) + labs(x="", y="", title="")+
  theme_bw() +theme_grey(base_size = 36)  + theme(axis.line = element_blank(),
                                           panel.grid.major = element_blank(),
                                           panel.grid.minor = element_blank(),
                                           panel.border = element_rect(fill=NA,color="black", size=0.5, linetype="solid"),
                                           panel.background = element_blank(),
                                           axis.text.y = element_text( colour = "black"),
                                           axis.text.x = element_text(angle=300, hjust=0, vjust=1, colour = "black"))

png("2.png" , width=2000, height=450)
p
dev.off()
pdf("2.pdf" , width=33, height=7.5)
p
dev.off()

library(ggplot2)
data = read.table("3sorghumo")
mypositions1 <- data.frame(
  id = c(c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data))),
  x=c(data$V1,data$V2,data$V4,data$V3),
  length=c(data$V5,data$V5,data$V5,data$V5),
  pvalue=c(data$V6,data$V6,data$V6,data$V6),
  y=c(rep("maize", nrow(data)),rep("maize", nrow(data)),rep("sorghum", nrow(data)),rep("sorghum", nrow(data)))
)

changetoM <- function ( position ){
  100000 - position
}

p = ggplot(mypositions1, aes(x = x, y = y)) +  geom_polygon(aes( group = id, fill=-log10(pvalue)), alpha=0.4) +
    scale_fill_gradient(low="blue", high="red")+ scale_x_continuous(limits = c(0, 100000), labels=changetoM) + labs(x="", y="", title="")+
  theme_bw() +theme_grey(base_size = 36)  + theme(axis.line = element_blank(),
                                           panel.grid.major = element_blank(),
                                           panel.grid.minor = element_blank(),
                                           panel.border = element_rect(fill=NA,color="black", size=0.5, linetype="solid"),
                                           panel.background = element_blank(),
                                           axis.text.y = element_text( colour = "black"),
                                           axis.text.x = element_text(angle=300, hjust=0, vjust=1, colour = "black"))

png("3o.png" , width=2000, height=450)
p
dev.off()
pdf("3o.pdf" , width=33, height=7.5)
p
dev.off()

library(ggplot2)
data = read.table("4sorghumo")
mypositions1 <- data.frame(
  id = c(c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data)), c(1:nrow(data))),
  x=c(data$V1,data$V2,data$V4,data$V3),
  length=c(data$V5,data$V5,data$V5,data$V5),
  pvalue=c(data$V6,data$V6,data$V6,data$V6),
  y=c(rep("maize", nrow(data)),rep("maize", nrow(data)),rep("sorghum", nrow(data)),rep("sorghum", nrow(data)))
)

changetoM <- function ( position ){
  100000 - position
}

p = ggplot(mypositions1, aes(x = x, y = y)) +  geom_polygon(aes( group = id, fill=-log10(pvalue)), alpha=0.4) +
    scale_fill_gradient(low="blue", high="red")+ scale_x_continuous(limits = c(0, 100000), labels=changetoM) + labs(x="", y="", title="")+
  theme_bw() +theme_grey(base_size = 36)  + theme(axis.line = element_blank(),
                                           panel.grid.major = element_blank(),
                                           panel.grid.minor = element_blank(),
                                           panel.border = element_rect(fill=NA,color="black", size=0.5, linetype="solid"),
                                           panel.background = element_blank(),
                                           axis.text.y = element_text( colour = "black"),
                                           axis.text.x = element_text(angle=300, hjust=0, vjust=1, colour = "black"))

png("4o.png" , width=2000, height=450)
p
dev.off()
pdf("4o.pdf" , width=33, height=7.5)
p
dev.off()


#' @name cMGL.multi
#' @rdname  cMGL.multi
#' @title d-dimensional MGL and survival MGL copula
#' @description
#' Density, distribution function, and random generation for the MGL and survival MGL copula.
#'
#' @param u d-dimensional matrix
#' @param d d-dimensional
#' @param pars copula parameter, denoted by \eqn{\delta>0}.
#' @param log logical; if TRUE, probabilities/densities p are returned as log(p).
#' @param n number of observations. If length(n) > 1, the length is taken to be the number required.
#' @importFrom stats qbeta
#' @importFrom stats pbeta
#' @importFrom stats runif
#' @importFrom stats pgamma
#' @md
#' @return
#' * \code{dcMGL.multi}, \code{pcMGL.multi} and \code{rcMGL.multi} gives values of Density, distribution function, and random generation for the d-dimensional MGL copula with copula parameter \eqn{\delta>0}.
#' * \code{dcMGL180.multi}, \code{pcMGL180.multi} and \code{rcMGL180.multi} gives values of Density, distribution function, and random generation for the d-dimensional MGL copula with copula parameter \eqn{\delta>0}.
NULL

#' @rdname cMGL.multi
#' @export
#' @examples
#'
#'
#' dcMGL.multi(u = cbind(c(0.6, 0.1, 0.5), c(0.3, 0.9, 0.2)), pars = 2, log = FALSE)
#'
#' dcMGL.multi(u = cbind(c(0.6, 0.1), c(0.3, 0.9), c(0.5, 0.6)), pars = 2, log = TRUE)
dcMGL.multi <- function(u, pars, log = FALSE) {
  # coding as a matrix
  dim <- ncol(u)
  a <- 1 / pars[1]
  q <- (qbeta(1 - u, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u, shape1 = 0.5, shape2 = a)))
  logdc <- 0
  for (i in seq_len(nrow(u))) {
    logdc[i] <- (dim - 1) * lgamma(a) + lgamma(a + dim / 2) - dim * lgamma(a + 0.5) + (a + 0.5) * sum(log(q[i, ] + 1)) - (a + dim / 2) * log(sum(q[i, ]) + 1)
  }
  dc <- exp(logdc)
  dc[which(q == Inf)] <- 0
  if (log == TRUE) {
    out <- logdc
  } else {
    out <- dc
  }
  return(out)
}

#' @rdname cMGL.multi
#' @export
#' @examples
#' \dontrun{
#'
#' dcMGL180.multi(u = cbind(c(0.6, 0.1, 0.5), c(0.3, 0.9, 0.2)), pars = 2, log = FALSE)
#'
#' dcMGL180.multi(u = cbind(c(0.6, 0.1), c(0.3, 0.9), c(0.5, 0.6)), pars = 2, log = TRUE)
#' }
dcMGL180.multi <- function(u, pars, log = FALSE) {
  dcMGL.multi(u = 1 - u, pars = pars, log = log)
}

#' @rdname cMGL.multi
#' @export
#' @examples
#' # 2-dim MGL copula
#' pcMGL.multi(u = cbind(c(0.5, 0.5), c(0.01, 0.9)), pars = 3)
#' # 3-dim MGL copula
#' pcMGL.multi(u = cbind(c(0, 0.2, 0.5), c(0.5, 0.2, 0.5), c(0.01, 0.5, 0.9)), pars = 3)
pcMGL.multi <- function(u, pars) {
  # dim <- ncol(u)
  a <- 1 / pars[1]

  q <- (qbeta(1 - u, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u, shape1 = 0.5, shape2 = a)))
  z <- 0
  for (i in seq_len(nrow(u))) {
    if (any(q[i, ] %in% Inf)) {
      z[i] <- 0
    } else {
      temp <- as.vector(q[i, ])
      fin <- function(theta) { # rely on a
        # theta <- as.vector()
        m <- pracma::erfc((temp * theta)^0.5)
        k <- base::prod(m)
        out <- k * theta^(a - 1) * exp(-theta) / gamma(a)
        out
      }
      fin <- Vectorize(fin)
      z[i] <- as.numeric(pracma::integral(
        fun = fin,
        xmin = 0,
        xmax = Inf, method = "Clenshaw"
      ))
    }
  }
  return(z) # rely on k
}

#' @rdname cMGL.multi
#' @export
#' @examples
#' pcMGL180.multi(u = cbind(c(0.5, 0.5), c(0.01, 0.9)), pars = 3)
pcMGL180.multi <- function(u, pars) {
  # dim <- ncol(u)
  delta <- pars[1]

  q <- (qbeta(u, shape1 = 0.5, shape2 = delta) / (1 - qbeta(u, shape1 = 0.5, shape2 = delta)))
  z <- 0
  for (i in seq_len(nrow(u))) {
    # if(any(q[i,] %in% Inf)) {
    #   z[i] <- 0
    # } else {
    temp <- as.vector(q[i, ])
    fin <- function(theta) { # rely on theta
      m <- pgamma(q = temp / theta, shape = 0.5, scale = 1)
      k <- base::prod(m)
      out <- k * theta^(-(delta + 1)) * exp(-1 / theta) / gamma(delta)
      out
    }
    fin <- Vectorize(fin)

    z[i] <- as.numeric(pracma::integral(
      fun = fin,
      xmin = 0,
      xmax = Inf, method = "Clenshaw"
    ))
  }
  return(z)
}
# pcMGL180.multi(u = cbind(c(0.5, 0.1), c(0.9, 0.1)), pars = 1.5)
# pcMGB2.bivar(u1 = c(0.5, 0.1), u2 = c(0.9, 0.1), pars1 = 0.5, pars2 = 0.5, pars3 = 1.5)

#' @rdname cMGL.multi
#' @export
#' @examples
#' Usim <- rcMGL.multi(n = 1000, d = 2, pars = 1)
#' plot(Usim)
rcMGL.multi <- function(n, d, pars) {
  a <- 1 / pars
  dseq <- seq(1:(d - 1))
  anew <- c(a, a + dseq / 2)
  Iinv_trans <- function(u, a) {
    qbeta(1 - u, shape1 = 0.5, shape2 = a) / (1 - qbeta(1 - u, shape1 = 0.5, shape2 = a))
  }
  umat <- matrix(data = runif(n * d, min = 0, max = 1), nrow = n, ncol = d)
  mmat <- qmat <- zmat <- Usim <- matrix(data = 0, nrow = n, ncol = d)

  for (j in seq_len(ncol(umat))) {
    qmat[, j] <- Iinv_trans(umat[, j], a = anew[j]) # column j denots the qj
  }

  mmat[, 1] <- qmat[, 1]
  mmat[, 2] <- (1 + mmat[, 1]) * qmat[, 2]
  if (d > 2) {
    for (j in 3:ncol(umat)) {
      tempmat <- mmat[, (1):(ncol(umat) - 1)]
      if (n == 1) {
        msum <- sum(tempmat)
      } else {
        msum <- apply(tempmat, MARGIN = 1, sum)
      }
      mmat[, j] <- (1 + msum) * qmat[, j]
    }
  }

  for (j in seq_len(ncol(zmat))) {
    k <- mmat[, j] / (mmat[, j] + 1)
    Usim[, j] <- 1 - pbeta(k, shape1 = 0.5, shape2 = a)
  }

  return(Usim)
}

#' @rdname cMGL.multi
#' @export
#' @examples
#' Usim <- rcMGL180.multi(n = 1000, d = 2, pars = 1)
#' plot(Usim)
rcMGL180.multi <- function(n, d, pars) {
  1 - rcMGL.multi(n = n, d = d, pars = pars)
}


# tidyeval ----------------------------------------------------------------
# http://dplyr.tidyverse.org/articles/programming.html

library(tidyverse)

df <- tibble(
  g1 = c(1, 1, 2, 2, 2),
  g2 = c(1, 2, 1, 2, 1),
  g3 = c(2, 2, 1, 2, 1),
  a = sample(5),
  b = sample(5)
)

df %>%
  group_by(g1) %>%
  summarise(a = mean(a))
df %>%
  group_by(g2) %>%
  summarise(a = mean(a))
df %>%
  group_by(g3) %>%
  summarise(a = mean(a))

# This is hard because you're used to referential transparency
f <- function(x) x * 10
g <- function(x) x + 1

f(g(10) + 2)
# that is the same as this:
y <- g(10) + 2
f(y)

# But dplyr is not referentially transparent: you can't
# replace an intermediate expression with a variable
group_var <- g2
df %>%
  group_by(group_var) %>%
  summarise(a = mean(a))

# You might hope that this works:
group_var <- "g2"
df %>%
  group_by(group_var) %>%
  summarise(a = mean(a))

# To solve this problem we need a new data structure:
# the quosure

quo(g1)
quo(x + y + z)

group_var <- quo(g1)
df %>%
  group_by(group_var) %>%
  summarise(a = mean(a))

# and we need some way to "unquote" or insert the
# value of quosure into the call.
df %>%
  group_by(!!group_var) %>%
  summarise(a = mean(a))

my_group_by <- function(df, group_var) {
  group_var <- enquo(group_var)

  df %>%
    group_by(!!group_var) %>%
    summarise(a = mean(a))
}
my_group_by(df, g1)

summary_var <- quo(a)

df %>%
  group_by(g1) %>%
  summarise(
    mean = mean(!!summary_var),
    sd = sd(!!summary_var)
  )
)

df %>%
  group_by(g1) %>%
  summarise(
    mean = mean(!!summary_var),
    sd = sd(!!summary_var)
  )
)

code/06 dplyr 01/New Features/tidyeval.r

code/AY 20_21/06 dplyr 01/New Features/tidyeval.r


##' Merge Constraints and respect rhs_dimnames and constr_dimnames
##' wraps hitandrun::mergeConstraints to preserve component dimnames
##" only stacks them
##' @param a,b a constraint object as in hitandrun
##' @return ab merged constraint object
merge_constraints <- function(a, b) {
    constr <- mergeConstraints(a, b)
    constr$rhs_dimnames <- c(a$dimnames, b$dimnames)
    constr$constr_dimnames <- a$constr_dimnames
    return(constr)
}

##' Merge Constraints Recursively
##' wraps merge_constraints and thereby hitandrun::mergeConstraints
##' @param a,b a constraint object as in hitandrun
##' @return ab merged constraint object
merge_constraints_list <- function(constraints_list) {
    # Reduce(merge_constraints, constraints_list)
    len <- length(constraints_list)
    if (len == 1){
        return(constraints_list[[1]])
    } else if (len == 2){
        return(merge_constraints(constraints_list[[1]], constraints_list[[2]]))
    } else {
        return(merge_constraints(constraints_list[[1]], merge_constraints_list(constraints_list[2:len])))
    }
}

##' create vector of inequalities ('<=' to match shape of constraint
##' useful when creating an inequality from scratch.
##' @param constr constraint matrix as in hitandrun
##' @return dir vector of '<=' of len == nrow(constr)
all_less_than <- function(constr) rep("<=", nrow(constr))

##' Print constraint to terminal
##' Useful for inspection. see plot_constraint_matrix for a visual representation
##' @param constr constraint matrix as in hitandrun
print_constraint <- function(constraint_object) {
    print(paste(nrow(constraint_object$constr), "rows (constraints)", ncol(constraint_object$constr),
        "cols (variables)"))
    cbind(constraint_object$constr, dir = constraint_object$dir, rhs = constraint_object$rhs) %>%
        as.data.frame %>% print
}

##' Diagonally merge two constraints
##' combines two constraints, and renames the colnames of the second constraint
##' to make sure they do not stack atop one another.
##' @param first_constraint,second_constraint constraint objects with $constr, $dir, $rhs
##' @param string_to_append_to_second_constraint string to append. i.e. a number. it will be appended after an underscore.
##' @return constr combined constraint going down the diagonal.
diagonal_merge_constraints <- function(first_constraint, second_constraint, string_to_append_to_second_constraint) {
    bb <- Matrix::bdiag(first_constraint$constr,second_constraint$constr) %>% as.matrix
    muscles_with_suffix <- paste(colnames(second_constraint$constr),string_to_append_to_second_constraint, sep = "_")
    constraintrows_with_suffix <- paste(rownames(second_constraint$constr),string_to_append_to_second_constraint, sep = "_")
    global_colnames <- c(colnames(first_constraint$constr), muscles_with_suffix)
    colnames(bb) <- global_colnames
    rownames(bb) <- c(rownames(first_constraint$constr),rownames(second_constraint$constr))

    c1_height <- nrow(first_constraint$constr)
    first_constraint$constr <- bb[1:c1_height,]
    second_constraint$constr <- bb[(c1_height+1):nrow(bb),]

    rownames(second_constraint$constr) <- constraintrows_with_suffix

    merged_constraint <- merge_constraints(first_constraint, second_constraint)
    merged_constraint$constr <- merged_constraint$constr %>% as.matrix
    return(merged_constraint)
}

##' Diagonally merge constraint list
##' Accepts inputs of length 1, 2, to n. Respects colnames and rownames
##' Adds iteravely to the diagonal. Performance fo current implementation is acceptable.
##' @param list_of_constraints each a constraint, see `?hitandrun`
##' @return constr combined constraint going down the diagonal.
diagonal_merge_constraint_list <- function(list_of_constraints) {
    list_len <- length(list_of_constraints)
    if (list_len == 1) {
        return(list_of_constraints[[1]])
    } else if (list_len == 2) {
        return(diagonal_merge_constraints(list_of_constraints[[1]], list_of_constraints[[2]],
            1))
    }
    var_result <- diagonal_merge_constraints(list_of_constraints[[1]], list_of_constraints[[2]],
        1)
    for (pair_i in seq(2, list_len - 1)) {
        var_result <- diagonal_merge_constraints(var_result, list_of_constraints[[pair_i +
            1]], pair_i)
    }
    var_result$constr <- var_result$constr %>% as.matrix
    var_result$dir <- var_result$dir %>% as.vector
    var_result$rhs <- var_result$rhs %>% as.vector
    return(var_result)
}

##' remove labels
##' useful for ggplot objects you want to clean up
##' @return p ggplot object function that can be added to a ggplot object.
remove_labels <- function() {
    theme(axis.title.x = element_blank(), axis.text.x = element_blank(), axis.line = element_blank(),
        axis.ticks.x = element_blank(), axis.title.y = element_blank(), axis.text.y = element_blank(),
        axis.ticks.y = element_blank())
}

##' Rotate Matrix
##' Useful when you want to visualize a matrix with image().
##' via https://www.r-bloggers.com/creating-an-image-of-a-matrix-in-r-using-image/
##' @param x matrix
##' @return x_prime rotated matrix
rotate <- function(x) t(apply(x, 2, rev))

##' Plot constraint matrix as colorful xy plot
##' useful for visualizing constraint matrices before and after changes
##' @param constraint constraint object, with constr, dir, and rhs elements.
##' return p ggplot object
plot_constraint_matrix <- function(constraint) {
    if (is.null(rownames(constraint$constr))) {
        message("Plotting redundant-free constraint without constraint names")
        rownames(constraint$constr) <- paste("c", 1:nrow(constraint$constr), sep = "_")
    }
    mat <- cbind(constraint$constr, constraint$rhs) %>% melt %>% as.data.frame
    mat$Var1 <- factor(mat$Var1, levels = rev(levels(mat$Var1)))
    p <- ggplot(mat, aes(x = Var2, y = Var1)) + geom_raster(aes(fill = value)) +
        scale_fill_gradientn(colors = brewer.pal(11, "PRGn")) + labs(x = "input variable per timestep",
        y = "constraint", title = "Matrix") + theme_classic() + theme(axis.text.x = element_text(size = 9,
        angle = 0, vjust = 0.3), axis.text.y = element_text(size = 9), plot.title = element_text(size = 11))
    return(p + remove_labels())
}

##' compose velocity constraint
##' require a given muscle's activation to change no more than some delta between two timepoints.
##' @param constraint constraint object as in ?hitandrun
##' @param max_allowable_increasing_tension_speed, max_allowable_decreasing_tension_speed value between min-max of muscle activation capability that defines maximal muscle activation change.
##' @return  velocity_constraint constraint object
compose_velocity_constraint <- function(constraint, max_allowable_increasing_tension_speed,
    max_allowable_decreasing_tension_speed) {
    indices_for_muscles <- muscle_and_lambda_indices(constraint, 7)$indices_for_muscles
    num_muscles <- get_num_muscles_via_indices_for_muscles(indices_for_muscles)
    velocity_constraint <- generate_and_add_velocity_constraint(constraint, max_allowable_increasing_tension_speed,
        max_allowable_decreasing_tension_speed, num_muscles)
    return(velocity_constraint)
}

########### DECOMPOSITION

##' useful for split_lhs_har_df_by_constraint
stop_if_tasks_not_wholenumber <- function(num_tasks) {
    if (num_tasks != floor(num_tasks)) {
        stop("The number of muscles does not match up with the number of tasks in the multiconstraint")
    }
}

##' derived from https://stackoverflow.com/questions/6819804/how-to-convert-a-matrix-to-a-list-of-column-vectors-in-r
matrix_to_list_of_cols <- function(x) split(x, rep(1:ncol(x), each = nrow(x)))

split_lhs_har_df_by_constraint <- function(har_df, multiconstraint, num_muscles) {
    # if left hand side then we can extract task num
    num_tasks <- ncol(multiconstraint$constr)/num_muscles
    stop_if_tasks_not_wholenumber(num_tasks)
    constraint_index_matrix <- matrix(1:(num_tasks * num_muscles), nrow = num_muscles)
    hardf_list <- lapply(constraint_index_matrix %>% matrix_to_list_of_cols, function(muscle_indices) {
        print(muscle_indices)
        solutions_subset <- har_df[, muscle_indices]
        return(solutions_subset)
    })
    return(hardf_list)
}

pair_har_solutions_df_with_constraint <- function(list_of_har_solution_dfs, list_of_constraints) {
    constraint_solution_pairs <- lapply(1:length(list_of_constraints), function(i) {
        return(list(constraint_object = list_of_constraints[[i]], har_solutions = list_of_har_solution_dfs[[i]]))
    })
    return(constraint_solution_pairs)
}

##' @param list_of_constraints the list of constraints, where the task was set (independent A matrix equality) but no velocity constraints were added.
##' @param trajectory_constraint constraint, which *must* be result of eliminate_redundant.
har_and_split_trajectory_constraint <- function(trajectory_constraint, list_of_constraints,
    num_muscles, har_samples, ...) {
    muscle_solutions <- trajectory_constraint %>% eliminate_redundant %>% pb_har_sample(har_samples, mc.cores=mc.cores, eliminate=FALSE)
    har_df_list <- split_lhs_har_df_by_constraint(muscle_solutions, trajectory_constraint, num_muscles)
    constraint_solution_pairs <- pair_har_solutions_df_with_constraint(har_df_list,
        list_of_constraints)
    expect_true(evaluate_constraint_solution_pairs(constraint_solution_pairs, ...) %>%
        dcc %>% all)
    return(constraint_solution_pairs)
}


# Inspired by https://github.com/notesofdabbler
# Almost directly from the code demo rvest::zillow in help(package=rvest)
library(rvest)

# FOR SALE
url <- "http://www.zillow.com/homes/for_sale/VT/58_rid/any_days/45.537137,-69.062805,42.187829,-75.846863_rect/7_zm/"#2_p/"

more.urls <- read_html(url) %>%
  html_nodes(".zsg-pagination a") %>%
  html_attr("href")

more.urls <- more.urls[!is.na(more.urls)]
more.urls <- strsplit(more.urls, '/')
more.urls <- lapply(more.urls, function(x) x[length(x)])
more.urls <- as.numeric(gsub('[_p]','', more.urls))
more.urls <- max(more.urls)
urls <- c(url, paste0(url,2:more.urls,'_p/'))

zdata2 <- getZillow(urls)
#save(zdata2, file='data/FS_2016April24.rda')
zdata3 <- parseZillow(zdata2)
zdata4 <- do.call(rbind.data.frame, zdata3)
for(i in c('lat', 'long','price','beds','baths','sqft', 'acres', 'yr_built')) zdata4[i] <- as.numeric(as.character(zdata4[,i]))

write.csv(zdata4, 'data/FS_2016May01.csv', row.names=FALSE)

# RECENTLY SOLD
url <- "http://www.zillow.com/homes/recently_sold/VT/58_rid/any_days/45.690832,-68.768921,42.200038,-75.552979_rect/7_zm/"

more.urls <- read_html(url) %>%
  html_nodes(".zsg-pagination a") %>%
  html_attr("href")

more.urls <- more.urls[!is.na(more.urls)]
more.urls <- strsplit(more.urls, '/')
more.urls <- lapply(more.urls, function(x) x[length(x)])
more.urls <- as.numeric(gsub('[_p]','', more.urls))
more.urls <- max(more.urls)
urls <- c(url, paste0(url,2:more.urls,'_p/'))

zdata2 <- getZillow(urls)
#save(zdata2, file='data/RS_2016April24.rda')
zdata3 <- parseSoldZillow(zdata2)
zdata4 <- do.call(rbind.data.frame, zdata3)
for(i in c('lat', 'long', 'price', 'pricepersqft', 'beds','baths','sqft', 'acres', 'yr_built')) zdata4[i] <- as.numeric(as.character(zdata4[,i]))

write.csv(zdata4, 'data/RS_2016May01.csv', row.names=FALSE)

# Spatial analysis
library(rgdal)
library(sp)
library(raster)
library(rgeos)
library(gstat)

vt <- rgdal::readOGR('/home/jon/Documents/AMElicitation/rasters/BoundaryState_VTBND', 'Boundary_VTBND_poly')

vt.twn <- rgdal::readOGR('/home/jon/Dropbox/AMharvest/shinyApps/AMHarvestSummary/data/spatial/Vermont/Boundary_TWNBNDS', 'Boundary_TWNBNDS_poly')

z.spat <- sp::SpatialPointsDataFrame(zdata4[,c('long', 'lat')], data=zdata4, proj4string=CRS("+init=epsg:4326"))

vt.wgs84 <- spTransform(vt, proj4string(z.spat))
plot(vt.wgs84)
plot(z.spat, add=TRUE, pch=19)

twn.w <- spTransform(vt.twn, proj4string(z.spat))
twn.sales <- over(z.spat, twn.w)
z.spat$TOWNNAME <- twn.w$TOWNNAME[twn.sales]

aggregate(z.spat$price, by=list(z.spat$TOWNNAME), FUN=median)

acres <- z.spat['acres']
ac <- acres@data[, 'acres']
ac[!is.na(ac) & ac > 1e3] <- NA#ac[!is.na(ac) & ac > 1e3]/43560
acres@data['acres'] <- ac

age <- aggregate(z.spat['yr_built'], by=twn.w['TOWNNAME'], mean, na.rm=TRUE)
age$yr_built <- 2016 - age$yr_built
count <- aggregate(z.spat['price'], by=twn.w['TOWNNAME'], length)
price <- aggregate(z.spat['price'], by=twn.w['TOWNNAME'], median, na.rm=TRUE)
acres <- aggregate(acres['acres'], by=twn.w['TOWNNAME'], mean, na.rm=TRUE)

z.spat$pricepersqft <- z.spat$price/z.spat$sqft
pricepersqft <- aggregate(z.spat['pricepersqft'], by=twn.w['TOWNNAME'], mean, na.rm=TRUE)
twn.sales <- over(z.spat, as(twn.w,'SpatialPolygons'), fn=mean)
over(twn.w, z.spat)

# distance from urban center
# by school district
# distnace from water
# elevation?
# valuation index: price/sqft + 50*baths + 25*beds + price/acre/10 - age
z.spat$jonval <- z.spat$price/z.spat$sqft + 50*z.spat$baths + 25*z.spat$beds + z.spat$price/z.spat$acres/1000 - (2016-z.spat$yr_built)
jonval <- aggregate(z.spat['jonval'], by=twn.w['TOWNNAME'], median, na.rm=TRUE)
ord <- order(jonval$jonval[!is.na(jonval$jonval)])
colorplot <- heat.colors(max(ord)+1)
plot(jonval[!is.na(jonval$jonval),], col=colorplot[ord])
plot(twn.w, add=TRUE)

choropleth <- function(sp, attrib, color.ramp=heat.colors, ...) {
    spa <- na.omit(sp[[attrib]])
    bins <- hist(spa, plot=FALSE, ...)$breaks
    bin <- rep(NA, length(spa))
    for(i in length(bins):1) bin[spa > 0 & spa <= bins[i]] <- i-1
    sp$bin <- NA
    sp[['bin']][!is.na(sp[[attrib]])] <- bin
    customcolor <- rev(color.ramp(length(bins)-1))
    customcolor[1] <- "#FFFFFF"
    plot(sp, col=customcolor[sp$bin])
    low.bin <- bins + 1
    low.bin[1] <- 0
    oldopts <- options(scipen=100000)
    on.exit(options(oldopts))
    invisible(paste(low.bin[1:(length(low.bin)-1)], '-', bins[2:length(bins)]))
}
#[sort(unique(na.omit(sp$bin)))]
x <- choropleth(age, 'yr_built', color.ramp=colorRampPalette(c('red', 'orange', 'yellow')), breaks=4)

plot(z.spat, add=TRUE, pch=19)

choropleth(acres, 'acres')
plot(z.spat, add=TRUE, pch=19)

x <- choropleth(price, 'price',  breaks=c(0, 0, seq(250000,500000, by=50000), 1500000))
fill <- rev(heat.colors(length(x)))
fill[1] <- 'white'
legend('bottomright', legend=x, fill=fill, bty='n')

fill.col <- colorRampPalette(c('red', 'orange', 'lightgray'))
x <- choropleth(price, 'price', color.ramp=fill.col, breaks=c(0, 0, seq(250000, 500000, by=75000), 1500000))
fill <- rev(fill.col(length(x)))
fill[1] <- 'white'
legend('bottomright', legend=x, fill=fill, bty='n')

plot(z.spat, add=TRUE, pch=19)

choropleth(count, 'price', breaks=4)
plot(z.spat, add=TRUE, pch=19)
legend('bottomright', legend=x, fill=rev(heat.colors(length(x))), bty='n')

getZillow <- function(urls) {
    lapply(urls, function(u) {
        cat(u, '\n')

        houses <- read_html(u) %>%
          html_nodes("article")

        houses
    })
}

parseZillow <- function(zhouse.l, quiet=TRUE, debugFun=function(...) NULL) {
    len.h <-1:length(zhouse.l)
    lapply(1:length(zhouse.l), function(x) {
        debugFun(x, '\n')
        houses <- zhouse.l[[x]]
        propdata <- tryCatch(houses %>% html_node(".property-data"), error=function(e) NULL)
        if(!is.null(propdata)) {
            parsePropData(houses, quiet)
        } else {
            parsePhotoCard(houses, quiet)
        }
    })
}

parseSoldZillow <- function(zhouse.l, quiet=TRUE, debugFun=function(...) NULL) {
    len.h <-1:length(zhouse.l)
    lapply(1:length(zhouse.l), function(x) {
        debugFun(x, '\n')
        houses <- zhouse.l[[x]]
        propdata <- tryCatch(houses %>% html_node(".property-data"), error=function(e) NULL)
        if(!is.null(propdata)) {
            parseSoldHome(houses, quiet)
        } #else {
#            parsePhotoCard(houses, quiet)
#        }
    })
}
# sold homes
parseSoldHome <- function(houses, quiet) {
    if(quiet) debugFun <- function(...){NULL}
    else debugFun <- cat

    z_id <- houses %>% html_attr("id")

    propinfo <- houses %>%
        html_node(".property-info")

    address <- propinfo %>%
      html_node(".property-address a") %>%
      html_attr("href") %>%
      strsplit("/") %>%
      pluck(3, character(1))

    geolab <- propinfo %>%
      html_nodes(".property-address meta") %>%
      html_attr("itemprop")

    geoloc <- propinfo %>%
      html_nodes(".property-address meta") %>%
      html_attr("content")

    geoloc <- as.numeric(geoloc)

    geo <- matrix(geoloc, ncol=2, byrow=TRUE)
    colnames(geo) <- c('lat', 'long')

    saleprice <- propinfo %>%
        html_node(".listing-type") %>%
        html_text()

    saleprice <- gsub('[^0-9]', '', saleprice)

    saledate <- propinfo %>%
        html_node(".sold-date") %>%
        html_text()

    saledate <- gsub('Sold on ', '', saledate)

    pricepersqft <- propinfo %>%
        html_nodes(".zsg-fineprint") %>%
        html_text()

    pricepersqft <- pricepersqft[seq(1, length(pricepersqft), by=2)]
    pricepersqft <- gsub('[^0-9]', '', pricepersqft)

    params <- houses %>%
      html_node(".property-data") %>%
      html_text() %>%
      strsplit(", ")

    params.l <- lapply(params, function(x) {
        if(length(x)) {
            x <- gsub('Studio', '0.5 bds', x)

            debugFun('    beds\n')
            beds <- grepl('bds', x)
            if(beds) {
                beds <- x %>%
                strsplit('bds')
                beds <- beds[[1]][1]
              }

            debugFun('    baths\n')
            baths <- grepl('ba', x)
            if(baths) {
                baths <- x %>%
                strsplit('ba')
                baths <- strsplit(baths[[1]], ' ')[[1]]
                baths <- baths[length(baths)]
            }

            debugFun('    house_area\n')
            house_area <- grepl('sqft [^a-z]+ ', x)
            if(house_area) {
                house_area <- x %>%
                strsplit('sqft [^a-z]+ ')
                house_area <- strsplit(house_area[[1]], ' ')[[1]]
                house_area <- house_area[length(house_area)]
            }

            debugFun('    lot_ac\n')
            lot_ac <- grepl('ac lot', x)
            if(lot_ac) {
                lot_ac <- x %>%
                strsplit('ac lot')
                lot_ac <- strsplit(lot_ac[[1]], ' ')[[1]]
                lot_ac <- lot_ac[length(lot_ac)]
            }

            lot_sqft <- grepl('sqft lot', x)
            if(lot_sqft) {
                lot_ac <- x %>%
                strsplit('sqft lot')
                lot_ac <- gsub('[^0-9.]', '', lot_ac) %>%
                as.numeric()
                lot_ac <- lot_ac/43560
            }

            debugFun('    year_built\n')
            year_built <- grepl('Built', x)
            if(year_built) {
                year_built <- x %>%
                strsplit('Built')
                year_built <- year_built[[1]][2]
            }

            out <- c(beds=beds, baths=baths, sqft=house_area, acres=lot_ac, yr_built=year_built)
            out.vals <- gsub('[^0-9.]', '', out)
            out.df <- data.frame(t(as.numeric(out.vals)))
            names(out.df) <- names(out)
            out.df
        } else data.frame(beds=NA, baths=NA, sqft=NA, acres=NA, yr_built=NA)
    })

    params.df <- do.call(rbind.data.frame, params.l)

    data.frame(z_id=z_id, address=address, geo, price=saleprice, saledate=saledate, pricepersqft=pricepersqft, params.df)
}

parsePropData <- function(houses, quiet) {
    if(quiet) debugFun <- function(...){NULL}
    else debugFun <- cat

    debugFun(x, '\n')
    z_id <- houses %>% html_attr("id")

    debugFun('    address\n')
    address <- houses %>%
      html_node(".property-address a") %>%
      html_attr("href") %>%
      strsplit("/") %>%
      pluck(3, character(1))

    debugFun('    geo\n')
    geo <- houses %>%
      html_nodes(".property-address meta") %>%
      html_attr("content")
    geo <- as.numeric(geo)
    geo <- data.frame(lat=geo[seq(1,length(geo), by=2)], long=geo[seq(2,length(geo), by=2)])

    debugFun('    price\n')
    price <- houses %>%
      html_node(".price-large") %>%
      html_text()

    price <- gsub('[^0-9]', '', price)

    params <- houses %>%
      html_node(".property-data") %>%
      html_text() %>%
      strsplit(", ")

    params.l <- lapply(params, function(x) {
        if(length(x)) {
            x <- gsub('Studio', '0.5 bds', x)

            debugFun('    beds\n')
            beds <- grepl('bds', x)
            if(beds) {
                beds <- x %>%
                strsplit('bds')
                beds <- beds[[1]][1]
              }

            debugFun('    baths\n')
            baths <- grepl('ba', x)
            if(baths) {
                baths <- x %>%
                strsplit('ba')
                baths <- strsplit(baths[[1]], ' ')[[1]]
                baths <- baths[length(baths)]
            }

            debugFun('    house_area\n')
            house_area <- grepl('sqft [^a-z]+ ', x)
            if(house_area) {
                house_area <- x %>%
                strsplit('sqft [^a-z]+ ')
                house_area <- strsplit(house_area[[1]], ' ')[[1]]
                house_area <- house_area[length(house_area)]
            }

            debugFun('    lot_ac\n')
            lot_ac <- grepl('ac lot', x)
            if(lot_ac) {
                lot_ac <- x %>%
                strsplit('ac lot')
                lot_ac <- strsplit(lot_ac[[1]], ' ')[[1]]
                lot_ac <- lot_ac[length(lot_ac)]
            }

            lot_sqft <- grepl('sqft lot', x)
            if(lot_sqft) {
                lot_ac <- x %>%
                strsplit('sqft lot')
                lot_ac <- gsub('[^0-9.]', '', lot_ac) %>%
                as.numeric()
                lot_ac <- lot_ac/43560
            }

            debugFun('    year_built\n')
            year_built <- grepl('Built', x)
            if(year_built) {
                year_built <- x %>%
                strsplit('Built')
                year_built <- year_built[[1]][2]
            }

            out <- c(beds=beds, baths=baths, sqft=house_area, acres=lot_ac, yr_built=year_built)
            out.vals <- gsub('[^0-9.]', '', out)
            out.df <- data.frame(t(as.numeric(out.vals)))
            names(out.df) <- names(out)
            out.df
        } else data.frame(beds=NA, baths=NA, sqft=NA, acres=NA, yr_built=NA)
    })

    params.df <- do.call(rbind.data.frame, params.l)

    data.frame(z_id=z_id, address=address, geo, price=price, params.df)
}

parsePhotoCard <- function(houses, quiet) {
    if(quiet) debugFun <- function(...){NULL}
    else debugFun <- cat

    z_id <- houses %>% html_attr("id")

    debugFun('    address\n')
    address <- houses %>%
      html_node(".zsg-photo-card-spec a") %>%
      html_attr("href") %>%
      strsplit("/") %>%
      pluck(3, character(1))

    debugFun('    geo\n')

    lat <- houses %>% html_attr("data-latitude")
    lon <- houses %>% html_attr("data-longitude")
#    geo <- houses %>%
#      html_nodes(".property-address meta") %>%
#      html_attr("content")

    geo <- data.frame(lat=as.numeric(lat)*10e-7, long=as.numeric(lon)*10e-7)

    debugFun('    price\n')
    price <- houses %>%
      html_nodes(".zsg-photo-card-status")%>%
      html_text()

    price <- price!='Auction'
    for(i in 1:length(price)) {
        if(price[i]) {
            price[i] <- houses[i] %>%
              html_nodes(".zsg-photo-card-spec") %>%
              html_nodes(".zsg-photo-card-price") %>%
              html_text()
        }
    }

    price <- gsub('[^0-9]', '', price)

    params <- houses %>%
      html_nodes(".zsg-photo-card-spec") %>%
      html_nodes(".zsg-photo-card-info") %>%
      html_text() %>%
      strsplit(", ")

    params.l <- lapply(params, function(x) {
        debugFun(x, '\n')
        if(length(x)) {
            x <- gsub('Studio', '0.5 bds', x)
            x <- gsub('--', 'NA', x)
            debugFun('    beds\n')
            beds <- grepl('bds', x)
            if(beds) {
                beds <- x %>%
                strsplit('bds')
                beds <- beds[[1]][1]
              }

            debugFun('    baths\n')
            baths <- grepl('ba', x)
            if(baths) {
                baths <- x %>%
                strsplit('ba')
                baths <- strsplit(baths[[1]], ' ')[[1]]
                baths <- baths[length(baths)]
            }

            debugFun('    house_area\n')
            house_area <- grepl('sqft', x)
            if(house_area && grepl('k sqft', x)) {
                house_area <- x %>%
                strsplit('k sqft')
                house_area <- strsplit(house_area[[1]], ' ')[[1]]
                house_area <- house_area[length(house_area)]
                house_area <- gsub('[^0-9]', '', house_area)
                house_area <- as.numeric(house_area) * 100
            } else {
                house_area <- x %>%
                strsplit('sqft')
                house_area <- strsplit(house_area[[1]], ' ')[[1]]
                house_area <- house_area[length(house_area)]
            }

            debugFun('    lot_ac\n')
            lot_ac <- grepl('ac lot', x)
            if(lot_ac) {
                lot_ac <- x %>%
                strsplit('ac lot')
                lot_ac <- strsplit(lot_ac[[1]], ' ')[[1]]
                lot_ac <- lot_ac[length(lot_ac)]
            }

            lot_sqft <- grepl('sqft lot', x)
            if(lot_sqft) {
                lot_ac <- x %>%
                strsplit('sqft lot')
                lot_ac <- gsub('[^0-9.]', '', lot_ac) %>%
                as.numeric()
                lot_ac <- lot_ac/43560
            }

            debugFun('    year_built\n')
            year_built <- grepl('Built', x)
            if(year_built) {
                year_built <- x %>%
                strsplit('Built')
                year_built <- year_built[[1]][2]
            }

            out <- c(beds=beds, baths=baths, sqft=house_area, acres=lot_ac, yr_built=year_built)
            out.vals <- gsub('[^0-9.]', '', out)
            out.df <- data.frame(t(as.numeric(out.vals)))
            names(out.df) <- names(out)
            out.df
        } else data.frame(beds=NA, baths=NA, sqft=NA, acres=NA, yr_built=NA)
    })

    params.df <- do.call(rbind.data.frame, params.l)

    data.frame(z_id=z_id, address=address, geo, price=price, params.df)
}

##beds <- params %>%
##  pluck(1, character(1)) #%>%
###  extract_numeric()
##
##baths <- params %>%
##  pluck(2, character(1)) #%>%
###  extract_numeric()
##
##house_area <- params %>%
##  pluck(3, character(1)) %>%
##  area()


#!/usr/bin/env Rscript
#
# Use multiple regression to get strain frequencies.
#
# strain_frequency_multregress.r <pool freqs> <base calls>
#
# Note that the base calls file should have a 1 for reference and 0 for
# alternate allele call, which is the opposite of a VCF file.
#
#==============================================================================#

suppressMessages(library(data.table))

#==============================================================================#

get_ss = function(par, calls, freqs) {
    ## cfs = coefficients (estimated strain frequencies)
    ## calls = matrix: columns are strains, rows are sites; 1 or 0
    ## freqs = vector of pool allele frequencies (one element per site)
    ## Value: sum of squares
    prd = (calls %*% par)[, 1]
    ss = sum((prd - freqs)^2)
    ss
}

get_sse = function(par, calls, freqs) {
        ## cfs = coefficients (estimated strain frequencies)
        ## calls = matrix: columns are strains, rows are sites; 1 or 0
        ## freqs = vector of pool allele frequencies (one element per site)
        ## Value: sum of squares
        prd = (calls %*% par)[, 1]
    ss = sum((prd - freqs)^2)
        ss
}

get_fitted = function(par, calls) {
        (calls %*% par)[, 1]
}

get_sst = function(freqs) {
        sum((mean(freqs) - freqs)^2)
}

get_r2 = function(par, calls, freqs) {
        ## par = $par slot from optimization - the coefficients
        ## calls = a matrix of allele calls (columns = strains)
        ## freqs = the pool allele frequencies
        sse = get_sse(par, calls, freqs)
    sst = get_sst(freqs)
        n = nrow(calls)
        m = length(par)
            v = n - m
            1 - ( (sse * (n - 1)) / (sst * v) )
}

#==============================================================================#

cargs = commandArgs(trailingOnly=TRUE)

pool_freqs_file = cargs[1]
base_calls_file = cargs[2]

sink(stderr())
pool_freqs = suppressMessages(fread(pool_freqs_file, sep='\t',
                                    header=TRUE, verbose=FALSE))
base_calls = suppressMessages(fread(base_calls_file, sep='\t',
                                    header=TRUE, verbose=FALSE))
sink()
names(base_calls)[-(1:2)] = paste0('S', names(base_calls)[-(1:2)])
strains = names(base_calls)[-(1:2)]

base_calls = base_calls[order(base_calls[['contig']], base_calls[['pos']]), ]
pool_freqs = pool_freqs[order(pool_freqs[['contig']], pool_freqs[['pos']]), ]
pool_key = paste0(pool_freqs[['contig']], '-', pool_freqs[['pos']])
bc_key = paste0(base_calls[['contig']], '-', base_calls[['pos']])
base_calls = base_calls[bc_key %in% pool_key, ]
pool_freqs = pool_freqs[pool_key %in% bc_key, ]

if(!all(pool_freqs[['contig']] == base_calls[['contig']]))
    stop('Files are not in the same order')
if(!all(pool_freqs[['pos']] == base_calls[['pos']]))
    stop('Files are not in the same order')

ref_freqs = pool_freqs[['ref_freq']]
ref_freqs[pool_freqs[['n_alleles']] == 0] = NaN

# Reference allele frequency as response, strain base calls as
# predictors, no intercept.
model_formula = paste('ref_freqs ~ (-1) + ',
                      paste(strains, collapse=' + '))

# Linear regression:
cat('Running linear regression\n', file=stderr())
model_results = lm(as.formula(model_formula), data=base_calls,
                   weights=pool_freqs[['n_reads']], na.action=na.exclude)
sm = summary(model_results)
output_table = sapply(strains, function(x) sm$coefficients[x, 1:2])
output_table = data.frame(stat = paste('LM', rownames(output_table), sep='-'),
                          output_table,
                          R2 = c(sm$adj.r.squared, ''))
write.table(output_table, file=stdout(), col.names=TRUE,
            row.names=FALSE, quote=FALSE, sep='\t')

# Optimization method with coefficients constrained between 0 and
# 1
cat('Running constrained optimization\n', file=stderr())
bc = as.matrix(base_calls)[, -(1:2)]
storage.mode(bc) = 'numeric'
nmiss = rowSums(is.na(bc))
bc = bc[nmiss == 0 & !is.na(ref_freqs), ]
rf = ref_freqs[nmiss == 0 & !is.na(ref_freqs)]
o = optim(par=rep(1/ncol(bc), ncol(bc)), get_sse, calls=bc,
          freqs=rf, lower=0, upper=1, method='L-BFGS-B')
r2 = get_r2(o$par, bc, rf)
cat('Constrained-Estimate\t', paste(o$par, collapse='\t'), '\t',
    r2, '\n', sep='', file=stdout())


#source("http://www.bioconductor.org/biocLite.R")
#biocLite("Biobase")
#biocLite("affy")
library("affy")
setwd("~/work/abe516/r/affy/data/")

harvard.rawData = ReadAffy()
geneNames(harvard.rawData)[1:10]
pm(harvard.rawData, "100_g_at")
mm(harvard.rawData, "100_g_at")
hist(harvard.rawData, main = "Harvard data")
boxplot(harvard.rawData, col=c(2,2,2,3,3,3))
plot(probeset(harvard.rawData, geneNames(harvard.rawData)[1]) [[1]])
RNAdeg<-AffyRNAdeg(harvard.rawData)
plotAffyRNAdeg(RNAdeg)

# biocLite("simpleaffy")
library(simpleaffy)
h.qc=qc(harvard.rawData)
avbg(h.qc)
percent.present(h.qc)

MAplot(harvard.rawData, plot.method="smoothScatter", pair=TRUE)
par(mfrow=c(2,3))
MAplot(harvard.rawData, plot.method="smoothScatter")

harvard.exprData <- expresso(harvard.rawData,
                             bgcorrect.method = "rma",
                             normalize.method = "constant",
                             pmcorrect.method = "pmonly",
                             summary.method = "avgdiff")


#' Plot annual MSY
#'
#' Plot values associated with MSY using year-specific inputs.
#' @param asap name of the variable that read in the asap.rdat file
#' @param a1 list file produced by grab.aux.files function
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotAnnualMSY <- function(asap,a1,save.plots,od,plotf){

  h.vals <- asap$SR.annual.parms$steepness.vec
  recr.par <- h.vals

  if (asap$control.parms$phases$phase.steepness>0 & max(h.vals)<1 ) { # test to make sure steepness was estimated

    nages<- asap$parms$nages
    nyears <- asap$parms$nyears
    years <- seq(asap$parms$styr,asap$parms$endyr)
    if (asap$options$isfecund == 1){
      fec.age <- asap$WAA.mats$WAA.ssb / asap$WAA.mats$WAA.ssb # matrix of 1s
    }else{
      fec.age <- asap$WAA.mats$WAA.ssb
    }
    mat.age <- asap$maturity
    wgt.age <- asap$WAA.mats$WAA.catch.all
    M.age <- asap$M.age
    sel.mat <- asap$F.age/apply(asap$F.age,1,max)

    spawn.time <- asap$options$frac.yr.spawn

    ahat.vals <- 4*h.vals/(1-h.vals)
    R0.vals <- asap$SR.annual.parms$R0.vec
    sr0.vals <- asap$SR.annual.parms$s.per.r.vec
    MSY.soln <- matrix(NA, nrow=9, ncol=nyears)
    rownames(MSY.soln) <- c("Fmsy", "MSY", "SPRmsy", "SSBmsy", "Rmsy", "YPRmsy",
                            "Rel.SSBmsy", "Rel.Rmsy", "Conv.Code")
    colnames(MSY.soln) <-  seq(asap$parms$styr, asap$parms$endyr)

    for (i in 1:nyears) {
      F.start=0.25
      get.yield.f.min <- function(F.start) {
        temp.spr = s.per.recr(nages=nages, fec.age=fec.age[i,], mat.age=mat.age[i,], M.age= M.age[i,], F.mult=F.start, sel.age=sel.mat[i,], spawn.time=spawn.time)
        temp.ypr = ypr(nages=nages, wgt.age=wgt.age[i,], M.age=M.age[i,],  F.mult=F.start, sel.age=sel.mat[i,] )
        temp.SSB = ssb.eq( recr.par=ahat.vals[i], R0.BH=R0.vals[i], spr=temp.spr, spr0=sr0.vals[i], is.steepness=F )
        yield = temp.ypr*temp.SSB/temp.spr           #harvest in weight
        yy=-1*yield
        return(yy)
      }   # end get.yield.f.min function

      F.nlmin <- nlminb( start=F.start , objective=get.yield.f.min, lower=0.01, upper=3.0,
                         control=list(eval.max=500, iter.max=200  )   )

      MSY.soln[1, i] <- F.nlmin$par  #Fmsy
      MSY.soln[2, i] <- -1*F.nlmin$objective #MSY

      # calculate other MSY quantities
      spr.nlmin <- s.per.recr(nages=nages, fec.age=fec.age[i,], mat.age=mat.age[i,], M.age= M.age[i,], F.mult=F.nlmin$par, sel.age=sel.mat[i,], spawn.time=spawn.time)
      MSY.soln[3, i] <- spr.nlmin/sr0.vals[i] #SPRmsy

      ssb.nlmin <- ssb.eq( recr.par=ahat.vals[i], R0.BH=R0.vals[i], spr=spr.nlmin, spr0=sr0.vals[i], is.steepness=F )
      MSY.soln[4, i] <-  ssb.nlmin #SSBmsy

      Rmsy.nlmin <- bev.holt.alpha(S=ssb.nlmin,R0=R0.vals[i],recr.par=ahat.vals[i],spr0=sr0.vals[i])
      MSY.soln[5,i ] <- Rmsy.nlmin #Rmsy

      ypr.nlmin <- ypr(nages=nages, wgt.age=wgt.age[i,], M.age=M.age[i,],  F.mult=F.nlmin$par, sel.age=sel.mat[i,] )
      MSY.soln[6,i ] <- ypr.nlmin #YPRmsy

      rel.ssb.nlmin <- ssb.nlmin/(R0.vals[i]*sr0.vals[i])
      MSY.soln[7, i] <-  rel.ssb.nlmin #SSBmsy/SSB0

      MSY.soln[8, i] <- Rmsy.nlmin/R0.vals[i] #Rmsy/R0

      MSY.soln[9, i] <-  F.nlmin$convergence  #code=0 indicates convergence
    }  # end i-loop over nyears

    f.hist <- hist(MSY.soln[1,], plot=F)
    MSY.hist <- hist(MSY.soln[2,], plot=F)
    R.hist <- hist(MSY.soln[5,], plot=F )
    S.hist <- hist(MSY.soln[4,], plot=F )

    h.hist <- hist(h.vals, plot=F)
    SPR.hist <- hist(MSY.soln[3,], plot=F)
    R0.hist <- hist(R0.vals, plot=F )
    S0.hist <- hist(asap$SR.annual.parms$S0.vec, plot=F )

    par(mfrow=c(2,2), mar=c(4,4,2,2), oma=c(0,0,2,0) )

    plot(f.hist$mids, f.hist$counts, xlab="Full F", ylab="Frequency", type='h', lwd=2, ylim=c(0, max(f.hist$counts))  )
    lines(f.hist$mids, f.hist$counts, lwd=2)
    plot(S.hist$mids, S.hist$counts, xlab="SSB.MSY", ylab="Frequency", type='h', lwd=2, ylim=c(0, max(S.hist$counts))  )
    lines(S.hist$mids, S.hist$counts, lwd=2)
    plot(MSY.hist$mids, MSY.hist$counts, xlab="MSY", ylab="Frequency", type='h', lwd=2, ylim=c(0, max(MSY.hist$counts)) )
    lines(MSY.hist$mids, MSY.hist$counts, lwd=2)
    plot(R.hist$mids, R.hist$counts, xlab="R.MSY", ylab="Frequency", type='h', lwd=2, ylim=c(0, max(R.hist$counts))  )
    lines(R.hist$mids, R.hist$counts, lwd=2)
    title (paste0("Annual MSY Reference Points (from S-R curve)"), outer=T, line=-1 )
    if (save.plots) savePlot(paste0(od, "MSY.4panel.hist1.", plotf), type=plotf)

    plot(h.hist$mids, h.hist$counts, xlab="steepness", ylab="Frequency", type='h', lwd=2, ylim=c(0, max(h.hist$counts))  )
    lines(h.hist$mids, h.hist$counts, lwd=2)
    plot(S0.hist$mids, S0.hist$counts, xlab="SSB0", ylab="Frequency", type='h', lwd=2, ylim=c(0, max(S0.hist$counts))  )
    lines(S0.hist$mids, S0.hist$counts, lwd=2)
    plot(SPR.hist$mids, SPR.hist$counts, xlab="SPR.MSY", ylab="Frequency", type='h', lwd=2, ylim=c(0, max(SPR.hist$counts)) )
    lines(SPR.hist$mids, SPR.hist$counts, lwd=2)
    plot(R0.hist$mids, R0.hist$counts, xlab="R0", ylab="Frequency", type='h', lwd=2, ylim=c(0, max(R0.hist$counts))  )
    lines(R0.hist$mids, R0.hist$counts, lwd=2)
    title (paste0("Annual MSY Reference Points (from S-R curve)"), outer=T, line=-1 )
    if (save.plots) savePlot(paste0(od, "MSY.4panel.hist2.", plotf), type=plotf)

    par(mfrow=c(1,1), mar=c(4,4,2,2) )

    h.order <- order(h.vals)
    steep.spr <- cbind(h.vals[h.order], MSY.soln[3,h.order])

    plot(steep.spr[,1], steep.spr[,2], xlab="Steepness", ylab="SPR.MSY", xlim=c(0.2,1), ylim=c(0,1),
         type='p', pch=16, col='blue3' )
    points(h.vals[1], MSY.soln[3,1], pch=16, cex=1.5, col="green3")
    points(h.vals[nyears], MSY.soln[3,nyears], pch=16, cex=1.5, col="orange2")
    legend('top', legend=c("First Year", "Last Year"), pch=c(16,16), col=c("green3", "orange2") )
    title (paste0("Annual Steepness and SPR.MSY (from S-R curve)"), outer=T, line=-1 )

    if (save.plots) savePlot(paste0(od, "MSY.h.vs.SPR.", plotf), type=plotf)

    plot(years, MSY.soln[1,], xlab="Year", ylab="Full F at MSY", ylim=1.1*c(0, max(MSY.soln[1,])), type='l', lwd=2  )
    points(years, MSY.soln[1,], pch=10)
    title (paste0("Annual MSY Reference Points (from S-R curve)"), outer=T, line=-1 )

    if (save.plots) savePlot(paste0(od, "Annual.Fmsy.", plotf), type=plotf)

    plot(years, MSY.soln[2,], xlab="Year", ylab="MSY", ylim=1.1*c(0, max(MSY.soln[2,])), type='l', lwd=2  )
    points(years, MSY.soln[2,], pch=10)
    title (paste0("Annual MSY Reference Points (from S-R curve)"), outer=T, line=-1 )

    if (save.plots) savePlot(paste0(od, "Annual.MSY.", plotf), type=plotf)

    plot(years, MSY.soln[3,], xlab="Year", ylab="%SPR at MSY", ylim=1.1*c(0, 1), type='l', lwd=2  )
    points(years, MSY.soln[3,], pch=10)
    title (paste0("Annual MSY Reference Points (from S-R curve)"), outer=T, line=-1 )

    if (save.plots) savePlot(paste0(od, "Annual.SPR.MSY.", plotf), type=plotf)

    plot(years, MSY.soln[4,], xlab="Year", ylab="SSB at MSY", ylim=1.1*c(0, max(MSY.soln[4,])), type='l', lwd=2  )
    points(years, MSY.soln[4,], pch=10)
    title (paste0("Annual MSY Reference Points (from S-R curve)"), outer=T, line=-1 )

    if (save.plots) savePlot(paste0(od, "Annual.SSB.MSY.", plotf), type=plotf)

    plot(years, MSY.soln[5,], xlab="Year", ylab="Recruitment at MSY", ylim=1.1*c(0, max(MSY.soln[5,])), type='l', lwd=2  )
    points(years, MSY.soln[5,], pch=10)
    title (paste0("Annual MSY Reference Points (from S-R curve)"),
           outer=T, line=-1 )

    if (save.plots) savePlot(paste0(od, "Annual.Recr.MSY.", plotf), type=plotf)

    frep1 <-asap$options$Freport.agemin
    frep2 <-asap$options$Freport.agemax
    if (frep1==frep2) freport <-MSY.soln[1,frep1:frep2]*sel.mat[,frep1:frep2]
    if (frep2>frep1) freport <-apply(MSY.soln[1,frep1:frep2]*sel.mat[,frep1:frep2],1,mean)
    freport.label <- paste0("Freport_",frep1,"-",frep2)
    MSY.soln<-  rbind(MSY.soln, freport)
    rownames(MSY.soln) <-
      c("Fmsy", "MSY", "SPRmsy", "SSBmsy", "Rmsy", "YPRmsy",
        "Rel.SSBmsy", "Rel.Rmsy", "Conv.Code",paste0("Freport_",frep1,"-",frep2))

    asap.name <- a1$asap.name
    write.csv( t(MSY.soln), file=paste0(od, "MSY.soln.values_", asap.name, ".csv"), row.names=T )

  } # end test for steepness phase>0

  return()
}  # end function


##############
#server.r
#############

source("londongrapher.r")

shinyServer(function(input, output, session){

  output$map1 <- renderLeaflet({
    leaflet(wardBoundaries) %>% addProviderTiles("CartoDB.DarkMatter") %>%
      setView(-0.0881798, 51.48932, zoom = 10)
  })

  #observer for the map elements to redraw
  observe({
    breaks<-classIntervals(wardBoundaries@data[[input$variable]], n=5, style=input$classIntStyle)
    breaks <- breaks$brks

    pal <- colorBin(palette = input$colourbrewerpalette,
                    domain = wardBoundaries@data[[input$variable]],
                    #create bins using the breaks object from earlier
                    bins = breaks
    )

    leafletProxy("map1", data = wardBoundaries) %>%
      clearShapes() %>%
      addPolygons(stroke = F,
                fillOpacity = 0.5,
                smoothFactor = 0.5,
                color = ~pal(wardBoundaries@data[[input$variable]]),
                #popup = ~WD11NM
                popup = paste(wardBoundaries@data$WD11NM,
                              "... ",wardBoundaries@data[[input$variable]])
                )
  })

  #observer for the legend to redraw
  observe({
    breaks<-classIntervals(wardBoundaries@data[[input$variable]], n=5, style=input$classIntStyle)
    breaks <- breaks$brks

    pal <- colorBin(palette = input$colourbrewerpalette,
                    domain = wardBoundaries@data[[input$variable]],
                    #create bins using the breaks object from earlier
                    bins = breaks
    )

    proxy <- leafletProxy("map1", data = wardBoundaries)
    proxy %>% clearControls() %>%
    addLegend("bottomright",
              pal= pal,
              values = ~wardBoundaries@data[[input$variable]],
              title = input$variable,
              labFormat = labelFormat(prefix = ""),
              opacity = 1
    )
  })

  # output$plot1 <- renderPlotly({
  #   londongrapher(variable = input$variable,
  #                 colourbrewerpalette = input$colourbrewerpalette
  #   )
  # })

  output$plot1 <- renderPlot({
    londongrapher(variable = input$variable,
                  colourbrewerpalette = input$colourbrewerpalette,
                  classIntStyle = input$classIntStyle)
  })

})


# Databricks notebook source
# Push mtcars dataset to Spark
sc <- sparklyr::spark_connect(method = "databricks")

mtcars_sdf <- sparklyr::sdf_copy_to(sc, mtcars, overwrite = T)

# Output schema
schema <- list(cyl = "double",
               term = "string",
               estimate = "double",
               std_error = "double",
               statistic = "double",
               p_value = "double")

## Add a new column for each group and return the results
results_sdf <- sparklyr::spark_apply(mtcars_sdf,
                                  group_by = "cyl",
                                  function(e){
                                    # 'e' is a data.frame containing all the rows for each distinct UniqueCarrier
                                    tidymod <- broom::tidy(lm(mpg ~ ., data = e[, -2]))
                                    tidymod
                                  },
                                   # Specify schema
                                   columns = schema,
                                   # Do not copy packages to each worker
                                   packages = F)
head(results_sdf, 10)

# COMMAND ----------

summary(mtcars)

# COMMAND ----------

mtcars$adjustedwt = mtcars$wt * 10

# COMMAND ----------

str(mtcars)

# COMMAND ----------


indata <- fst::read.fst("indata//normal.fst",as.data.table = T)

# Your Data naturally follows some distribution
indata[order(risk_grade),.N,risk_grade][,.(risk_grade, dn = N/sum(N))]
indata[,lvr_bin := cut(curr_lvr, c(0,0.8, 1))]
indata[order(lvr_bin),.N,lvr_bin][,.(lvr_bin, dn = N/sum(N))]
indata[order(state),.N,state][,.(state, dn = N/sum(N))]

# For risk appettite setting, you may be asked how a portfolio with a particular distribution
# might perform

# e.g. VIC population grows so both NSW and VIC has 36% of portflio
# and risk_grade 10+ collectively has 5% of distribution
# and 30% of loans have LVR greater than 80%

# use dog breeder algorithms
# generate separate datasets that satisfies one of the criteria above
# append them together, now the new data has characteristics of all 3
# sample from this new dataset + a random sample from the original by repeating steps above

indata[, vic_nsw_other:= ifelse(state %in% c("NSW","VIC"), state, "Other")]
indata[, risk_grade10 := ifelse(risk_grade >= 10, "rg >= 10", "rg < 10")]

vicnsw_target <- data.table(vic_nsw_other = c("NSW","VIC","Other"), target = c(0.36, 0.36, 0.28))
risk_grade10_target <- data.table(risk_grade10 = c("rg >= 10", "rg < 10"), target = c(0.05,0.95))
lvr_bin_target <- data.table(lvr_bin = c("(0,0.8]", "(0.8,1]"), target = c(0.7,0.3))

sample_to_target <- function(indata, target) {
  lapply(1:nrow(target), function(i) {
    # browser()
    indata1 <- merge(indata, target[i,], all.y = T)
    ii = sample(nrow(indata1), target[i,target]*nrow(indata)/3, replace = T)
    indata1[ii,]
  }) %>% rbindlist(use.names = T)
}

benchmark_to_target <- function(target, indata) {
  x = sapply(1:nrow(target), function(i) {
    # browser()
    indata1 <- merge(indata, target[i,], all.y = T)
    nrow(indata1)/nrow(indata) - target[i,target]
  })
  sum(x^2)
}

sample_from_data <- indata
res <- 1
iter <- 0
last_res <- 2
while(last_res - res >= 0.00001 & iter < 100) {
  last_res <- res
  vs <- sample_to_target(sample_from_data, vicnsw_target)[,target := NULL]
  # vs[,.N, vic_nsw_other]
  rg <- sample_to_target(sample_from_data, risk_grade10_target)[,target := NULL]
  # rg[,.N, risk_grade10]s
  lvrbin <- sample_to_target(sample_from_data, lvr_bin_target)[,target := NULL]
  # lvrbin[,.N, lvr_bin]

  sample_from_data <- rbindlist(list(vs, rg, lvrbin),use.names = T,fill = T)
  res = sum(sapply(
    list(vicnsw_target, risk_grade10_target, lvr_bin_target),
    benchmark_to_target, sample_from_data))
  print(res)
  # if (last_res - res >= 0.00001 & iter < 100) {
  #   rindata <- indata[sample(nrow(indata), nrow(indata)/3),]
  #   sample_from_data <- list(sample_from_data, rindata) %>% rbindlist(use.names = T)
  #   sample_from_data <- sample_from_data[sample(nrow(sample_from_data),nrow(indata))]
  #   # print(nrow(sample_from_data))
  # }

  iter = iter + 1
}
# sample_from_data
indata[,.N, vic_nsw_other][,.(vic_nsw_other, dn = N/sum(N))]
sample_from_data[,.N, vic_nsw_other][,.(vic_nsw_other, dn = N/sum(N))]

indata[,.N, risk_grade10][,.(risk_grade10, dn = N/sum(N))]
sample_from_data[,.N, risk_grade10][,.(risk_grade10, dn = N/sum(N))]

indata[,.N, lvr_bin][,.(lvr_bin, dn = N/sum(N))]
sample_from_data[,.N, lvr_bin][,.(lvr_bin, dn = N/sum(N))]

sample_from_data[,dplyr::n_distinct(account_id)]

fst::write.fst(sample_from_data, "indata/synthetic.fst", 100)


library(readr)
library(xgboost)
library(e1071)

set.seed(1)

cat("reading the train and test data\n")
#train <- read_csv("../../data/train.csv-1")
#test  <- read_csv("../../data/test.csv-1")
train <- read_csv("../../data/train.csv")
test  <- read_csv("../../data/test.csv")

#Train ID - Features - Target
#Test ID - Features

#Drop Features with All NA
lstDrp = c()
j = 1
for (i in 2:ncol(test) )
{
  if (sum(is.na(train[, i])) == nrow(train))
  {
    lstDrp[j] = i
    j = j + 1
    #train[, i] = NULL
    cat("NA Dropped: ", i, "\n")
  }
}

train[lstDrp] = list(NULL)
test[lstDrp] = list(NULL)
#cat("Dropped lst: ", lstDrp, "\n")
cat("New Din Train: ", dim(train), "\n")
cat("New Dim Test: ", dim(test), "\n")

feature.names <- names(train)[2:ncol(train)-1]

cat("assuming text variables are categorical & replacing them with numeric ids\n")
for (f in feature.names) {
  if (class(train[[f]])=="character") {
    levels <- unique(c(train[[f]], test[[f]]))
    train[[f]] <- as.integer(factor(train[[f]], levels=levels))
    test[[f]]  <- as.integer(factor(test[[f]],  levels=levels))
  }
}

#cat("replacing missing values with -1\n")
#train[is.na(train)] <- -1
#test[is.na(test)]   <- -1

cat("replace missing values with mean \n")

#Impute Numerical Variables with Mean and Categorical with Mode
for (i in 2:ncol(test))
{
  #if(class(train[, i]) == "character")
  #{
  #	mode(train[, i])
  #}

  fMean = mean(train[!is.na(train[, i]), i])
  #cat("mean", i, ":", fMean, "\n")
  train[is.na(train[, i]), i] = fMean
  test[is.na(test[, i]), i] = fMean

  if(is.na(train[,i]) == TRUE)
  {
    cat("NA", i, " ", feature.names[i], "\n")
  }

}

lstDrp = c()
j = 1
for (i in 2:ncol(test))
{
  if (sum(as.double(train[, i])) == 0)
  {
    lstDrp[j] = i
    j = j + 1
    #train[, i] = NULL
    cat("Zero Dropped: ", i, "\n")
  }
}

train[lstDrp] = list(NULL)
test[lstDrp] = list(NULL)
#cat("Dropped lst: ", lstDrp, "\n")
cat("New Din Train: ", dim(train), "\n")
cat("New Dim Test: ", dim(test), "\n")

#Write Data to file
write.csv(cbind(train$target, train[, 3:ncol(train)-1]), file = 'Preprocess_Train.csv', row.names=FALSE)
write.csv(test[, 2:ncol(test)], file = 'Preprocess_Test.csv', row.names=FALSE)

#return(train)
#if (sum(!is.na(train)) ) { cat("NAN ", sum(!is.na(train)), "\n")}

cat(dim(train), "\n", dim(test), "\n")