# Fitting Models by OLS
#'
#'
#' @importFrom estimatr lm_robust
#' @importFrom stats formula
#' @importFrom rlang f_lhs
#'
#'
rct_lm <- function(baseline = NULL,
                   covariate = NULL,
                   data = NULL,
                   treat_levels = NULL,
                   treat_labels = NULL,
                   ctrl = NULL,
                   subset = NULL,
                   weights = NULL,
                   cluster = NULL,
                   only_dmod = TRUE,
                   ...) {
  # check models
  if (is.null(baseline)) abort_empty("basline")
  if (only_dmod) covariate <- append(list(NULL), covariate)
  model.list <- expand.grid(covariate = covariate, baseline = baseline)
  model.list <- model.list[!duplicated(model.list), ]

  # order of treatment
  order_d <- reorder_arms(treat_levels, treat_labels, ctrl)

  # estimation
  res <- lapply(seq_len(nrow(model.list)), function(i) {
    # model
    baseline <- model.list$baseline[i][[1]]
    covariate <- model.list$covariate[i][[1]]

    # cleaning data
    use <- clean_RCTdata(
      baseline,
      covariate,
      data,
      order_d$levels,
      order_d$labels,
      enexpr(subset),
      enexpr(weights),
      enexpr(cluster)
    )

    # estimation
    assign(all.vars(f_lhs(baseline)), use$outcome)
    x <- use$design

    estimatr::lm_robust(
      formula(paste(all.vars(f_lhs(baseline)), "~ -1 + x")),
      weights = use$weights,
      clusters = use$clusters,
      ...
    )
  })

  # output
  res
}


#' @title Correlation ptds and fluids fasting
#' @return
#' @author Aaron Conway
#' @export
#' @importFrom correlation correlation
#' @importFrom dplyr mutate select

create_fluids_corr <- function(data_ptds) {
  data_ptds %>%
    select(ptds, fluids_duration) %>%
    correlation(method = "spearman")
}


data = read.delim("sizes.csv")

plotGraph = function(tag, title='', showY=T) {
  n = max(data[data$tag == tag, ]$i)
  i = 1:n
  n2 = n/2

  if (showY) {
    yaxt = 's'
  } else {
    yaxt = 'n'
  }

  plot(actual~q, data[data$tag == tag,], cex=0.2, xaxt='n', xlim=c(0,1), ylim=c(0,1050), xlab='Quantile',
       ylab='Centroid size', yaxt=yaxt, pch=21, col=rgb(0,0,0,0.2), bg=rgb(0,0,0,0.2))
  title(title)
  box()
  axis(side=1, at=c(0,0.25, 0.5, 0.75, 1), labels=c(0.0,0.25,0.5,0.75, 1.0))

  q = seq(0,1,by=0.01)
  lines(q, 1000*4*q*(1-q), col='gray')
}

pdf("sizes.pdf", width=6, height=2.0, pointsize=9)
layout(matrix(c(1,2,3), 1, 3, byrow=T), widths=c(1.21,1,1))
eldest = par(lwd=0.2)
old = par(mar=c(4.1, 4.1, 2.1, 2))
plotGraph("uniform", title=expression("Uniform Distribution"), T)
par(old)
old = par(mar=c(4.1,0,2.1,2))
plotGraph("gamma", title=expression(paste(Gamma(0.1, 0.1), " Distribution")), F)
plotGraph("sequential", title=expression("Sequential Distribution"), F)
par(old)
par(eldest)
  dev.off()
#plotGraph("mixture", title="Mixture Distribution")


#ifelse is a vectorised version of the if/else flow controllers, similar to the C-style ternary operator.
 x <- sample(1:10, 10)
 ifelse(x > 5, x^2, 0)


#create a line plot for vectors x and y with 5 diff. vals.
#on same data construct scatterplot, barplot, bubblechart,
library(ggplot2)
library(plotly)
x=c(1,2,3,4,5)
y=c(12,44,11,26,16)
plot_ly(x = ~x, y = ~y,mode="line")

plot_ly(x = ~x, y = ~y,type="bar")

plot_ly(mtcars$mpg~mtcars$cyl,type="box")

plot_ly(iris,x = iris$Sepal.Length, y = iris$Petal.Length, type = "scatter",mode="markers", marker = list(size = ~y, opacity = 0.5))

mat = matrix(x,y,5,5)

hv = heatmap(mat,y)

boxplot(mtcars$mpg~mtcars$cyl)


# purpose: merge and vis the NAM F1 pheno
# Jinliang Yang
# 1.21.2012
# how to generate the . problem?

setwd("~/Documents/Heterosis_GWAS/pheno2011");
krn <- read.csv("nam_F1_KRN.csv");
kernel <- read.csv("nam_F1_Kernel.csv")
cob <- read.csv("nam_F1_cob.csv")

trait <- merge(krn, cob, by="Genotype", all=TRUE);
trait <- merge(trait, kernel, by="Genotype", all=TRUE)

geno <- trait[duplicated(trait$Genotype),]$Genotype
length(geno)
trait[trait$Genotype%in%geno,]

trait <- trait[!duplicated(trait$Genotype),]
density(trait$KRN)

par(mfrow=c(2,4))
# KRN
krn <- density(trait[!is.na(trait$Note) & trait$Note=="RIL",]$KRN) # returns the density data
bxkrn <- density(trait[!is.na(trait$Note) & trait$Note=="Bx",]$KRN) # returns the density data
plot(krn, col="red", xlim=c(10,22), ylim=c(0,0.35), main="KRN", xlab="row number") # plots the results
lines(bxkrn, col="blue")

# Kernel: KC, TKW and AKW
kc <- density(trait[!is.na(trait$Note) & trait$Note=="RIL",]$KC)
bxkc <- density(trait[!is.na(trait$Note) & trait$Note=="Bx",]$KC)
plot(kc, col="red", ylim=c(0, 0.005), xlim=c(0, 800), main="KC", xlab="count")
lines(bxkc, col="blue")

tkw <- density(trait[!is.na(trait$Note) & trait$Note=="RIL",]$TKW)
bxtkw <- density(trait[!is.na(trait$Note) & trait$Note=="Bx",]$TKW)
plot(tkw, col="red", xlim=c(0, 250), main="TKW", xlab="weight(g)")
lines(bxtkw, col="blue")

akw <- density(trait[!is.na(trait$Note) & trait$Note=="RIL",]$AKW)
bxakw <- density(trait[!is.na(trait$Note) & trait$Note=="Bx",]$AKW)
plot(akw, col="red", ylim=c(0, 15), main="AKW", xlab="weight(g)")
lines(bxakw, col="blue")

# cob: CL, CW and CD
cl <- density(trait[!is.na(trait$Note) & trait$Note=="RIL",]$CL)
bxcl <- density(trait[!is.na(trait$Note) & trait$Note=="Bx",]$CL)
plot(cl, col="red", xlim=c(50,220), ylim=c(0,0.03), main="CL", xlab="length(mm)" )
lines(bxcl, col="blue")

cw <- density(trait[!is.na(trait$Note) & trait$Note=="RIL",]$CW)
bxcw <- density(trait[!is.na(trait$Note) & trait$Note=="Bx",]$CW)
plot(cw, col="red", ylim=c(0,0.08), main="CW", xlab="weight(g)")
lines(bxcw, col="blue")

cd <- density(trait[!is.na(trait$Note) & trait$Note=="RIL",]$CD)
bxcd <- density(trait[!is.na(trait$Note) & trait$Note=="Bx",]$CD)
plot(cd, col="red", ylim=c(0,0.25), main="CD", xlab="diameter(mm)")
lines(bxcd, col="blue")


pdf_file<-"pdf/piecharts_simple.pdf"
cairo_pdf(bg="grey98", pdf_file,width=11,height=11)

par(omi=c(2,0.5,1,0.25),mai=c(0,1.25,0.5,0.5),family="Lato Light",las=1)
library(RColorBrewer)

# Create chart

pie.myData<-c(5.8,27.0,0.2,21.1,12.8,33.1)
energytypes<-c("Nuclear energy:","Coal**:","Others***:","Gas:","Renewable\nenergies****:","Oil:")
names(pie.myData)<-paste(energytypes,pie.myData,"%",sep=" ")
pie(pie.myData,col=brewer.pal(length(pie.myData),"Reds"),border=0,cex=1.75,radius=0.9,init.angle=90)

# Titling

mtext("Global energy mix (including sea and air transport)",3,line=2,adj=0,family="Lato Black",outer=T,cex=2.5)
mtext("Shares of energy sources in the primary energy supply* in percent, 2008",3,line=-0.75,adj=0,cex=1.65,font=3,outer=T)
mtext("* Primary energy sources = primary energy production + imports - exports +/- stock changes",1,line=2,adj=0,cex=1.05,outer=T)
mtext("** Including peat",1,line=3.2,adj=0,cex=1.05,outer=T)
mtext("*** Bio matter, biodegradable waste (excluding industrial waste), water power, geothermal energy, solar, wind, and marine power.",1,line=4.4,adj=0,cex=1.05,outer=T)
mtext("**** Industrial waste and flammable waste that can serve as energy sources and are non-biodegradable",1,line=5.6,adj=0,cex=1.05,outer=T)
mtext("Source: German Federal Agency for Civic Education: keyword 'Enegiemix' [energy mix], www.bpb.de [website in German]",1,line=8,adj=1,cex=1.25,font=3,outer=T)
dev.off()


#' \code{}
#' <%=ifelse(exists(".annotationslab"), "@param annotations Matrix of size \\eqn{n\\times P + 1}{n*P + 1}. Annotation data, where the first column is the nodeid (should coincide with the coding of the tree), the following columns are function annotations coded as \\code{1} if the node has the function, \\code{0} if the node doesn't has the function and \\code{9} or \\code{NA} otherwise (no information).", "") %>
#' <%=ifelse(exists(".annotations"),    "@param annotations Matrix of size \\eqn{n\\times P}{n*P}. Annotation data, each column is a functional annotation coded as \\code{1} if the node has the function, \\code{0} if the node doesn't has the function and \\code{9} or \\code{NA} otherwise (no information).", "") %>
#' <%=ifelse(exists(".tip.annotation"), "@param tip.annotation,node.annotation Annotation data. See [aphylo-class].", "") %>
#' <%=ifelse(exists(".psi"),         "@param psi Numeric vector of length 2. Misclasification probabilities. (see \\code{\\link{LogLike}}).", "") %>
#' <%=ifelse(exists(".mu"),          "@param mu_d,mu_s Numeric vector of length 2. Gain/loss probabilities (see \\code{\\link{LogLike}}).", "") %>
#' <%=ifelse(exists(".eta"),         "@param eta Numeric vector of length 2. Annotation bias probabilities (see \\code{\\link{LogLike}}).", "") %>
#' <%=ifelse(exists(".Pi"),          "@param Pi Numeric scalar. Root node probability of having the function (see \\code{\\link{LogLike}}).", "") %>
#' <%=ifelse(exists(".offspring"),   "@param offspring List of length \\eqn{n}. Offspring of each node (see \\code{\\link{new_aphylo}}).", "") %>
#' <%=ifelse(exists(".S"),           "@param S Integer matrix of size \\eqn{2^P\\times P}{2^P * P}. See \\code{\\link{states}}.", "") %>
#' <%=ifelse(exists(".tree"),       "@param tree An object of class [phylo][ape::read.tree]", "") %>
#' <%=ifelse(exists(".types"),       "@param tip.type,node.type Integer vectors with values {0,1}. 0 denotes duplication node and 1 speciation node. This is used in [LogLike].", "") %>
NULL


library(Romp)

x <- rnorm(100)

R <- sum(x)
c <- c_sum(x)
f77 <- f77_sum(x)
f90 <- f90_sum(x)
rcpp <- rcpp_sum(x)

stopifnot(all.equal(R, c))
stopifnot(all.equal(R, f77))
stopifnot(all.equal(R, f90))
stopifnot(all.equal(R, rcpp))


library(tfestimators)

mtcdat <- mtcars

# return an input_fn for a given subset of data
mtcars_input_fn <- function(data, num_epochs = 1, batch_size = 64) {
  input_fn(data,
           features = c("disp", "cyl"),
           response = "mpg",
           batch_size = batch_size,
           num_epochs = num_epochs)
}

cols <- feature_columns(
  column_numeric("disp"),
  column_numeric("cyl")
)

model <- dnn_regressor(feature_columns = cols,
                       hidden_units = c(10,10,10))

indices <- sample(1:nrow(mtcars), size = 0.80 * nrow(mtcars))
train <- mtcars[indices, ]
test  <- mtcars[-indices, ]

# train the model
model %>% train(mtcars_input_fn(train, num_epochs = 100))

#tensorboard(log_dir = "/tmp/tftest", launch_browser = TRUE)

model %>% evaluate(mtcars_input_fn(test))

obs <- mtcars[1:3, ]
model %>% predict(mtcars_input_fn(obs))


library(fastmap)

k = 1
x = matrix(1:30, 10)

set.seed(1234)
test = cma(x, k)

set.seed(1234)
truth = fastmap:::.cma(x, k)

stopifnot(all.equal(test, truth))


######################### SCRIPT 1: KNOWN POPUALTION VALIDATION #########################

# dependencies: JAGS, R packages (coda, rjags)

# Load required packages
library(rjags)

# read in data
knownpop = read.csv('data/knownpop.csv',as.is = TRUE)
nsum = read.csv('data/nsum_sg.csv',as.is = TRUE)

names_pop = c('Medical doctors','Primary school teachers','Full-time NS men',
            'Licensed taxi drivers','Hawker stalls owners',
            'Licensed property agents','Male clients of sex workers',
            'Women who had a baby in 2016','NUS graduates 2016',
            'Stroke 2016','Heart attack 2016','Bought an HDB in 2016',
            'Driving license 2016','PSLE 2016','NDP 2016','MSM',
            'O-Levels 2016','Couples who got married in 2016',
            'Dengue 2016','Female sex workers','Men >70 years old',
            'Women >70 years old','Single men >50 years old','IVDU')
hiddenpop = c(0,0,1,0,0,0,1,0,0,1,1,0,0,0,0,1,0,0,0,1,0,0,0,1)
popindex = grep(pattern = '_total',x = names(nsum))

modelstring='model {\n
for(i in 1:N)\n
{\n
for(k in 1:Ku)\n
{\n
nu[i,k] ~ dpois(lambda*alpha[i]*Su[k])\n
}\n
for(k in 1:Kk)\n
{\n
nk[i,k] ~ dpois(lambda*alpha[i]*Sk[k])\n
}\n
alpha[i]~dlnorm(0,tau)\n
}\n
for(k in 1:Ku)\n
{\n
Su[k]~dunif(0,2500000)\n
}\n
for(k in 1:Kk)\n
{\n
Sk[k]~dunif(0,2500000)\n
}\n
lambda ~ dunif(0,10)\n
tau ~ dunif(0,10)\n
}\n'

data0 = nsum[,popindex]

runModel = function(indexu)
{
  indexk = which(!(1:24 %in% indexu))
  dataset=list(
    N=dim(data0)[1],
    Kk=dim(data0)[2]-length(indexu),
    nk=data0[,indexk],
    Ku=length(indexu),
    nu=data0[,indexu],
    Sk=knownpop$real_data[indexk],
    Su=rep(NA,length(indexu)))

  initialisation=list(lambda=0.1)
  jagmod=jags.model(textConnection(modelstring),data=dataset,inits=initialisation,n.chains=1)
  update(jagmod, n.iter=5000, progress.bar="text")
  posterior = coda.samples(jagmod, c("alpha","lambda","tau","Su"),n.iter=10000,progress.bar="text",thin=10)

  results = list(indexk=indexk,indexu=indexu,dataset = dataset,posterior=posterior)
  return(results)
}

indexu = c(3,7,16,20,24)

rs = runModel(indexu = c(3,7,16,20,24))
rs1 = runModel(indexu = c(1,3,7,16,20,24))
rs2 = runModel(indexu = c(2,3,7,16,20,24))
rs4 = runModel(indexu = c(3,4,7,16,20,24))
rs5 = runModel(indexu = c(3,5,7,16,20,24))
rs6 = runModel(indexu = c(3,6,7,16,20,24))
rs8 = runModel(indexu = c(3,7,8,16,20,24))
rs9 = runModel(indexu = c(3,7,9,16,20,24))
rs10 = runModel(indexu = c(3,7,10,16,20,24))
rs11 = runModel(indexu = c(3,7,11,16,20,24))
rs12 = runModel(indexu = c(3,7,12,16,20,24))
rs13 = runModel(indexu = c(3,7,13,16,20,24))
rs14 = runModel(indexu = c(3,7,14,16,20,24))
rs15 = runModel(indexu = c(3,7,15,16,20,24))
rs17 = runModel(indexu = c(3,7,16,17,20,24))
rs18 = runModel(indexu = c(3,7,16,18,20,24))
rs19 = runModel(indexu = c(3,7,16,19,20,24))
rs21 = runModel(indexu = c(3,7,16,20,21,24))
rs22 = runModel(indexu = c(3,7,16,20,22,24))
rs23 = runModel(indexu = c(3,7,16,20,23,24))

rslist = list(rs1=rs1,rs2=rs2,rs4=rs4,rs4=rs4,rs5=rs5,rs6=rs6,rs8=rs8,
              rs9=rs9,rs10=rs10,rs11=rs11,rs12=rs12,rs13=rs13,rs14=rs14,
              rs15=rs15,rs17=rs17,rs18=rs18,rs19=rs19,rs21=rs21,rs22=rs22,rs23=rs23)

getModelResults = function(RESULTS,VALIDATE)
{
  postmat = as.matrix(RESULTS$posterior)
  su = postmat[,paste0('Su[',VALIDATE,']')]
  return(su)
}

quantile(getModelResults(RESULTS = rs1,VALIDATE = 1),probs = c(0.025,0.5,0.975))
knownpopindex = which(!(is.na(knownpop$real_data)))
knownpop$known_population[!(is.na(knownpop$real_data))]
validation = data.frame(index = knownpopindex,known_population = knownpop$known_population[!(is.na(knownpop$real_data))],
                        real = knownpop$real_data[!(is.na(knownpop$real_data))],
                        median=NA,cril=NA,criu=NA)

for(i in 1:length(knownpopindex))
{
  LI = knownpopindex[i]
  validation$median[validation$index %in% knownpopindex[i]] = quantile(getModelResults(RESULTS = rslist[[paste0('rs',LI)]],VALIDATE = which(rslist[[paste0('rs',LI)]]$indexu %in% knownpopindex[i])),probs = c(0.5))
  validation$cril[validation$index %in% knownpopindex[i]] = quantile(getModelResults(RESULTS = rslist[[paste0('rs',LI)]],VALIDATE = which(rslist[[paste0('rs',LI)]]$indexu %in% knownpopindex[i])),probs = c(0.025))
  validation$criu[validation$index %in% knownpopindex[i]] = quantile(getModelResults(RESULTS = rslist[[paste0('rs',LI)]],VALIDATE = which(rslist[[paste0('rs',LI)]]$indexu %in% knownpopindex[i])),probs = c(0.975))
}

discrepancy = (log(validation$median/validation$real))
discrepancy_adjusted = discrepancy
discrepancy_adjusted[validation$known_population %in% "Men >70 years old"] = NA
discrepancy_rank = rank(abs(discrepancy_adjusted),na.last = TRUE)
validation$ratio = (validation$median/validation$real)
validation$discrepancy = log(validation$median/validation$real)
validation$rank = rank(abs(discrepancy_adjusted))
validation

write.csv(validation,file = 'data/validation.csv',row.names = FALSE)


# basic simulations: create left and right parties in
# simulated parliament with various amounts of noise

# Notes:
# (1) First, we define the fraction of the data which is noise ("noise.frac")
# (2) Then with what remains, the "signal" is divided into aa and bb according to "separation":
# "Separation" \in(.5, 1) is one number to generate the spectrum of divided vs consensual, as follows:
# say noise = .2, so the signal =.8. Then:
# consensual - "separation=.5" => a=.4, b=.4
# divided - "separation=.9" => a=.9, b=.1

#make a very divided, low noise, parliament with e.g.
###parl <- make.parliament(300, .1, .9, 300, .9, .1, 100 ) #this implies zero noise words.

#make a cosensual parliament with little noise with e.g.
### make.parliament(300, .4, .5, 300, .5, .4, 100)

#make a very noisy parliament with e.g.
### make.parliament(300, .2, .3, 300, .3, .2, 100)

rm(list=ls())

#define language
right.language <- paste("right_word",1:50, sep="_" )
left.language <- paste("left_word", 1:50, sep="_")
noise <- paste("noise_word", 1:50, sep="_")

#think of as MP's speech as simply being a random draw w replacement
# from this set of language
make.mp <- function(a=.3, b=.3, c=1-(a+b), total.words=100){
  mp.speech <- c(sample(right.language, size=a*total.words ,replace=T),
                 sample(left.language, size= b*total.words ,replace=T),
                 sample(noise, size= c*total.words ,replace=T))
  paste(mp.speech, collapse=" ") #puts everything out as one long string
}

#so, special case includes e.g. 'pure' Tory MP: make.mp(1,0,0)
#and e.g. bipartisan MP with no noise make.mp(.5, .5)

#can make a party from those MPs
make.party <- function(strength=50, aa=.8, bb=.1, cc=1-(aa+bb), total.words=100){
  party.out <- t(replicate(strength, make.mp(aa, bb, cc))) #each row is an MP, each column is a speech
  party.out
}
#for example, could have a left party as make.party(300, a=.1, b=.8, total.words=100) -- each MP makes 100 speeches

options(stringsAsFactors=FALSE) #just make sure speeches aren't factors

#make parliament of two parties
make.parliament <- function(strength.left=300, a.left=.1, b.left=.8, strength.right=300, a.right=.8, b.right=.1, total.words=100 ){
  left.party <- as.character( make.party(strength= strength.left, aa=a.left, bb=b.left, total.words=total.words) )
  right.party <-as.character( make.party(strength= strength.right, aa=a.right, bb=b.right, total.words=total.words) )

  Y <- c( rep(0, strength.left), rep(1, strength.right))
  MPs <- c( paste("MP.left",1:strength.left, sep="."),  paste("MP.right",1:strength.right, sep=".")  )
  dframe <- data.frame(MP=MPs, speeech=c(left.party, right.party))
  #now convert everything to a tfidf dtm
  require(quanteda)
  parliament.idf <- as.matrix( tfidf(dfm(corpus(dframe[,2], ), removeNumbers=F) ) )
  rownames(parliament.idf) <- MPs
  parliament.idf.y <- cbind(Y, parliament.idf)
  parliament.idf.y
}

strength <- 300
size <- 100

# separation: from parity- a/b = 1 to extreme - a/b = very large or very small
for(separation in c(0.5, 0.4, 0.3, 0.2, 0.1)){
  print(paste("separation:", separation), sep=' ')
  for(noise.frac in c(0, 0.1, 0.2, 0.3, 0.4, 0.5, 0.6, 0.7, 0.8, 0.9, 0.95)){ #seq(0,1, .1)){
    print(paste("noise fraction:", noise.frac), sep=' ')
    signal <- 1-noise.frac
    a.left= signal * separation
    a.right= signal * (1-separation)
    b.left = 1- a.left
    b.right = 1- a.right
    parl <- make.parliament(strength, a.left, b.left, strength, a.right, b.right, size)
    write.csv(parl, file=paste("/nas/tz/uk/sim/sims/sim", strength, size, separation*100, noise.frac*100, ".csv", sep='_'))
  }
}

#------------------------------
#
#------------------------------------
separation <- 0.4

for(noise.frac in seq(0,1, .001)){
  print(paste("noise fraction:", noise.frac), sep=' ')
  signal <- 1-noise.frac
  a.left= signal * separation
  a.right= signal * (1-separation)
  b.left = 1- a.left
  b.right = 1- a.right
  parl <- make.parliament(strength, a.left, b.left, strength, a.right, b.right, size)
  write.csv(parl, file=paste("/nas/tz/uk/sim/sims/sim_1k_", strength, size, separation*100, noise.frac*100, ".csv", sep='_'))
}
}


#if (!requireNamespace("BiocManager", quietly = TRUE))
#    install.packages("BiocManager")
#BiocManager::install("edgeR")

library(edgeR)

count <- read.csv("count_table.csv", header=T, row.names=1)
group <- factor(c(rep("A", 18), rep("B", 20)))

design <- model.matrix(~ group)

d <- DGEList(counts = count, group = group)
d <- calcNormFactors(d)
d <- estimateDisp(d, design)
fit <- glmFit(d, design)
lrt <- glmLRT(fit, coef = 2)

table <- as.data.frame(topTags(lrt, n=nrow(count)))
write.table(table, file = "dge_result.csv", col.names=T, row.names=T, sep=",")

# Volcano plot
pdf(file="dge_volcano_plot.pdf", height=as.integer(5), width=as.integer(7))

with(table, plot(logFC, -log10(PValue), pch=20, main="Volcano plot", cex=.5, xlim=c(-6,6), ylim=c(0,8), xaxt="n", yaxt="n", col="black"))

axis(side=1, at=c(-6,-4,-2,0,2,4,6))
axis(side=2, at=c(0,2,4,6,8))

with(subset(table, FDR<.1 ), points(logFC, -log10(PValue), pch=20, cex=.25, col="green"))
with(subset(table, abs(logFC)>1), points(logFC, -log10(PValue), pch=20, cex=.25, col="orange"))
with(subset(table, FDR<.1 & abs(logFC)>1), points(logFC, -log10(PValue), pch=20, cex=.5, col="red"))

dev.off()


library("nloptr")

# Set up parameters and constants
birthyear <- 1997
lifespan <- 100
startage.i <- 22
startage.r <- 60

startyear.i <-  birthyear + startage.i # start investing
startyear.r <- birthyear + startage.r # start retiring (end investing)
endyear.r <- birthyear + lifespan
n.i <- startyear.r - startyear.i # number of years of investing
n.r <- endyear.r - startyear.r # number of years of retirement
n.total <- n.i + n.r

year2ind <- function(year) { year - startyear.i + 1 }
age2ind <- function(age) { age - startage.i + 1 }

PARAM.NAMES <- c('d.roth', 'd.trad', 'w.roth', 'w.trad')

# This is used to pass nloptr a single vector to optimize
pack_params <- function(unpacked_params) {
  vals <- c(unpacked_params$d.roth$vals, unpacked_params$d.trad$vals, unpacked_params$w.roth$vals, unpacked_params$w.trad$vals)
  fixed <- c(unpacked_params$d.roth$fixed, unpacked_params$d.trad$fixed, unpacked_params$w.roth$fixed, unpacked_params$w.trad$fixed)

  list(vals=vals, fixed=fixed)
}

# This is used to unpack the single vector for nloptr into something more manageable
unpack_params <- function(packed_params, size) {
  params <- list()
  params$d.roth$vals <- packed_params$vals[(1: size)]
  params$d.roth$fixed <- packed_params$fixed[(1: size)]
  params$d.trad$vals <- packed_params$vals[(size + 1):(2 * size)]
  params$d.trad$fixed <- packed_params$fixed[(size + 1):(2 * size)]
  params$w.roth$vals <- packed_params$vals[(2 * size + 1):(3 * size)]
  params$w.roth$fixed <- packed_params$fixed[(2 * size + 1):(3 * size)]
  params$w.trad$vals <- packed_params$vals[(3 * size + 1):(4 * size)]
  params$w.trad$fixed <- packed_params$fixed[(3 * size + 1):(4 * size)]

  params
}

unpack_params_simple <- function(packed_params) {
  params <- as.list(packed_params)
  names(params) <- PARAM.NAMES
  params
}

pack_params_simple <- function(params) {
  unlist(params)
}

fix_param <- function(param, indexes, vals) {
  param$vals[indexes] <- vals
  param$fixed[indexes] <- TRUE
  param
}

init_params <- function(n.i, n.r, init_val=0){
  size <- n.i + n.r
  vals <- vector(mode="numeric", length=(size)) + init_val
  fixed <- vector(mode="logical", length=(size))
  params <- rep(list(list(vals=vals, fixed=fixed)), times=length(PARAM.NAMES))
  names(params) <- PARAM.NAMES
  # Fix retirement withdrawals to 0 when not retired
  params$w.roth <- fix_param(params$w.roth, 1:n.i, 0)
  params$w.trad <- fix_param(params$w.trad, 1:n.i, 0)
  # Fix retirement deposits to 0 when retired
  params$d.roth <- fix_param(params$d.roth, (n.i + 1):(size), 0)
  params$d.trad <- fix_param(params$d.trad, (n.i + 1):(size), 0)

  params
}

init_params_simple <- function(init_val=0){
  params <- as.list(rep(init_val, times=length(PARAM.NAMES)))
  names(params) <- PARAM.NAMES
  params
}

# params <- init_params(n.i = n.i, n.r = n.r)
params.simple <- init_params_simple()

# Fix any variables and set up known values
# TODO
incomes <- vector(mode="numeric", length=(n.total))
incomes[year2ind(2019)] <- 9e5
incomes[year2ind(2020)] <- 8.5e5
incomes[year2ind(2021):year2ind(2026)] <- 2e5

# Estimate unknown values
income.estimated <- 5e5
incomes[year2ind(2027):n.i] <- income.estimated
interest.rates <- rep(1.08, (n.total))

# Tax function - using 2020 single filers tax brackets
BRACKETS <- list(rate=c(0.1, 0.12, 0.22, 0.24, 0.32, 0.35, 0.37),
                 cutoffs=c(9875, 40125, 85525, 163300, 207350, 518400, Inf))

clip <- function(vec, LB=0, UB=10) pmax( LB, pmin( vec, UB))
shift <- function(x, by) c(rep(0,times=by), x[1:length(x) - by])

tax_fn_helper <- function(income) {
  lb <- shift(BRACKETS$cutoffs, 1)
  ub <- BRACKETS$cutoffs
  if (income == 0) {
    BRACKETS$rate[1]
  } else {
    (BRACKETS$rate %*% (clip(income, LB=lb, UB=ub) - lb)) / income
  }
}
tax_fn <- Vectorize(tax_fn_helper)

# Account value functions - deposits and withdrawals are pre-tax
interest.cum <- rev(cumprod(interest.rates))

# Don't count traditional deposits as income
adjust.income <- function(incomes, d.trad.vals) {
  incomes - d.trad.vals
}
value.roth <- function(d.roth.vals, w.roth.vals, adjusted.incomes, interest.cum) {
  sum(interest.cum * (d.roth.vals * (1 - tax_fn(adjusted.incomes))) - interest.cum * w.roth.vals)
}
value.trad <- function(d.trad.vals, w.trad.vals, interest.cum) {
  sum(interest.cum * d.trad.vals - interest.cum * w.trad.vals)
}

# Objective - maximize the total amount I get from withdrawals after tax
eval_obj <- function(x, fixed, incomes, interest.cum, size, x.init) {
  params <- unpack_params(list(vals=x, fixed=fixed), size)
  # Minimizing the negative sum
  -sum(params$w.roth$vals + params$w.trad$vals * (1 - tax_fn(params$w.trad$vals)))
}

# Inequality Constraints - should be in form g(x) <= 0
IRA_CONTRIB_LIM <- 6e3

ira.limit.ineq <- function(d.roth.vals, d.trad.vals, adjusted.incomes) {
  (d.roth.vals * (1 - tax_fn(adjusted.incomes))) + d.trad.vals - IRA_CONTRIB_LIM
}
# posdef.transfer <- function(d.roth.vals, d.trad.vals, w.roth.vals, w.trad.vals) {
#   c(-d.roth.vals, -d.trad.vals, -w.roth.vals, -w.trad.vals)
# }
posdef.account.roth <- function(d.roth.vals, w.roth.vals, adjusted.incomes, interest.cum) {
  -value.roth(d.roth.vals, w.roth.vals, adjusted.incomes, interest.cum)
}
posdef.account.trad <- function(d.trad.vals, w.trad.vals, interest.cum) {
  -value.trad(d.trad.vals, w.trad.vals, interest.cum)
}

# Currently only uses final value of account to determine if this was a legal deposit/withdrawal schedule
# This is okay as long as deposits and withdrawals do not overlap, since a negative balance => final value will be negative
# However, this needs to be changed if I allow withdrawals and deposits at the same time.
# TODO adjust income
eval_ineq <- function(x, fixed, incomes, interest.cum, size, x.init) {
  params <- unpack_params(list(vals=x, fixed=fixed), size)
  adjusted.incomes <- adjust.income(incomes, params$d.trad$vals)
  c(ira.limit.ineq(params$d.roth$vals, params$d.trad$vals, adjusted.incomes),
    # posdef.transfer(params$d.roth$vals, params$d.trad$vals, params$w.roth$vals, params$w.trad$vals),
    posdef.account.roth(params$d.roth$vals, params$w.roth$vals, adjusted.incomes, interest.cum),
    posdef.account.trad(params$d.trad$vals, params$w.trad$vals, interest.cum))
}

eval_ineq_simple <- function(x, fixed, income, interest.cum, size, x.init) {
  params <- unpack_params_simple(x)
  adjusted.income <- adjust.income(income, params$d.trad)

  c(ira.limit.ineq(params$d.roth, params$d.trad, adjusted.income),
    posdef.account.roth(params$d.roth, params$w.roth, adjusted.income, interest.cum),
    posdef.account.trad(params$d.trad, params$w.trad, adjusted.income, interest.cum)
  )
}

# Equality Constraints - should be in form h(x) = 0
eval_eq <- function(x, fixed, incomes, interest.cum, size, x.init) {
  (x - x.init) * fixed
}

# Optimize
local_opts <- list(algorithm="NLOPT_LN_COBYLA")
opts <- list(
  algorithm="NLOPT_GN_ISRES",
  xtol_rel=1e-08,
  maxeval=100000
  # local_opts=local_opts
  )
params.packed <- pack_params(params)
res <- nloptr(
  x0=params.packed$vals,
  eval_f=eval_obj,
  lb= rep(0, times=length(params.packed$vals)),
  ub= rep(IRA_CONTRIB_LIM, times=length(params.packed$vals)),
  eval_g_ineq=eval_ineq,
  eval_g_eq=eval_eq,
  opts=opts,
  fixed=params.packed$fixed,
  incomes=incomes,
  interest.cum=interest.cum,
  size=(n.total),
  x.init=params.packed$vals
)

cat("Failed?: ",  res$status)
cat("Status Message: ", res$message)
cat("Total Withdrawal achieved: ", -res$objective)
params.opt <- unpack_params(list(vals=res$solution, fixed=params$fixed), n.total)

cat("Traditional Deposits: ", params.opt$d.trad$vals)
cat("Roth Deposits: ", params.opt$d.roth$vals)
cat("Traditional Withdrawals: ", params.opt$w.trad$vals)
cat("Roth Withdrawals: ", params.opt$w.roth$vals)


# crossprod
test = linalg_crossprod(x=x)$to_robj()
truth = crossprod(xr)
cmp(test[lower.tri(test, diag=TRUE)], truth[lower.tri(truth, diag=TRUE)])

test = linalg_tcrossprod(x=x)$to_robj()
truth = tcrossprod(xr)
cmp(test[lower.tri(test, diag=TRUE)], truth[lower.tri(truth, diag=TRUE)])


install.packages("tidyverse")
library(tidyr)
library(dplyr)

read.csv("input.csv", col.names = c("x")) %>%
  mutate(y = x) %>%
  expand(x,y) %>%
  mutate(sum = rowSums(.[1:2])) %>%
  filter(sum == 2020) %>%
  mutate(product = x*y) %>%
  print()

read.csv("input.csv", col.names = c("x")) %>%
  mutate(y = x) %>%
  mutate(z = x) %>%
  expand(x,y,z) %>%
  mutate(sum = rowSums(.[1:3])) %>%
  filter(sum == 2020) %>%
  mutate(product = x*y*z) %>%
  print()


library(tidyverse)

ggplot(data = mpg) +
  geom_point(mapping = aes(x=displ,y=hwy))

filter(mpg,cyl==8)

filter(diamonds,carat>3)


#' Plot all biomass types
#'
#' Comparison of Total, SSB, and Exploitable Biomass calculated on Jan-1. The Total B is direct from ASAP, while exploitable B and SSB are calculated for this comparison.
#' @param asap name of the variable that read in the asap.rdat file
#' @param save.plots save individual plots
#' @param od output directory for plots and csv files
#' @param plotf type of plot to save
#' @export

PlotAllBiomassTypes<-function(asap,save.plots,od,plotf){
  par(mfrow=c(1,1) )

  sel.aa <- asap$F.age/apply(asap$F.age,1, max)
  exp.b <- apply(asap$N.age*asap$WAA.mats$WAA.jan1*sel.aa,1,sum)
  #exp.b <- asap$exploitable.B
  ssb.jan1 <- apply(asap$N.age*asap$maturity*asap$WAA.mats$WAA.jan1,1,sum)
  tot.b <-asap$tot.jan1.B
  years<-  seq(asap$parms$styr, asap$parms$endyr)

  plot(years, tot.b, type='l', col='maroon', lwd=2, lty=1, xlab="Year", ylab="Biomass",
       ylim=c(0, 1.1*max(exp.b, ssb.jan1, tot.b)) )
  lines(years, ssb.jan1, col='blue', lwd=2, lty=2)
  lines(years, exp.b, col='green2', lwd=2, lty=4)
  legend('top', horiz=T, legend=c("Total", "SSB", "Exploitable"), lty=c(1,2,4),
         lwd=c(2,2,2), col=c("maroon", "blue", "green2") )
  title ( "Comparison of January 1 Biomass", outer=T, line=-1 )

  if (save.plots==T) savePlot( paste0(od, "Biomass.Comparisons.",plotf), type=plotf)
  return()
} #end function


library(lavaan)

full.model2 <- 'competence =~ y2 + y12 + y15 + y16 + y17 + y18
                   functioning =~ y3 +y4+y5+y6+y9+y10+y11+y13+y14+ y21
                   positive_feeling =~ y1 + y7 + y8 + y19 + y20 + y22

                   unaware =~ x4+x3+x5+x6+x12+x11+x10

                   aware =~ x1+x2+x7+x8+x9

                   y13 ~~ y14
 	                y4 ~~ y3
 	                y12 ~~ y15

          unaware ~ competence + functioning + positive_feeling
          aware ~ competence + functioning + positive_feeling'

full.fit2 <- cfa(full.model2,res_SEM)
summary(full.fit2,standardized = TRUE , fit.measures = TRUE)

semPaths(full.fit2, intercepts = FALSE,edge.label.cex = 1, what = 'std',structural = TRUE)


#' Score Iniation Indicators
#'
#' @param df site MSD file
#'
#' @export
#' @importFrom magrittr %>%

score_init <- function(df){

  #1.&2. TX_NEW Position relative to OU-/PSNU-level median (median last three quarters)

  #pull headers to figure out last three quarters to keep
    headers <- names(df)
    pds <- headers[stringr::str_detect(headers, "q(?=[:digit:])")] %>%
      tail(., n =3)
  #narrow down to data needed for indicator creation
    init_tx_new <- df %>%
      dplyr::filter(indicator == "TX_NEW",
                    standardizeddisaggregate == "Total Numerator",
                    typemilitary == "N") %>%
      dplyr::select(operatingunit, psnu,sitename, orgunituid, pds) %>%
      dplyr::filter_if(is.numeric, dplyr::any_vars(!is.na(.) & .!=0)) #remove if all quarters are missing
  #site sum over last 3 pds
    init_tx_new <- init_tx_new %>%
      tidyr::gather(pd, val, dplyr::starts_with("fy")) %>%
      dplyr::select(-pd) %>%
      dplyr::group_by_if(is.character) %>%
      dplyr::summarise_if(is.numeric, ~ sum(., na.rm = TRUE)) %>%
      dplyr::ungroup()
  #Calculate percentile grouping
    init_tx_new <- init_tx_new %>%
      dplyr::group_by(operatingunit) %>%
      dplyr::mutate(init.tx_new_ou.score = dplyr::case_when(val > quantile(val, .75) ~ 2,
                                                            val > quantile(val, .50) ~ 1,
                                                            TRUE                     ~ 0)) %>%
      dplyr::ungroup() %>%
      dplyr::group_by(operatingunit, psnu) %>%
      dplyr::mutate(init.tx_new_psnu.score = dplyr::case_when(val > quantile(val, .75) ~ 2,
                                                              val > quantile(val, .50) ~ 1,
                                                              TRUE                     ~ 0)) %>%
      dplyr::ungroup() %>%
      dplyr::mutate(init.tx_new_ou.value = val) %>%
      dplyr::rename(init.tx_new_psnu.value = val)

  #3. Year on Year change in volume

    qtr <- ICPIutilities::identifypd(df, "quarter")

    qtr_fltr <- dplyr::case_when(qtr == 1 ~ "1",
                                 qtr == 2 ~ "(1|2)",
                                 qtr == 3 ~ "(1|2|3)",
                                 qtr == 4 ~ "(?=[:digit:])")

    pds <- headers[stringr::str_detect(headers, paste0("q", qtr_fltr))]

    init_tx_new_yoy <- df %>%
      dplyr::filter(indicator == "TX_NEW",
                    standardizeddisaggregate == "Total Numerator",
                    typemilitary == "N") %>%
      dplyr::select(operatingunit, psnu,sitename, orgunituid, pds)

    init_tx_new_yoy <- init_tx_new_yoy %>%
      tidyr::gather(pd, val, dplyr::starts_with("fy"), na.rm = TRUE) %>%
      dplyr::mutate(pd = stringr::str_remove_all(pd, "q[:digit:]")) %>%
      dplyr::group_by_if(is.character) %>%
      dplyr::summarise_if(is.numeric, ~ sum(., na.rm = TRUE)) %>%
      dplyr::mutate(init.tx_new_yoyd =  val - dplyr::lag(val),
                    init.tx_new_yoyc = (val - dplyr::lag(val))/dplyr::lag(val)) %>%
      dplyr::ungroup() %>%
      dplyr::filter(pd == "fy2018", is.finite(init.tx_new_yoyc))

  #Calculate percentile grouping
    init_tx_new_yoy <- init_tx_new_yoy %>%
      dplyr::group_by(operatingunit) %>%
      dplyr::mutate(init.tx_new_yoyd.score =
                      dplyr::case_when(init.tx_new_yoyd > quantile(init.tx_new_yoyd, .75) ~ 2,
                                       init.tx_new_yoyd > quantile(init.tx_new_yoyd, .50) ~ 1,
                                       TRUE                                               ~ 0),
                    init.tx_new_yoyc.score =
                      dplyr::case_when(init.tx_new_yoyc > quantile(init.tx_new_yoyc, .75) ~ 2,
                                       init.tx_new_yoyc > quantile(init.tx_new_yoyc, .50) ~ 1,
                                       TRUE                                               ~ 0)) %>%
      dplyr::ungroup() %>%
      dplyr::rename(init.tx_new_yoyd.value = init.tx_new_yoyd,
                    init.tx_new_yoyc.value = init.tx_new_yoyc,
                    init.tx_new_yoy.value = val) %>%
      dplyr::select(-pd, -init.tx_new_yoy.value)

  #4. NET NEW change

    init_tx_netnew_yoy <- df %>%
      dplyr::filter(indicator == "TX_NET_NEW",
                    standardizeddisaggregate == "Total Numerator",
                    typemilitary == "N") %>%
      dplyr::select(operatingunit, psnu,sitename, orgunituid, pds)

    init_tx_netnew_yoy <- init_tx_netnew_yoy %>%
      tidyr::gather(pd, val, dplyr::starts_with("fy"), na.rm = TRUE) %>%
      dplyr::mutate(pd = stringr::str_remove_all(pd, "q[:digit:]")) %>%
      dplyr::group_by_if(is.character) %>%
      dplyr::summarise_if(is.numeric, ~ sum(., na.rm = TRUE)) %>%
      dplyr::mutate(init.tx_netnew_yoyd =  val - dplyr::lag(val),
                    init.tx_netnew_yoyc = (val - dplyr::lag(val))/dplyr::lag(val)) %>%
      dplyr::ungroup() %>%
      dplyr::filter(pd == "fy2018", is.finite(init.tx_netnew_yoyc))

  #Calculate percentile grouping
    init_tx_netnew_yoy <- init_tx_netnew_yoy %>%
      dplyr::group_by(operatingunit) %>%
      dplyr::mutate(init.tx_netnew_yoyd.score =
                      dplyr::case_when(init.tx_netnew_yoyd > quantile(init.tx_netnew_yoyd, .75) ~ 2,
                                       init.tx_netnew_yoyd > quantile(init.tx_netnew_yoyd, .50) ~ 1,
                                       TRUE                                                    ~ 0),
                    init.tx_netnew_yoyc.score =
                      dplyr::case_when(init.tx_netnew_yoyc > quantile(init.tx_netnew_yoyc, .75) ~ 2,
                                       init.tx_netnew_yoyc > quantile(init.tx_netnew_yoyc, .50) ~ 1,
                                       TRUE                                                     ~ 0)) %>%
      dplyr::ungroup() %>%
      dplyr::rename(init.tx_netnew_yoyd.value = init.tx_netnew_yoyd,
                    init.tx_netnew_yoyc.value = init.tx_netnew_yoyc,
                    init.tx_netnew_yoy.value = val) %>%
      dplyr::select(-pd, -init.tx_netnew_yoy.value)

  #combine all together
    init <- list(init_tx_new, init_tx_new_yoy, init_tx_netnew_yoy) %>%
      purrr::reduce(dplyr::full_join, by = c("operatingunit", "psnu", "sitename", "orgunituid"))
    return(init)
}


#source("http://www.bioconductor.org/biocLite.R")
#biocLite("affy")
#biocLite("limma")
#biocLite("hgu95acdf")

library(affy)
library(limma)
library(hgu95acdf)

setwd("~/work/abe516/r/de/data")
raw = ReadAffy()
probeNames(raw)[1:20]
geneNames(raw)[1:10]
image(raw[,1])
hist(raw)
boxplot(raw, col=c(2,2,3,3,4,4,5,5))
par(mfrow=c(2,4))
MAplot(raw, plot.method="smoothScatter")

raw.bg=bg.correct(raw, "rma")
raw.norm=normalize(raw.bg, "quantiles")
hist(raw.norm, main = " raw data after RMA  BG & quantile normalization ")
par(mfrow=c(2,4))
MAplot(raw.norm, plot.method= "smoothScatter")
raw.pm=pmcorrect.pmonly(raw.norm)
eset <- computeExprSet(raw.norm, "pmonly","medianpolish")

eset <- expresso(raw,
                 bgcorrect.method = "rma",
                 normalize.method = "quantiles",
                 pmcorrect.method = "pmonly",
                 summary.method ="medianpolish")
f <- factor(c(1,1,2,2,3,3,4,4),
            labels=c("brain", "f.brain", "f.liver", "liver"))
design <- model.matrix(~ 0 + f)
colnames(design) <-c("brain", "f.brain", "f.liver", "liver")

fit <- lmFit(eset, design)

contrast.matrix <- makeContrasts(f.brain-brain, f.liver-liver, levels = design)

fit1 <- contrasts.fit(fit, contrast.matrix)
fit2 <- eBayes(fit1)

topTable(fit2, n=10, adjust="fdr")
topTable(fit2,coef=1,n=10, adjust="fdr")
topTable(fit2,coef=2,n=10, adjust="fdr")

modt=topTable(fit2,
              coef=1,
              sort.by="t",
              adjust="fdr",
              number=10)[,c(1,3)]

logodds= topTable(fit2, coef=1,sort.by="B",
                  adjust="fdr",number=10)[,c(1,6)]

logFC=topTable(fit2, coef=1,sort.by="logFC",
               adjust="fdr",number=10)[,c(1,3)]

results <- decideTests(fit2, adjust="fdr", p=0.05)
results2 <- decideTests(fit2, adjust="fdr", p=0.005)

summary(results)
summary(results2)
p.value <-fit2$F.p.value

i <- grep("AFFX", geneNames(raw))
summary(p.value[i])

results <- classifyTestsF(fit2,
                          p.value=0.000001)
head(results)
summary(results)
vennDiagram(results)

table(brain.comp=results[,1],liver.comp=results[,2])
jpeg("my_vennDiagram.jpg", width = 960, height = 480, pointsize = 10, quality = 100, bg = "white" )
par(mfrow=c(1,2))
vennDiagram(results,include="up",
            main="up")
vennDiagram(results,include="down",
            main="down")
dev.off()

brain.up <- results[results[,1]==1, 1]
brain.down <- results[results[,1]== -1,1 ]
write.csv(data.frame(brain.up),file="myresults_brain_up.csv")
write.csv(data.frame(brain.down),file="myresults_brain_down.csv")

par(mfrow=c(1,2))
volcanoplot(fit2,coef=1, main="brain",
            names=row.names(fit2$coefficients), highlight=10)
volcanoplot(fit2,coef=2, main="liver",
            names=row.names(fit2$coefficients), highlight=10)


context("Bounds")

test_that("rescale_mid returns correct results", {
  x <- c(-1, 0, 1)

  expect_equal(rescale_mid(x), c(0, 0.5, 1))
  expect_equal(rescale_mid(x, mid = -1), c(0.5, 0.75, 1))
  expect_equal(rescale_mid(x, mid = 1), c(0, 0.25, 0.5))

  expect_equal(rescale_mid(x, mid = 1, to = c(0, 10)), c(0, 2.5, 5))
  expect_equal(rescale_mid(x, mid = 1, to = c(8, 10)), c(8, 8.5, 9))
})

test_that("rescale_max returns correct results", {
  expect_equal(rescale_max(0), NaN)
  expect_equal(rescale_max(1), 1)
  expect_equal(rescale_max(.3), 1)
  expect_equal(rescale_max(c(4, 5)), c(0.8, 1.0))
  expect_equal(rescale_max(c(-3, 0, -1, 2)), c(-1.5, 0, -0.5, 1))
  expect_equal(rescale_max(c(-3, 0, -1, 2)), c(-1.5, 0, -0.5, 1))
})

test_that("zero range inputs return mid range", {
  expect_that(rescale(0), equals(0.5))
  expect_that(rescale(c(0, 0)), equals(c(0.5, 0.5)))
})

test_that("censor and squish ignore infinite values", {
  expect_equal(squish(c(1, Inf)), c(1, Inf))
  expect_equal(censor(c(1, Inf)), c(1, Inf))

})

test_that("scaling is possible with dates and times", {
  dates <- as.Date(c("2010-01-01", "2010-01-03", "2010-01-05", "2010-01-07"))
  expect_equal(rescale(dates, from = c(dates[1], dates[4])), seq(0,1,1/3))
  expect_equal(rescale_mid(dates, mid = dates[3])[3], 0.5)

  dates <- as.POSIXct(c("2010-01-01 01:40:40",
                        "2010-01-01 03:40:40",
                        "2010-01-01 05:40:40",
                        "2010-01-01 07:40:40"))
  expect_equal(rescale(dates, from = c(dates[1], dates[4])), seq(0, 1, 1/3))
  expect_equal(rescale_mid(dates, mid = dates[3])[3], 0.5)

})

test_that("scaling is possible with integer64 data", {
  x <- bit64::as.integer64(2^60) + c(0:3)
  expect_equal(
    rescale_mid(x, mid = bit64::as.integer64(2^60) + 1),
    c(0.25, 0.5, 0.75, 1))
})

test_that("scaling is possible with NULL values", {
  expect_null(rescale(NULL))
  expect_null(rescale_mid(NULL))
})

test_that("scaling is possible with logical values", {
  expect_equal(rescale(c(FALSE, TRUE)), c(0, 1))
  expect_equal(rescale_mid(c(FALSE, TRUE), mid = 0.5), c(0, 1))
})


# Josep Ll. Berral-García
# ALOJA-BSC-MSR hadoop.bsc.es
# 2015-11-17
# Variable relation functions library for ALOJA-ML

library(rms);

## EXAMPLES
#
#vin <- c("Net","Disk","Maps","IO.SFac","IO.FBuf","Blk.size","Datanodes","VM.Cores","VM.RAM");
#vout <- "Exe.Time";
#
#ds <- aloja_get_data("test3-CL21-22.csv");
#aloja_variable_relations (ds, vin, vout, minsamples = 100);
#
#ds <- aloja_get_data("test4-CL21.csv");
#aloja_variable_relations (ds, vin, vout, minsamples = 100);

###############################################################################
# Variable relation tools                                                     #
###############################################################################

aloja_variable_relations <- function (ds, vin, vout, minsamples = 100, saveall = NULL, quiet = 1)
{
	if (!is.numeric(minsamples)) minsamples <- as.numeric(minsamples);

	retval <- list();

	for (i in vin)
	{
		retobj <- list();

		if (length(unique(ds[,i])) < 2)
		{
			if (quiet == 0) print(paste("Exe.Time vs.",i,"=== Skipping. Only one class or unique value in variable",sep=" "));
			retobj[["Label"]] <- paste("Exe.Time vs.",i,sep=" ");
			retobj[["json"]] <- paste('{"Label":"Exe.Time vs. ',i,'","Reference":"","Intercept":"","Slope":"","Message":"Only one Class or Value"}',sep="");
		} else {

			# Fair Sample
			faux1 <- table(ds[,i]);
			if (all(faux1[faux1 < minsamples])) { threshold <- minsamples; } else { threshold <- min(faux1[faux1 >= minsamples]); }

			dsaux <- data.frame(vin=NA, vout=NA);
			names(dsaux)[1] = i;
			names(dsaux)[2] = vout;
			for (j in names(faux1))
			{
				selected <- sample(1:faux1[j],min(faux1[j],threshold));
				dsaux_b <- ds[ds[,i]==j,c(vout,i)];
				dsaux <- rbind(dsaux,dsaux_b[selected,]);
			}

			# Find Slopes
			dsout <- dsaux[,vout];
			dsin <- dsaux[,i];
			b <- ols(dsout ~ dsin);
			nols <- names(b$coefficients);

			if (class(dsin) %in% c("factor","character")) retobj[["Reference"]] <- levels(as.factor(dsin))[1];
			retobj[["Label"]] <- paste("Exe.Time vs.",i,sep=" ");
			retobj[["Intercept"]] <- b$coefficients[[1]];
			for (j in 2:length(b$coefficients)) retobj[["Slope"]][[nols[j]]] <- b$coefficients[[j]];

			# Print on screen
			if (quiet == 0)
			{
				if (class(dsin) %in% c("factor","character")) { ref1 <- paste("Reference:",retobj[["Reference"]],sep=" "); } else { ref1 <- NULL; }
				saux1 <- paste("Exe.Time vs.",i,"===",ref1,"Intercept:",retobj[["Intercept"]],sep=" ");
				for (j in 1:length(retobj[["Slope"]])) saux1 <- paste(saux1,"Slope (",names(retobj[["Slope"]])[j],"):",retobj[["Slope"]][j],sep=" ");
				print(saux1);
			}

			jaux <- NULL;
			for (j in 1:length(retobj[["Slope"]])) jaux <- paste(jaux,',"',names(retobj[["Slope"]])[j],'":"',retobj[["Slope"]][j],'"',sep="");
			retobj[["json"]] <- paste('{"Label":"Exe.Time vs. ',i,'","Reference":"',retobj[["Reference"]],'","Intercept":"',retobj[["Intercept"]],'","Slope":{',substring(jaux,2),'},"Message":""}',sep="");
		}
		retval[[i]] <- retobj;
	}

	if (!is.null(saveall))
	{
		jaux <- NULL;
		for (i in vin) jaux <- paste(jaux,",",retval[[i]][["json"]],sep="");
		fileConn <- file(paste(saveall,"-json.dat",sep=""));
		writeLines(paste("[",substring(jaux,2),"]",sep=""), fileConn);
		close(fileConn);

		aloja_save_object(retval,tagname=saveall);
	}

	retval;
}

aloja_variable_quicklm <- function (ds, vin, vout, saveall = NULL, sample = 1)
{
	if (!is.numeric(sample)) sample <- as.numeric(sample); if (sample < 0 || sample > 1) { sample <- 1; print("WARNING: Invalid sample ratio"); }

	retval <- list();

	dsbin <- aloja_binarize_ds(ds[,c("ID",vin,vout)]);

	if (sample < 1)
	{
		ssize <- ceil(nrow(ds) * sample);
		km1 <- kmeans(dsbin[,(!colnames(dsbin) %in% c("ID"))],centers=ssize);
		dsbin <- as.data.frame(km1$centers);
	}

	retval[["ds_original"]] <- ds;
	retval[["dataset"]] <- dsbin;
	retval[["model"]] <- lm(dsbin[,vout] ~ ., data=dsbin[,(!colnames(dsbin) %in% c("ID",vout))]);

	retval[["mae"]] <- mean(abs(retval$model$fitted.values - dsbin[,vout]));
	retval[["rae"]] <- mean(abs((retval$model$fitted.values - dsbin[,vout])/dsbin[,vout]));
	retval[["coefs"]] <- t(retval$model$coefficients);
	retval[["sample"]] <- sample;

	jaux <- NULL;
	for (j in 1:length(retval$coefs)) jaux <- paste(jaux,',"',colnames(retval$coefs)[j],'":"',retval$coefs[j],'"',sep="");
	retval[["json"]] <- paste('{"Regression":{',substring(jaux,2),'},"MAE":',retval$mae,',"RAE":',retval$rae,',"Sample":',retval$sample,'}',sep="");

	if (!is.null(saveall))
	{
		fileConn <- file(paste(saveall,"-json.dat",sep=""));
		writeLines(retval$json, fileConn);
		close(fileConn);

		aloja_save_object(retval,tagname=saveall);
	}

	retval;
}

aloja_variable_quickrt <- function (ds, vin, vout, saveall = NULL, mparam = 5, simple = 1, sample = 1)
{
	if (!is.integer(mparam)) mparam <- as.integer(mparam);
	if (!is.integer(simple)) simple <- as.integer(simple); if (simple < 0 || simple > 1) { simple <- 1; print("WARNING: Invalid simple parameter"); }
	if (!is.numeric(sample)) sample <- as.numeric(sample); if (sample < 0 || sample > 1) { sample <- 1; print("WARNING: Invalid sample ratio"); }

	retval <- list();

	dsbin <- aloja_binarize_ds(ds[,c("ID",vin,vout)]);

	if (sample < 1)
	{
		ssize <- ceil(nrow(ds) * sample);
		km1 <- kmeans(dsbin[,(!colnames(dsbin) %in% c("ID"))],centers=ssize);
		dsbin <- as.data.frame(km1$centers);
	}

	retval[["ds_original"]] <- ds;
	retval[["dataset"]] <- dsbin;
	retval[["model"]] <- qrt.tree(varout=vout,dataset=dsbin[,(!colnames(dsbin) %in% c("ID"))],m=mparam,simple=simple);

	retval[["mae"]] <- retval$model$mae;
	retval[["rae"]] <- retval$model$rae;

	retval[["sample"]] <- sample;
	retval[["json"]] <- qrt.json(retval$model);

	if (!is.null(saveall))
	{
		fileConn <- file(paste(saveall,"-json.dat",sep=""));
		writeLines(retval$json, fileConn);
		close(fileConn);

		png(paste(saveall,"-tree.png",sep=""),width=1000,height=500);
		qrt.plot.tree(retval$model);
		dev.off();

		aloja_save_object(retval,tagname=saveall);
	}

	retval;
}


print(paste0(Sys.time(), " --- Histogram of PTEs active years"))

# Tabulate statistics of years active
tax <- df_describers[spp_N_1st_auth_s>=1]
tax$yrs_active1 <- tax$max_corrected - tax$min + 1

# Active based on max_corrected
yrs_active1 <- tax$yrs_active1
tax[yrs_active1 <=0]
yrs_active1[yrs_active1<=0] <- 0
# tax[yrs_active1>30]$full.name.of.describer

# Active based on max_correct and with date of death
yrs_active1b <- tax[!is.na(dod.describer),]$yrs_active1

tax[yrs_active1 >100]
df[grepl("Abrahamovich|Lucia", full.name.of.describer) & date == 1913]

summary(yrs_active1)  # all
summary(yrs_active1b) # with dod
length(yrs_active1)

hist_active_yrs <- ggplot(data.frame(yrs=yrs_active1b)) +
    geom_histogram(data.frame(yrs=yrs_active1),
                   mapping=aes(x=yrs, y=..count../sum(..count..) * 100),
                   binwidth=10, fill='black') +
    # geom_histogram(aes(x=yrs, y=..count../sum(..count..) * 100), binwidth=10,
    #                fill='grey80', alpha=0.6) +
    scale_x_continuous(breaks= seq(0, max(yrs_active1), 10)) +
    scale_y_continuous(breaks= seq(0, 50, 10), limits=c(0, 50)) +
    # geom_vline(
    #     xintercept=summary(yrs_active1)[2],
    #     color='grey', size=.5,
    # ) +
    # geom_vline(
    #     xintercept=summary(yrs_active1)[3],
    #     color='grey', size=.5,
    # ) +
    # geom_vline(
    #     xintercept=summary(yrs_active1)[5],
    #     color='grey', size=.5,
    # ) +
    # geom_vline(
    #     xintercept=summary(yrs_active1b)[5],
    #     color='grey', size=.5, linetype="dotted"
    # ) +
    xlab("\nNumber of active years") + ylab("Percentage of PTEs (%)\n") +
    theme

ggsave(
    paste0(dir_plot, 'fig-4.png'), hist_active_yrs,
    units="cm", width=12, height=5.5, dpi=300
)

# Active based on max publication dates
yrs_active2 <- tax$max - tax$min

# Based on sum of authors that described a species
yrs_active3 <- df[, c("date", "full.name.of.describer")] %>%
    separate_rows(full.name.of.describer, sep="; ")

yrs_active3 <- data.table(unique(yrs_active3))
yrs_active3 <- yrs_active3[, .N, by='date'][order(date)]
yrs_active3$date <- as.integer(yrs_active3$date)

plot_tax_effort5 <- ggplot(data=yrs_active3, aes(x=date, y=N)) +
    geom_line() + theme +
    xlab("Number of PTEs") + ylab("Year") +
    ggtitle(paste0("Number of PTEs in each year"))

# Mean number of species/year
hist_mean_sp_per_auth <- ggplot(df_describers) +
    geom_histogram(
        mapping=aes(x=ns_species_per_year_active,
        y=..count../sum(..count..) * 100), binwidth=5) +
    theme


## ----load libraries, echo=FALSE------------------------------------------
library(tidyverse)
library(ggmap)
library(here)

## ----make a word cloud of plot names, fig.width=10, fig.height=8, out.width="70%"----
library(wordcloud)
namedplots <- c("histogram", "barchart", "scatterplot", "piechart", "lineplot", "density_plot", "boxplot", "dendrogram", "treemap", "scatterplot_matrix", "parallel_coordinate_plot", "biplot", "contourplot", "stem_and_leafplot", "rug_plot", "dotplot", "mosaic_plot", "spine_plot", "forest_plot", "heatmap", "qqplot", "star_plot", "chernoff_face","graph", "beeswarm", "violin_plot", "tour", "choropleth_map", "glyph_map", "cartogram", "bubble_plot", "correlogram", "area_chart", "population_pyramid", "seasonal_plot", "frequency_polygon", "biplot", "profile_plot", "funnel_plot")
pal <- c("#A1719D","#03329B","#0774E4","#702E8D","#6B44B7","#B71452","#D50321","#F39E9C","#FCB52C","#B78ED2")
wordcloud(namedplots, freq = sample(1:10, length(namedplots), replace=TRUE), colors=pal)

## ----read TB data and wrangle and subset to USA--------------------------
tb <- read_csv(here::here("data/TB_notifications_2019-07-01.csv")) %>%
  select(country, iso3, year, new_sp_m04:new_sp_fu) %>%
  gather(stuff, count, new_sp_m04:new_sp_fu) %>%
  separate(stuff, c("stuff1", "stuff2", "sexage")) %>%
  select(-stuff1, -stuff2) %>%
  mutate(sex=substr(sexage, 1, 1),
         age=substr(sexage, 2, length(sexage))) %>%
  select(-sexage)

# Filter years between 1997 and 2012 due to missings
tb_us <- tb %>%
  filter(country == "United States of America") %>%
  filter(!(age %in% c("04", "014", "514", "u"))) %>%
  filter(year > 1996, year < 2013)

## ----make a bar chart of US TB incidence, echo=TRUE, out.width="60%", fig.width=10, fig.height=3----
ggplot(tb_us, aes(x = year, y = count, fill = sex)) +
  geom_bar(stat = "identity") +
  facet_grid(~ age)

## ----colour and axes fixes, echo=TRUE, fig.height=3----------------------
# This uses a color blind proof scale
ggplot(tb_us, aes(x=year, y=count, fill=sex)) +
  geom_bar(stat="identity") +
  facet_wrap(~age, ncol=6) +
  scale_fill_brewer("", palette="Dark2")

## ----compare proportions of males/females, out.width="70%", echo=TRUE, fig.height=3----
# Fill the bars, note the small change to the code
ggplot(tb_us, aes(x=year, y=count, fill=sex)) +
  geom_bar(stat="identity", position="fill") +
  facet_wrap(~age, ncol=6) +
  scale_fill_brewer("", palette="Dark2") + ylab("proportion")

## ----compare counts of males/females, out.width="100%", echo=TRUE, fig.height=5----
# Make separate plots for males and females, focus on counts by category
ggplot(tb_us, aes(x=year, y=count, fill=sex)) +
  geom_bar(stat="identity") +
  facet_wrap(sex~age, ncol=6) +
  scale_fill_brewer("", palette="Dark2")

## ----rose plot of males/females, out.width="60%", echo=TRUE, fig.height=5----
# How to make a pie instead of a barchart - not straight forward
ggplot(tb_us, aes(x=year, y=count, fill=sex)) +
  geom_bar(stat="identity") +
  facet_wrap(sex~age, ncol=6) +
  scale_fill_brewer("", palette="Dark2") +
  coord_polar()

## ----stacked barchart of males/females, out.width="60%", echo=TRUE, fig.height=5----
# Step 1 to make the pie
ggplot(tb_us, aes(x = 1, y = count, fill = factor(year))) +
  geom_bar(stat="identity", position="fill") +
  facet_wrap(sex~age, ncol=6) +
  scale_fill_viridis_d("", option="inferno")

## ----pie chart of males/females, out.width="60%", echo=TRUE, fig.height=5----
# Now we have a pie, note the mapping of variables
# and the modification to the coord_polar
ggplot(tb_us, aes(x = 1, y = count, fill = factor(year))) +
  geom_bar(stat="identity", position="fill") +
  facet_wrap(sex~age, ncol=6) +
  scale_fill_viridis_d("", option="inferno") +
  coord_polar(theta = "y")

## ----use a line plot instead of bar, fig.height=3------------------------
ggplot(tb_us, aes(x=year, y=count, colour=sex)) +
  geom_line() + geom_point() +
  facet_wrap(~age, ncol=6) +
  scale_colour_brewer("", palette="Dark2")

## ----use a line plot of proportions, fig.height=3------------------------
tb_us %>% group_by(year, age) %>%
  summarise(p = count[sex=="m"]/sum(count)) %>%
  ggplot(aes(x=year, y=p)) +
  geom_hline(yintercept = 0.50, colour="white", size=2) +
  geom_line() + geom_point() +
  facet_wrap(~age, ncol=6) +
  ylab("proportion of males")

# Your turn
## ----use a line plot instead of bar, fig.height=3------------------------
ggplot(tb_us, aes(x=year, y=count, colour=age)) +
  geom_line() + geom_point() +
  facet_wrap(~sex, ncol=6) +
  scale_colour_brewer("", palette="Dark2")

ggplot(tb_us, aes(x=year, y=count, colour=age)) +
  geom_point() +
  geom_smooth(method="lm", se=FALSE) +
  facet_wrap(~sex, ncol=6) +
  scale_colour_brewer("", palette="Dark2")

tb_us$sex <- factor(tb_us$sex, levels = c("f", "m"),
                    labels=c("female", "male"))
ggplot(tb_us, aes(x=year, y=count)) +
  geom_point(aes(colour=age)) +
  geom_smooth(method="lm",
              se=FALSE, colour="black") +
  facet_wrap(~sex, ncol=6) +
  scale_colour_brewer("", palette="Dark2")

## ----load the platypus obervation data, echo=TRUE------------------------
load(here::here("data/platypus.rda"))
platydata <- platypus$data
ggplot(data=platydata) + geom_point(aes(x=longitude, y=latitude))

## ----Add some transparency to see density of locations, echo=TRUE--------
ggplot(data=platydata) + geom_point(aes(x=longitude, y=latitude), alpha=0.1)

## ----making a map projection, echo=TRUE, fig.height=10, out.width="100%"----
ggplot(data=platydata) +
  geom_point(aes(x=longitude, y=latitude), alpha=0.1) +
  coord_map()

## ----load the saved map data, echo=TRUE----------------------------------
load(here::here("data/oz.rda"))
ggmap(oz) +
  geom_point(data=platydata, aes(x=longitude, y=latitude),
              alpha=0.1, colour="orange")

## Your turn: density plot
ggmap(oz) +
  geom_density2d(data=platydata, aes(x=longitude, y=latitude),
             colour="orange")

## ----create a date variable, echo=TRUE-----------------------------------
library(lubridate)
platydata <- platydata %>%
  mutate(eventDate = ymd(eventDate))

## ----show sightings ovre time, echo=TRUE, out.width="60%"----------------
ggplot(data=platydata) +
  geom_point(aes(x=eventDate, y=1))

## ----focus on records since 1900 and count the number for each year, echo=TRUE, out.width="60%"----
platydata1900 <- platydata %>% filter(year>1900) %>%
  count(year)
ggplot(data=platydata1900) +
  geom_point(aes(x=year, y=n))

## ----add a trend line, echo=TRUE, out.width="60%"------------------------
ggplot(data=platydata1900, aes(x=year, y=n)) +
  geom_point() +
  geom_smooth(se=F)

## ----make it interactive to investigate some observations, echo=TRUE-----
library(plotly)
ggplotly()


##https://github.com/jrfaulkner/spmrf

#' Extract latent process parameters and associated Bayesian credible intervals
#'
#' Extract theta (latent process) parameters from an object with posterior draws and associated Bayesian credible intervals.
#' @param mfit An object containing posterior draws from a \code{spmrf} model fit or \code{stan} model fit.  The object can be of class \code{stanfit}, \code{array}, \code{matrix}, or \code{data.frame}.
#' @param obstype Character string with the name of the probability distribution of the observations.  This controls the back-transformation of the process parameters.  Possible values for \code{obstype} are 'normal', 'poisson', or 'binomial'.
#' @param alpha Controls level for 100*(1-\code{alpha})\% Bayesian credible intervals. Values must be 0 < \code{alpha} < 1.
#' @return Returns a list with the posterior median and posterior (1-\code{alpha}) quantiles of the theta parameter vector.
#' @seealso \code{\link[rstan]{stan}}, \code{\link[rstan]{as.array.stanfit}}, \code{\link[rstan]{as.matrix.stanfit}}, \code{\link[rstan]{as.data.frame.stanfit}}, \code{\link{spmrf}}
#' @export

extract_theta <- function(mfit, obstype="normal",  alpha=0.05){

  if (missing(mfit)) stop("Must specify object with posterior draws from a spmrf or stan model fit.")
  if ( !(class(mfit)[1] %in% c("array", "matrix", "data.frame", "stanfit") ) ) stop("Object must be of class 'stanfit', 'array', 'matrix', or 'data.frame'.  Object must be or be generated from a stan model fit object.")
  if ( !(obstype %in% c("normal", "poisson", "binomial") ) ) stop("Argument 'obstype' must be 'normal', 'poisson', or 'binomial'.")
  if (!(0 < alpha & alpha < 1)) stop("Must specify 'alpha' between 0 and 1.")

  if (class(mfit)[1]=="stanfit") {
  	 if (!requireNamespace("rstan", quietly = TRUE)) {
    			stop("Package 'rstan' needed for this function to work. Please install it.", call. = FALSE)
  	 }
  	tmp.th <- rstan::extract(mfit, "theta")[[1]]
  }
  if (class(mfit)[1]=="array")  {
    nca <- dim(mfit)[2]
	  tmp.th1 <- mfit[ , 1, ]
	  if (nca > 1){
	    for (jj in 2:nca){
	      tmp.th1 <- rbind(tmp.th1, mfit[ ,jj,])
	    }
	  }
	  ath <-  grep(x=dimnames(tmp.th1)[[2]], pattern="theta")
	  zth <-  grep(x=dimnames(tmp.th1)[[2]], pattern="ztheta")
	  thind <- setdiff(ath, zth)
	  tmp.th <- tmp.th1[ , thind]
  }
  if (class(mfit)[1]=="matrix"){
  	ath <-  grep(x=colnames(mfit), pattern="theta")
  	zth <-  grep(x=colnames(mfit), pattern="ztheta")
  	thind <- setdiff(ath, zth)
  	tmp.th <- mfit[ , thind]
  }
  if (class(mfit)[1]=="data.frame") {
  	ath <-  grep(x=names(mfit), pattern="theta")
  	zth <-  grep(x=names(mfit), pattern="ztheta")
  	thind <- setdiff(ath, zth)
  	tmp.th <- as.matrix(mfit[ , thind])
  }
  plow <- alpha/2
  phigh <- 1 - alpha/2

  if (obstype=="normal"){
   tmp.md <- apply(tmp.th, 2, median)
   tmp.l <- apply(tmp.th, 2, quantile, probs=plow)
   tmp.u <- apply(tmp.th, 2, quantile, probs=phigh)
  }
  if (obstype=="poisson"){
   tmp.md <- exp(apply(tmp.th, 2, median))
   tmp.l <- exp(apply(tmp.th, 2, quantile, probs=plow))
   tmp.u <- exp(apply(tmp.th, 2, quantile, probs=phigh))
  }
  if (obstype=="binomial"){
   tmp.md <- plogis(apply(tmp.th, 2, median))
   tmp.l <- plogis(apply(tmp.th, 2, quantile, probs=plow))
   tmp.u <- plogis(apply(tmp.th, 2, quantile, probs=phigh))
  }
   out <- list(postmed=tmp.md, bci.lower=tmp.l, bci.upper=tmp.u)
   out

}


#!/usr/bin/env Rscript
#autor:      Joao Sollari Lopes
#local:      University of Reading, Reading, UK
#Rversion:   3.2.3
#criado:     01.03.2010
#modificado: 20.11.2017

# @arg data_file - file with summary of 'real' data (.trg)
# @arg rej_file  - file with rejection step results (.rej)
# @arg pri_file  - file with sample of priors (.pri)
model_choice <- function(data_file , rej_file , pri_file){

	#import VGAM library
	library(VGAM)

	#import Mark Beaumont's scripts
	source("calmod.r")

	#import the .rej file
	abc.rej <- data.matrix(read.table(rej_file))

	#import the .pri files
	priors <- data.matrix(read.table(pri_file))

	#import the .trg files
	target <- data.matrix(read.table(data_file))

	# Perform model choice with the rejection-step
	top1 <- length(which(abc.rej[,2]==1))/2000
	top2 <- length(which(abc.rej[,2]==2))/2000
	print(c(top1,top2))
    fname <- "../results/model_rej.eps"
    postscript(file=fname,width=7,height=7,colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special")
	barplot(c(top1,top2),names=c("top1","top2"))
	abline(h=1.0/2,col="red")
	dev.off()
	print("model choice - rejection done.")

	# Perform model choice with the regression-step
	abc.model <- calmod(target,abc.rej[,2],abc.rej[,13:21],1,rej=F)
	print(abc.model$x2)
    fname <- "../results/model_reg.eps"
    postscript(file=fname,width=7,height=7,colormodel="rgb",horizontal=FALSE,onefile=FALSE,paper="special")
	barplot(abc.model$x2,names=c("top1","top2"))
	abline(h=1.0/2,col="red")
	dev.off()
	print("model choice - regression done.")

}

args = commandArgs(trailingOnly=TRUE)
model_choice(args[1],args[2],args[3])


create_equality_constraint <- function(A_mat, b_vec) {
    stop_if_dimensionality_names_are_missing(A_mat)
    constr <- list(constr = rbind(A_mat, -A_mat), dir = rep("<=", 2 * nrow(A_mat)), rhs = c(b_vec,-1*b_vec))
    rownames(constr$constr) <- c(rownames(A_mat), negative_string(rownames(A_mat)))
    return(constr)
}

constraint_H_with_bounds <- function(A, b, bounds_tuple_of_numeric, num_muscles=NULL) {
    H_constraint <- create_equality_constraint(A, b)
    bounds <- bound_constraints_for_all_muscles(bounds_tuple_of_numeric, muscle_names=colnames(A))
    comb <- merge_constraints(H_constraint, bounds)
    comb$constr <- as.matrix(comb$constr)
    return(comb)
}

constraint_H_lhs_direction <- function(A, direction, bounds_tuple_of_numeric) {
    lhs <- create_equality_constraint(A, rep(0, nrow(A)))

}

add_null_column_to_end_of_lhs <- function(constraint, column_name) {
    c_copy <- constraint
    output_dimensionality <- nrow(constraint$constr)
    c_copy$constr <- cbind(constraint$constr, rep(0, output_dimensionality))
    colnames(c_copy$constr)[ncol(c_copy$constr)] <- column_name
    return(c_copy)
}

##' @param A equality constraints—must have named columns and rows for input and output dimensions
##' @param direction the direction to generate constraints on. Must have an attr(direction, "output_dimension_names") with a string name for each dimension. same len as direction
a_matrix_lhs_direction <- function(H_matrix, direction, bounds_tuple_of_numeric) {
    wrench_and_H_dims_match(H_matrix, direction)
    task_lambda_colname <- "task_lambda"
    stop_if_dimensionality_names_are_missing(H_matrix)
    muscle_names <- colnames(H_matrix)
    output_dimension_names <- rownames(H_matrix)
    A_block <- create_equality_constraint(cbind(H_matrix, -direction), rep(0, nrow(H_matrix)))
    colnames(A_block$constr)[ncol(A_block$constr)] <- task_lambda_colname
    bounds_raw <- bound_constraints_for_all_muscles(bounds_tuple_of_numeric, muscle_names)
    bounds <- add_null_column_to_end_of_lhs(bounds_raw, column_name=task_lambda_colname)
    constraint <- merge_constraints(A_block, bounds)
    return(constraint)
}

a_matrix_rhs_task <- function(H_matrix_input, task_wrench, bounds_tuple_of_numeric){
    wrench_and_H_dims_match(H_matrix_input,task_wrench)
    stop_if_dimensionality_names_are_missing(H_matrix_input)
    muscle_names <- colnames(H_matrix_input)
    bounds_raw <- bound_constraints_for_all_muscles(bounds_tuple_of_numeric, muscle_names)

    H_equality <- create_equality_constraint(H_matrix_input, task_wrench)
    constraint <- merge_constraints(H_equality, bounds_raw)
    return(constraint)
}

##' Negate a Constraint
##' useful for creating equality constraints. then stack this result with the original to make an equality constr.
##' @param constraint_object constraint object as in hitandrun
##' @param neg_constr same constraints, but all negated. The direction remains the same, as less than.
negate_constraint <- function(constraint_object){
    list(constr = -constraint_object$constr, dir = constraint_object$dir, rhs=-constraint_object$rhs)
}

write_constraint_to_csv <- function(constraint_object, output_filepath){
    write.csv(cbind(constraint_object$constr, dir=constraint_object$dir,rhs=constraint_object$rhs), output_filepath)
}

#bounds
lb_ub_strings <- function(name) paste0(c("lb_", "ub_"), name)
bound_constraints_for_all_muscles <- function(bounds_tuple_of_numeric, muscle_names) {
    n_muscles <- length(bounds_tuple_of_numeric)
    res <- lapply(1:n_muscles, function(muscle_index) {
        lb <- lowerBoundConstraint(n_muscles, muscle_index, bounds_tuple_of_numeric[[muscle_index]]$lower)
        ub <- upperBoundConstraint(n_muscles, muscle_index, bounds_tuple_of_numeric[[muscle_index]]$upper)
        return(merge_constraints(lb, ub))
    }) %>% mergeConstraints
    rownames(res$constr) <- dcclapply(muscle_names, lb_ub_strings)
    colnames(res$constr) <- muscle_names
    return(res)
}

split_constraints <- function(constraint, n_shards){
    n_constraints <- nrow(constraint$constr)
    idxs <- 1:n_constraints
    indices_per_shard <- split(idxs, cut_number(idxs, n_shards)) %>% unname
    miniconstraints <- lapply(indices_per_shard, function(indices_for_shard){
        res <- list(constr=constraint$constr[indices_for_shard,],
            dir=constraint$dir[indices_for_shard],
            rhs=constraint$rhs[indices_for_shard])
        return(res)
    })
    return(miniconstraints)
}


#locs <- read.csv("data/aeronet_bigf_locs.csv", stringsAsFactors=FALSE)

locs <- get_aeronet_matches()

locs$n <- rep(NA, nrow(locs))
locs$rmse <- rep(NA, nrow(locs))
locs$corr <- rep(NA, nrow(locs))
locs$m <- rep(NA, nrow(locs))
#locs$c <- rep(NA, nrow(locs))
locs$r2 <- rep(NA, nrow(locs))
locs$e_mean <- rep(NA, nrow(locs))
locs$e_sd <- rep(NA, nrow(locs))
locs$perc_e_mean <- rep(NA, nrow(locs))
locs$perc_e_sd <- rep(NA, nrow(locs))

#locs <- locs[locs$run == 1,]

mlist.aeronet = list()

for (i in 1:nrow(locs))
{
  l <- locs[i,]
  print(paste("###### Running validation for", l$aeronet, "and", l$bigf))
  m.temp <- aeronet_bigf_merge(l$aeronet, tolower(l$bigf))

  if (is.na(m.temp) || (is.na(m.temp[1]) && length(m.temp) == 1))
  {
    locs[i,]$rmse <- NA
    locs[i,]$m <- NA
    #locs[i,]$c <- NA
    locs[i,]$corr <- NA
    locs[i,]$r2 <- NA
    locs[i,]$n <- NA
    locs[i,]$e_mean <- NA
    locs[i,]$e_sd <- NA
    locs[i,]$perc_e_mean <- NA
    locs[i,]$perc_e_sd <- NA
  }
  else
  {
    # Calculate percentage error
    m.temp$perc_e <- (m.temp$error / m.temp$PWC) * 100

    locs[i,]$rmse <- rmse(m.temp$error)
    model <- lm(m.temp$PWC ~ m.temp$iwv + 0)
    locs[i,]$m <- model$coefficients[1]
    #locs[i,]$c <- model$coefficients[1]
    locs[i,]$r2 <- summary(model)$r.squared
    locs[i,]$e_mean <- mean(m.temp$error)
    locs[i,]$e_sd <- sd(m.temp$error)
    locs[i,]$perc_e_mean <- mean(m.temp$perc_e)
    locs[i,]$perc_e_sd <- sd(m.temp$perc_e)

    locs[i,]$n <- nrow(m.temp)

    locs[i,]$corr <- cor(m.temp$PWC, m.temp$iwv)

    mlist.aeronet[[l$bigf]] = m.temp
  }

}

val.aeronet <- na.omit(locs)

mla = list()

for (i in 1:length(mlist.aeronet))
{
  item <- mlist.aeronet[[i]]
  name <- names(mlist.aeronet)[i]

  if (length(item) == 1)
  {
    next()
  }
    mla[[name]] = item
}

m.aeronet <- do.call('rbind', mla)
m.aeronet <- as.data.frame(m.aeronet)

cache('val.aeronet')
cache('mlist.aeronet')
cache('m.aeronet')


#!/usr/bin/Rscript

# Bhishan Poudel
# Jan 16, 2016

# set up a device driver to plot
#postscript(file='~/Copy/Programming/R/rprograms/plotting/legends/legend3.eps')

par(mar = c(4, 4, 2, 0.1))
plot(rnorm(100), rnorm(100),
     xlab = expression(hat(mu)[0]), ylab = expression(alpha^beta),
     main = expression(paste("Plot of ", alpha^beta, " versus ", hat(mu)[0])))

# turn off device driver
#dev.off()


#! /usr/bin/env Rscript

suppressMessages(require(reshape2))
suppressMessages(require(plyr))

args <- commandArgs(trailingOnly = TRUE)

if (length(args) != 1) {
  stop("Usage: run_expectancy.r <path/to/csv>")
}

event_run_csv_path <- args[1]
cat("\nReading CSV (takes about 30 seconds).\n")
system.time(events <- read.csv(event_run_csv_path))
cat("\n")

events$state_1b <- factor(events$state_1b,labels=c("--","1B"))
events$state_2b <- factor(events$state_2b, labels=c("--","2B"))
events$state_3b <- factor(events$state_3b, labels=c("--","3B"))
events$state_outs <- factor(events$state_outs, labels=c("0 Outs","1 Out", "2 Outs"))
events$new_state_1b <- factor(events$new_state_1b,labels=c("--","1B"))
events$new_state_2b <- factor(events$new_state_2b, labels=c("--","2B"))
events$new_state_3b <- factor(events$new_state_3b, labels=c("--","3B"))
events$new_state_outs <- factor(events$new_state_outs, labels=c("0 Outs","1 Out", "2 Outs", "3 Outs"))

table_1 <- dcast(
  events,
  list(
    .("1B"=state_1b, "2B"=state_2b, "3B"=state_3b),
    .(state_outs)),
  fun.aggregate=function(runs_eoi) round(mean(runs_eoi), 3),
  value.var="runs_eoi")

table_1 <- table_1[order(table_1$"0 Outs"),]
cat("\nRun Expectancy, By the 24 Base/Out States, 1999-2002\n\n")
print(table_1, row.names=FALSE)
cat("\n")


# Modified from https://gist.github.com/andrewheiss/926b9d60a26e29f6bf32

# Load libraries
library(dplyr)
library(tidyr)
library(rgdal)
library(rgeos)
library(spdep)
library(data.table)

# # Load shapefiles
# countries <- readOGR('data/geo/1_separate/gadm/shp_all_levels/gadm36_0.shp')
countries <- readOGR('data/geo/ne_50m_admin_0_countries_lakes/ne_50m_admin_0_countries_lakes.shp')

# Extract the ISO codes and map them to the numeric row names
country.names <- data_frame(id = row.names(countries@data),
                            country_iso3 = as.character(countries@data$ADM0_A3))
country.names2 <- data_frame(id = row.names(countries@data),
                             country_name = as.character(countries@data$NAME_EN))
country.names$neighbor_iso3 <- country.names$country_iso3
country.names2$neighbor_name <- country.names2$country_name

# Determine which countries are neighbors
# Adapted from http://stackoverflow.com/a/32318128/120898
#
# spdep::poly2nb/nb2mat method is faster and more accurate than rgeos::gTouches
#
# gTouches gives wrong results; doesn't see Russia-North Korea border; is suuuuuuuper slow
#   neighbor.matrix <- gTouches(countries, byid=TRUE)
#
neighbor.list <- poly2nb(countries)
neighbor.matrix <- nb2mat(neighbor.list, style="B", zero.policy=TRUE)
colnames(neighbor.matrix) <- rownames(neighbor.matrix)

# Clean up and transform the neighbor matrix
all.neighbors <- as.data.frame(neighbor.matrix) %>%
  mutate(country = row.names(.)) %>%  # Convert row names to actual column
  gather(neighbor, present, -country) %>%  # Convert to long
  filter(present == 1) %>%  # Only look at cells with a match
  # Add country names
  left_join(select(country.names, -neighbor_iso3), by=c("country" = "id")) %>%
  left_join(select(country.names, -country_iso3), by=c("neighbor" = "id")) %>%
  left_join(select(country.names2, -neighbor_name), by=c("country" = "id")) %>%
  left_join(select(country.names2, -country_name), by=c("neighbor" = "id")) %>%
  filter(country_iso3 != "-99", neighbor_iso3 != "-99")  # Remove missing countries
  # select(contains("iso3"))  # Just get the ISO columns
head(all.neighbors)

all.neighbors <- data.table(all.neighbors)
all.neighbors <- all.neighbors[, c("country_iso3", "neighbor_iso3", "country_name", "neighbor_name")]

#
#   country_iso3 neighbor_iso3
# 1          CHN           AFG
# 2          IRN           AFG
# 3          PAK           AFG
# 4          TJK           AFG
# 5          TKM           AFG
# 6          UZB           AFG

write.csv(all.neighbors, "data/lookup/2019-11-01-country-adjacent.csv", fileEncoding="UTF-8", row.names=F)

neighbor.summary <- all.neighbors %>%
  group_by(country_iso3) %>%
  summarise(num = n()) %>%
  arrange(desc(num))
neighbor.summary


rawData <- read.csv("data/train.csv")
train <- rawData[1:(nrow(rawData) * 0.7), ]
crossValid <- rawData[(nrow(train) + 1):(nrow(rawData)), ]
test <- read.csv("data/test.csv")

cleaningData <- function(original) {
    if ("Survived" %in% colnames(original)) {
        #usefulCol <- c("Survived", "Pclass", "Sex", "Age", "SibSp","Parch","Fare","Embarked")
        usefulCol <- c("Survived", "Pclass", "Sex", "Age")
    } else {
        #usefulCol <- c("Pclass", "Sex", "Age", "SibSp","Parch","Fare","Embarked")
        usefulCol <- c("Pclass", "Sex", "Age")
    }

    data <- data.matrix(fixNa(original)[, usefulCol])
    cbind(matrix(1, nrow(data), 1), data)
    #fixNa(original)[, usefulCol]
}

fixNa <- function(data) {
    temp <- data
    temp$Age[is.na(temp$Age)] <- mean(temp$Age, na.rm=T)
    temp$Fare[is.na(temp$Fare)] <- mean(temp$Fare, na.rm=T)
    temp$Pclass[is.na(temp$Pclass)] <- mean(temp$Pclass, na.rm=T)
    temp$SibSp[is.na(temp$SibSp)] <- mean(temp$SibSp, na.rm=T)
    temp$SibSp[is.na(temp$Parch)] <- mean(temp$Parch, na.rm=T)
    temp
}

mySigmoid <- function(z) {
    1.0 / (1.0 + exp(-z));
}

costFunc <- function(theta, X, y) {
    sum(cbind(y, 1 - y) * cbind(log(sigmoid(X %*% theta)), log(1 - sigmoid(X %*% theta)))) / -nrow(X)
}

gradient <- function(theta, X, y) {
    (t(X) %*% (sigmoid(X %*% theta) - y)) / nrow(X);
}

learning <- function(train, alpha, iterNum) {
    cleanTrain <- cleaningData(train)
    X <- cleanTrain[, -2]
    y <- cleanTrain[, 2]
    theta <- matrix(0, ncol(X), 1)
    for (i in 1:iterNum) {
        theta <- theta - alpha * gradient(theta, X, y)
    }
    theta
}

builtInLearning <- function(train) {
    glm(Survived~., family = binomial, data=train)
}

crossValidate <- function(validateSet, theta) {
    cleanedData <- cleaningData(validateSet)
    X <- cleanedData[, -2]
    y <- cleanedData[, 2]
    m <- nrow(X)
    p <- rep(c(0), m)
    correct <- 0
    t_neg <- 0
    t_pos <- 0
    f_neg <- 0
    f_pos <- 0
    for (i in 1:m) {
        rate <- sigmoid(X[i,] %*% theta)

        if (rate >= 0.5 && y[i] == 1) {
            t_pos <- t_pos + 1
        } else if (rate < 0.5 && y[i] == 1) {
            t_neg <- t_neg + 1
        } else if (rate >= 0.5 && y[i] == 0) {
            f_neg <- f_neg + 1
        } else if (rate < 0.5 && y[i] == 0) {
            f_pos <- f_pos + 1
        }

        if ((rate >= 0.5 && y[i] == 1) || (rate < 0.5 && y[i] == 0)) {
            correct <- correct + 1
        }

    }

    precision <- (t_pos / (t_pos + f_pos))
    recall <- (t_pos / (t_pos + f_neg))
    f1 <- (precision * recall) / (precision + recall)
    #acc <- (t_pos + t_neg) / (t_pos + t_neg + f_pos + f_neg)
    acc <- correct / m

    list(precision = precision, recall = recall, f1 = f1, acc = acc)
}

myPredict <- function(test, theta) {
    X <- cleaningData(test)
    m <- nrow(X)
    p <- rep(c(0), m)

    for (i in 1:m) {
        rate <- sigmoid(X[i,] %*% theta)

        if (rate >= 0.5) {
            p[i] <- 1
        } else {
            p[i] <- 0
        }

    }

    data.frame(PassengerId=test[,"PassengerId"], Survived=p)
}


counts <- c(18,17,15,20,10,20,25,13,12)
outcome <- gl(3,1,9)
treatment <- gl(3,3)
print(d.AD <- data.frame(treatment, outcome, counts))

debug_main <- function() {
    glm.D93 <<- glm(counts ~ outcome + treatment, family = poisson())
}

debug(debug_main)

debug_main()


library(readr)
library(dplyr) # filter, group_by...
library(lubridate) # process date data
library(ggplot2)
library(scales)
library(RColorBrewer)

# load data from .csv file
train <- read_csv("../input/train.csv", col_types = list(StateHoliday = col_character()))
test <- read_csv("../input/test.csv", col_types = list(StateHoliday = col_character()))
store <- read_csv("../input/store.csv")

# Add each store's average sales and customers to hthe store-level data frame
store <- left_join(store, summarize(group_by(train[train$Open == 1,], Store)
                              , AvgSales = mean(Sales, na.rm = TRUE) # remove null value within
                              , AvgCust = mean(Customers, na.rm = TRUE)), "Store")

store$Assortment[store$Assortment == "a"] <- "basic"
store$Assortment[store$Assortment == "b"] <- "extra"
store$Assortment[store$Assortment == "c"] <- "extended"
store$StTyAs <- paste("'", store$StoreType, "'", " store type - "
                   , store$Assortment, sep = "")

store$CompDistBin <- ntile(store$CompetitionDistance, 5)
store$CompDistBin <- paste(store$CompDistBin, "quintile")
store$CompDistBin[store$CompDistBin == "NA quintile"] <- NA

store$CompOpenDate <- ymd(paste(store$CompetitionOpenSinceYear
                             , store$CompetitionOpenSinceMonth
                             , "01"))

store$CompOpenDate <- as.Date(store$CompOpenDate)
store <- select(store
             , Store
             , StoreType
             , Assortment
             , StTyAs
             , CompDist = CompetitionDistance
             , CompDistBin
             , CompOpenDate
             , AvgSales
             , AvgCust)
store$AvgSpC <- store$AvgSales / store$AvgCust
store$CompDays <- as.numeric(as.Date("2015-09-17") - store$CompOpenDate)

int_TilePlot <- function(data, response, x, y
                         , r_lab = response, x_lab = x, y_lab = y
                         , r_scale = comma, x_scale = comma, y_scale = comma
                         , bins = 10, exp = 8){

  x_brk <- seq(min(data[[x]]), max(data[[x]]), length.out = bins)
  y_brk <- seq(min(data[[y]]), max(data[[y]]), length.out = bins)
  df <- data.frame(x_val = rep(x_brk, bins)
                   , y_val = rep(y_brk, each = bins)
                   , r_val = NA)
  df$x_z <- (df$x_val - mean(data[[x]])) / sd(data[[x]])
  df$y_z <- (df$y_val - mean(data[[y]])) / sd(data[[y]])
  data$x_z <- (data[[x]] - mean(data[[x]])) / sd(data[[x]])
  data$y_z <- (data[[y]] - mean(data[[y]])) / sd(data[[y]])
  for (i in 1:nrow(df)){
    dist <- numeric()
    for (j in 1:nrow(data)){
      dist <- append(dist, sqrt(abs(df$x_z[i] - data$x_z[j])^2
                                + abs(df$y_z[i] - data$y_z[j])^2))
    }
    adjDist <- abs(dist - max(dist))^exp
    wtdResp <- sum(adjDist * data[[response]]) / sum(adjDist)
    df$r_val[i] <- wtdResp
  }
  ggplot(df, aes(x = x_val, y = y_val, z = r_val)) +
    geom_tile(aes(fill = r_val)) +
    stat_contour(bins = 15) +
    scale_x_continuous(x_lab, labels = x_scale) +
    scale_y_continuous(y_lab, labels = y_scale) +
    scale_fill_continuous(r_lab, labels = r_scale) +
    theme_minimal()
}
int_TilePlot(store[store$StoreType != 'b' & !is.na(store$CompDist),]
             , "CompDist", "AvgSpC", "AvgCust"
             , "Competition Distance"
             , "Average Sales per Customer"
             , "Average # of Customers"
             , comma, dollar, comma)


library("ROCR")
library("nnet")
library("ResourceSelection")

data = read.csv("datasets/CardiacDataAdj.csv",header = T)
data.continous = keep(data, function(x) {!(all(x %in% c(0,1,0.5)))})
data.categorical = keep(data, function(x) {all(x %in% (c(0,1,1.5)))})
for (i in c(14,17:31)){
  data[[i]] = factor(data[[i]])
} #cast to factor
for (i in names(data.continous)){
  outliers[[i]] = boxplot.stats(data.continous[,i])$out
} #ensure that no outliers exist
data_over60 = data[data$age > 60,]

training_over60 = head(data_over60,331)
testing_over60 = tail(data_over60,83)

# start with all variables minus collineary variables
start_back_any_60 = glm(any.event ~ . -basedp -pkhr -dp -X.mphr.b. -dpmaxdo -newMI -newCABG - newPTCA - death, data = training_over60, family = 'binomial',control = list(maxit = 50))
end_back_any_60 = step(start_back_any_60)

# worse results
start_forw_any_60 = glm(any.event ~ 1 , data = training_over60, family = 'binomial',control = list(maxit = 50))
end_forw_any_60 = step(start_forw_any_60, direction='forward',scope=formula(start_back_any_60))

start_both_any_60 = glm(any.event ~ 1 , data = training_over60, family = 'binomial',control = list(maxit = 50))
end_both_any_60 = step(start_forw_any_60, direction='both',scope=formula(start_back_any_60))

car::vif(end_back_any_60) #check collinearity
#check linearity between  independent variables and log odds.
probabilities <- end_back_any_60 %>% predict(training_over60, type = "response")
mydata <- training_over60 %>%
  select("dobdose","dobEF")
predictors <- c("dobdose","dobEF")
mydata <- mydata %>%
  mutate(logit = log(probabilities/(1-probabilities))) %>%
  gather(key = "predictors", value = "predictor.value", -logit)
ggplot(mydata, aes(logit, predictor.value))+
  geom_point(size = 0.5, alpha = 0.5) +
  geom_smooth(method = "loess") +
  theme_bw() +
  facet_wrap(~predictors, scales = "free_y")
#apporximately linear

#Mc Fadden Pseudo R^2
ll.null <- end_back_any_60$null.deviance/-2
ll.proposed <- end_back_any_60$deviance/-2
(ll.null - ll.proposed) / ll.null
1 - pchisq(2*(ll.proposed - ll.null), df=(length(end_back_any_60$coefficients)-1)) # pseudo R^2 p-value
hoslem.test(end_back_any_60$y, fitted(end_back_any_60), g=10) #goodness of fit test

#ROC curve training data
pred_back =  prediction(end_back_any_60$fitted.values,training_over60$any.event)
eval_back = performance(pred_back,"acc")
plot(eval_back)
roc = performance(pred_back, "tpr","fpr")
plot(roc,colorize = T,main="ROC curve, any event, age > 60, training data",ylab="True Positive",xlab="False Positive")
abline(a=0,b=1)
auc = performance(pred_back,"auc")
auc = unlist(slot(auc,"y.values"))
auc = round(auc,4)
legend(.7,.2,auc,title="AUC")

#ROC curve testing data
pred_back =  predict(end_back_any_60,testing_over60,type='response')
pred_back = prediction(pred_back,testing_over60$any.event)
eval_back = performance(pred_back,"acc")
plot(eval_back)
roc = performance(pred_back, "tpr","fpr")
plot(roc,colorize = T,main="ROC curve, age > 60, testing data",ylab="True Positive",xlab="False Positive")
abline(a=0,b=1)
auc = performance(pred_back,"auc")
auc = unlist(slot(auc,"y.values"))
auc = round(auc,4)
legend(.7,.2,auc,title="AUC")


####### Setup #######

library(tidyverse)
library(gridExtra)
library(GGally)
library(readr)
library(rcompanion)

vColors = c("#049DD9","#03A64A","#F2AC29","#F2CA80","#F22929")

theme_set(theme_minimal())

dfData <- read.table("data_exam_june2020.txt", header = TRUE)

dfData <- dfData %>% mutate(id = factor(id), success = factor(success))

####### Descriptive Statistics #######

str(dfData)

summary(dfData)

group_by(dfData, age_group, structure, success) %>%
  summarise(Observations = n())

sum(is.na(dfData)) # no nas

# Sucess per Student

# xyplot(success ~ 1 | id,
    #   data = dfData, type = 'b', scale = list(c(tick.number = 2)),
    #   as.table = TRUE)

# Success per Factor

p1 =
  ggplot(data = dfData,aes(x = id, fill = success)) +
  geom_bar() +
  scale_fill_manual(values = vColors[c(1,2)]) +
  scale_color_manual(values = vColors[c(1,2)]) +
  ylab("Observations") + xlab("id of Child") +
  theme(panel.grid.major.x = element_blank()) +
  theme(legend.position = "none")

p2 =
  ggplot(data = dfData,aes(x = age_group, fill = success)) +
  geom_bar() +
  scale_fill_manual(values = vColors[c(1,2)]) +
  scale_color_manual(values = vColors[c(1,2)]) +
  ylab("Observations") + xlab("Age Group") +
  theme(panel.grid.major.x = element_blank()) +
  theme(legend.position = "none") + ylim(0,1200)

p3 =
  ggplot(data = dfData,aes(x = structure, fill = success)) +
  geom_bar() +
  scale_fill_manual(values = vColors[c(1,2)]) +
  scale_color_manual(values = vColors[c(1,2)]) +
  ylab("Observations") + xlab("Structure") +
  theme(panel.grid.major.x = element_blank()) +
  theme(legend.position = "none")+ ylim(0,1200)

p4 =
  ggplot(data = dfData,aes(x = match_mismatch, fill = success)) +
  geom_bar() +
  scale_fill_manual(values = vColors[c(1,2)]) +
  scale_color_manual(values = vColors[c(1,2)]) +
  ylab("Observations") + xlab("Match or Mismatch") +
  theme(panel.grid.major.x = element_blank())+ ylim(0,1200)

grid.arrange(p2,p3,p4,p1, layout_matrix = rbind(c(1,2,3),c(4,4,4)), top = "Success per Factor")

# Interactions

p1 =
  ggplot(data = dfData,aes(x = interaction(age_group,structure), fill = success)) +
  geom_bar() +
  scale_fill_manual(values = vColors[c(1,2)]) +
  scale_color_manual(values = vColors[c(1,2)]) +
  ylab("Observations") + xlab("Interaction Age Group with Structure") +
  theme(panel.grid.major.x = element_blank()) +
  theme(legend.position = "none") + ylim(0,600)

p2 =
  ggplot(data = dfData,aes(x = interaction(age_group,match_mismatch), fill = success)) +
  geom_bar() +
  scale_fill_manual(values = vColors[c(1,2)]) +
  scale_color_manual(values = vColors[c(1,2)]) +
  ylab("Observations") + xlab("Interaction Age Group with Mismatch") +
  theme(panel.grid.major.x = element_blank()) +
  theme(legend.position = "none") +
  ylim(0,600)

p3 =
  ggplot(data = dfData,aes(x = interaction(structure,match_mismatch), fill = success)) +
  geom_bar() +
  scale_fill_manual(values = vColors[c(1,2)]) +
  scale_color_manual(values = vColors[c(1,2)]) +
  ylab("Observations") + xlab("Interaction Structure with Mismatch") +
  theme(panel.grid.major.x = element_blank()) + ylim(0,600)

grid.arrange(p1,p2,p3, nrow = 1, top = "Success per Interaction")

####### Correlation Statistics #######

# Indepentend between each other

vCraV = c()

for(i in 1:4){
  vCraV[i] = cramerV(table(dfData[,c(i,5)]))
}

vCraV = data.frame(cbind(vCraV,Name = colnames(dfData)[1:4]), stringsAsFactors = F)

ggplot(data = vCraV, aes(y = as.numeric(vCraV), x = Name)) +
  geom_bar(stat = "identity", fill = vColors[3]) +
  geom_text(aes(x=Name,y=as.numeric(vCraV) + 0.05 ,label= round(as.numeric(vCraV),2)),vjust=0, color = "grey30") +
  ylab("Cramer's V") +
  xlab("Variable") +
  theme(panel.grid.major.x = element_blank()) +
  ylim(0,1)

# Test all for quasi seperation in binary regression so beta is not going to infinity

table(as.integer(dfData$structure)-1 > 0, as.integer(dfData$success)-1) # Nearest one


# 4. faza: Napredna analiza podatkov

# CLUSTERING ###################################################################

#podatki za zdravstvo po letu 2011 vedno slabši zato je najbolj optimalno leto za analizo 2011

# tabela:

X <- zivljenje %>% filter(leto == "2011") %>% filter(!drzava %in% c("Bulgaria","Luxembourg"))
X$drzava[X$drzava == "Czech Republic"] <- "Czech Rep."
X.norm <- X %>% dplyr::select(pricakovana.starost, kg.na.osebo, odstotek.BDP.ki.gre.v.zdravstvo, tveganje.revscine)%>%
  scale()
rownames(X.norm) <- X$drzava
X.norm <- X.norm[1:29, -1]

## HIERARHIČNO

#funkcije s predavanj:

hc.kolena = function(dendrogram, od = 1, do = NULL, eps = 0.5) {
  # število primerov in nastavitev parametra do
  n = length(dendrogram$height) + 1
  if (is.null(do)) {
    do = n - 1
  }
  # k.visina je tabela s štirimi stolpci
  # (1) k, število skupin
  # (2) višina združevanja
  # (3) sprememba višine pri združevanju
  # (4) koleno: ali je točka koleno?
  k.visina = tibble(
    k = as.ordered(od:do),
    visina = dendrogram$height[do:od]
  ) %>%
    # sprememba višine
    mutate(
      dvisina = visina - lag(visina)
    ) %>%
    # ali se je intenziteta spremembe dovolj spremenila?
    mutate(
      koleno = lead(dvisina) - dvisina > eps
    )
  k.visina
}

# iz tabele k.visina vrne seznam vrednosti k,
# pri katerih opazujemo koleno
hc.kolena.k = function(k.visina) {
  k.visina %>%
    filter(koleno) %>%
    dplyr::select(k) %>%
    unlist() %>%
    as.character() %>%
    as.integer()
}

# narišemo diagram višin združevanja
diagram.kolena = function(k.visina) {
  k.visina %>% ggplot() +
    geom_point(
      mapping = aes(x = k, y = visina),
      color = "red"
    )+
    geom_line(
      mapping = aes(x = as.integer(k), y = visina),
      color = "red"
    )+
    geom_point(
      data = k.visina %>% filter(koleno),
      mapping = aes(x = k, y = visina),
      color = "blue", size = 2
    )+
    ggtitle(paste("Kolena:", paste(hc.kolena.k(k.visina), collapse = ", "))) +
    xlab("število skupin (k)") +
    ylab("razdalja pri združevanju skupin") +
    theme_classic()
}

diagram.skupine = function(podatki, oznake, skupine, k) {
  podatki = podatki %>%
    bind_cols(skupine) %>%
    rename(skupina = ...2)

  d = podatki %>%
    ggplot(
      mapping = aes(
        x = x, y = y, color = skupina
      )
    ) +
    geom_point() +
    geom_label(label = oznake, size = 2) +
    scale_color_hue() +
    theme_classic()

  for (i in 1:k) {
    d = d + geom_encircle(
      data = podatki %>%
        filter(skupina == i)
    )
  }
  d
}

library(rgeos)
library(ggalt)

dendrogram <- dist(X.norm) %>% hclust(method = "ward.D")

r = hc.kolena(dendrogram)
diagram.kolena(r)
# -> 4 skupine

#zakomentirano da ne izpisuje v rmd
#plot(dendrogram, hang=-1, cex=0.4, main = "drzava", labels = X$drzava)
#rect.hclust(dendrogram,k=4,border="red")

skupine = dendrogram %>% cutree(k = 4) %>% as.ordered()
skupine

diagram.skupine(X.norm, colnames(X.norm), skupine, 2 )

#drzave <- attributes(X.norm)$dimnames[[1]]  # dobimo imena, ki jih spremenimo potem v stolpce (to ni df)
#drzave.x.y = as_tibble(X.norm %>% cmdscale(k = 2)) #%>% bind_cols(drzave) %>%
#  rename(drzava = ...3, x = V1, y = V2)

# Narišemo države tako, da jih pobarvamo glede na pripadnost skupini
#  diagram.skupine(drzave.x.y, drzave.x.y$drzava, skupine, 4)

data("World")
evropa <- World %>% filter (continent == 'Europe')
skupina <- data.frame(name = X$drzava, skupine=factor(skupine))
zem <- merge(x = evropa, y =  skupina)
grupiranje.map <- tm_shape(zem) + tm_polygons("skupine", palette = "Pastel1", popup.vars = c("Skupina: " = "skupine"))+tmap_mode("view")

grupiranje.map

# NAPOVED ######################################################################

# za napoved pricakovane zivljenjske dobe v Sloveniji za leto 2020
# uvozila nove podatke, z daljšim časovnim obdobjem

pricakovana.slo <- read_csv("podatki/HFA_43_EN.csv",
                        skip = 25,
                        na = "-",
                        locale = locale(encoding = "Windows-1250"))%>%
  filter(COUNTRY == "SVN")%>%
  dplyr::select(YEAR, VALUE )

library(ranger)

Lag <- function(x, n){c(rep(NA, n), x)[1:length(x)]}

naredi.df <- function(x){
  data.frame(pricakovana = x,
             pricakovana1 = Lag(x, 1),
             pricakovana2 = Lag(x, 2),
             pricakovana3 = Lag(x, 3),
             pricakovana4 = Lag(x, 4))

}

df <- naredi.df(pricakovana.slo$VALUE)
model = ranger(formula = pricakovana ~ ., data = df %>% drop_na())

n = nrow(df)

df2 <- naredi.df(c(pricakovana.slo$VALUE, NA))
napoved <- predict(model, data = df2[n+1,])$predictions
df2[n+1,1] = napoved

pricakovanje <- as_tibble(data.frame(
  c(1985:2020),
  df2$pricakovana))

napoved.graf <- ggplot(pricakovanje) + geom_line(mapping = aes(x = c.1985.2020., y = df2.pricakovana), color = "red")+
  geom_line(mapping = aes(x = c.1985.2020., y = df2.pricakovana, color = c.1985.2020. <= 2019), show.legend = FALSE)+
  labs(
    x = "Leto",
    y = "Pričakovana življenjska doba",
    title = "Gibanje pričakovane življenjske dobe v Sloveniji in napoved za leto 2020"
  )

####
#samo da ugotovim korelacijo:
ggpairs(data.frame(X.norm))