library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(EnvStats)

countries <- c(
  "Denmark",
  "Italy",
  "Germany",
  "Spain",
  "United_Kingdom",
  "France",
  "Norway",
  "Belgium",
  "Austria",
  "Sweden",
  "Switzerland"
)

args = commandArgs(trailingOnly=TRUE)
if(length(args) == 0) {
  args = 'base'
}
StanModel = args[1]

print(sprintf("Running %s",StanModel))

## Reading all data
d=readRDS('data/COVID-19-up-to-date.rds')

## get CFR
cfr.by.country = read.csv("data/weighted_fatality.csv")
cfr.by.country$country = as.character(cfr.by.country[,2])
cfr.by.country$country[cfr.by.country$country == "United Kingdom"] = "United_Kingdom"

serial.interval = read.csv("data/serial_interval.csv")
covariates = read.csv('data/interventions.csv', stringsAsFactors = FALSE)
covariates <- covariates[1:11, c(1,2,3,4,5,6, 7, 8)]

## making all covariates that happen after lockdown to have same date as lockdown
covariates$schools_universities[covariates$schools_universities > covariates$lockdown] <- covariates$lockdown[covariates$schools_universities > covariates$lockdown]
covariates$travel_restrictions[covariates$travel_restrictions > covariates$lockdown] <- covariates$lockdown[covariates$travel_restrictions > covariates$lockdown]
covariates$public_events[covariates$public_events > covariates$lockdown] <- covariates$lockdown[covariates$public_events > covariates$lockdown]
covariates$sport[covariates$sport > covariates$lockdown] <- covariates$lockdown[covariates$sport > covariates$lockdown]
covariates$social_distancing_encouraged[covariates$social_distancing_encouraged > covariates$lockdown] <- covariates$lockdown[covariates$social_distancing_encouraged > covariates$lockdown]
covariates$self_isolating_if_ill[covariates$self_isolating_if_ill > covariates$lockdown] <- covariates$lockdown[covariates$self_isolating_if_ill > covariates$lockdown]

p <- ncol(covariates) - 1
forecast = 0

DEBUG = FALSE
if(DEBUG == FALSE) {
  N2 = 75 # Increase this for a further forecast
}  else  {
  ### For faster runs:
  # countries = c("Austria","Belgium") #,Spain")
  N2 = 75
}
# countries = c("Italy","United_Kingdom","Spain","Norway","Austria","Switzerland")

dates = list()
reported_cases = list()
stan_data = list(M=length(countries),N=NULL,p=p,x1=poly(1:N2,2)[,1],x2=poly(1:N2,2)[,2],
                 y=NULL,covariate1=NULL,covariate2=NULL,covariate3=NULL,covariate4=NULL,covariate5=NULL,covariate6=NULL,covariate7=NULL,deaths=NULL,f=NULL,
                 N0=6,cases=NULL,LENGTHSCALE=7,SI=serial.interval$fit[1:N2],
                 EpidemicStart = NULL) # N0 = 6 to make it consistent with Rayleigh
deaths_by_country = list()

for(Country in countries) {
  CFR=cfr.by.country$weighted_fatality[cfr.by.country$country == Country]

  covariates1 <- covariates[covariates$Country == Country, 2:8]

  d1=d[d$Countries.and.territories==Country,]
  d1$date = as.Date(d1$DateRep,format='%d/%m/%Y')
  d1$t = decimal_date(d1$date)
  d1=d1[order(d1$t),]
  index = which(d1$Cases>0)[1]
  index1 = which(cumsum(d1$Deaths)>=10)[1] # also 5
  index2 = index1-30

  print(sprintf("First non-zero cases is on day %d, and 30 days before 5 days is day %d",index,index2))
  d1=d1[index2:nrow(d1),]
  stan_data$EpidemicStart = c(stan_data$EpidemicStart,index1+1-index2)

  for (ii in 1:ncol(covariates1)) {
    covariate = names(covariates1)[ii]
    d1[covariate] <- (as.Date(d1$DateRep, format='%d/%m/%Y') >= as.Date(covariates1[1,covariate]))*1  # should this be > or >=?
  }

  dates[[Country]] = d1$date
  # hazard estimation
  N = length(d1$Cases)
  print(sprintf("%s has %d days of data",Country,N))
  forecast = N2 - N
  if(forecast < 0) {
    print(sprintf("%s: %d", Country, N))
    print("ERROR!!!! increasing N2")
    N2 = N
    forecast = N2 - N
  }

  h = rep(0,forecast+N) # discrete hazard rate from time t = 1, ..., 100
  if(DEBUG) { # OLD -- but faster for testing this part of the code
    mean = 18.8
    cv = 0.45

    for(i in 1:length(h))
      h[i] = (CFR*pgammaAlt(i,mean = mean,cv=cv) - CFR*pgammaAlt(i-1,mean = mean,cv=cv)) / (1-CFR*pgammaAlt(i-1,mean = mean,cv=cv))
  } else { # NEW
    mean1 = 5.1; cv1 = 0.86; # infection to onset
    mean2 = 18.8; cv2 = 0.45 # onset to death
    ## assume that CFR is probability of dying given infection
    x1 = rgammaAlt(5e6,mean1,cv1) # infection-to-onset ----> do all people who are infected get to onset?
    x2 = rgammaAlt(5e6,mean2,cv2) # onset-to-death
    f = ecdf(x1+x2)
    convolution = function(u) (CFR * f(u))

    h[1] = (convolution(1.5) - convolution(0))
    for(i in 2:length(h)) {
      h[i] = (convolution(i+.5) - convolution(i-.5)) / (1-convolution(i-.5))
    }
  }
  s = rep(0,N2)
  s[1] = 1
  for(i in 2:N2) {
    s[i] = s[i-1]*(1-h[i-1])
  }
  f = s * h

  y=c(as.vector(as.numeric(d1$Cases)),rep(-1,forecast))
  reported_cases[[Country]] = as.vector(as.numeric(d1$Cases))
  deaths=c(as.vector(as.numeric(d1$Deaths)),rep(-1,forecast))
  cases=c(as.vector(as.numeric(d1$Cases)),rep(-1,forecast))
  deaths_by_country[[Country]] = as.vector(as.numeric(d1$Deaths))
  covariates2 <- as.data.frame(d1[, colnames(covariates1)])
  # x=1:(N+forecast)
  covariates2[N:(N+forecast),] <- covariates2[N,]

  ## append data
  stan_data$N = c(stan_data$N,N)
  stan_data$y = c(stan_data$y,y[1]) # just the index case!
  # stan_data$x = cbind(stan_data$x,x)
  stan_data$covariate1 = cbind(stan_data$covariate1,covariates2[,1])
  stan_data$covariate2 = cbind(stan_data$covariate2,covariates2[,2])
  stan_data$covariate3 = cbind(stan_data$covariate3,covariates2[,3])
  stan_data$covariate4 = cbind(stan_data$covariate4,covariates2[,4])
  stan_data$covariate5 = cbind(stan_data$covariate5,covariates2[,5])
  stan_data$covariate6 = cbind(stan_data$covariate6,covariates2[,6])
  stan_data$covariate7 = cbind(stan_data$covariate7,covariates2[,7])
  stan_data$f = cbind(stan_data$f,f)
  stan_data$deaths = cbind(stan_data$deaths,deaths)
  stan_data$cases = cbind(stan_data$cases,cases)

  stan_data$N2=N2
  stan_data$x=1:N2
  if(length(stan_data$N) == 1) {
    stan_data$N = as.array(stan_data$N)
  }
}

stan_data$covariate2 = 0 * stan_data$covariate2 # remove travel bans
stan_data$covariate4 = 0 * stan_data$covariate5 # remove sport

#stan_data$covariate1 = stan_data$covariate1 # school closure
stan_data$covariate2 = stan_data$covariate7 # self-isolating if ill
#stan_data$covariate3 = stan_data$covariate3 # public events
# create the `any intervention` covariate
stan_data$covariate4 = 1*as.data.frame((stan_data$covariate1+
                                          stan_data$covariate3+
                                          stan_data$covariate5+
                                          stan_data$covariate6+
                                          stan_data$covariate7) >= 1)
stan_data$covariate5 = stan_data$covariate5 # lockdown
stan_data$covariate6 = stan_data$covariate6 # social distancing encouraged
stan_data$covariate7 = 0 # models should only take 6 covariates

if(DEBUG) {
  for(i in 1:length(countries)) {
    write.csv(
      data.frame(date=dates[[i]],
                 `school closure`=stan_data$covariate1[1:stan_data$N[i],i],
                 `self isolating if ill`=stan_data$covariate2[1:stan_data$N[i],i],
                 `public events`=stan_data$covariate3[1:stan_data$N[i],i],
                 `government makes any intervention`=stan_data$covariate4[1:stan_data$N[i],i],
                 `lockdown`=stan_data$covariate5[1:stan_data$N[i],i],
                 `social distancing encouraged`=stan_data$covariate6[1:stan_data$N[i],i]),
      file=sprintf("results/%s-check-dates.csv",countries[i]),row.names=F)
  }
}

stan_data$y = t(stan_data$y)
options(mc.cores = parallel::detectCores())
rstan_options(auto_write = TRUE)
m = stan_model(paste0('stan-models/',StanModel,'.stan'))

if(DEBUG) {
  fit = sampling(m,data=stan_data,iter=40,warmup=20,chains=2)
} else {
  # fit = sampling(m,data=stan_data,iter=4000,warmup=2000,chains=8,thin=4,control = list(adapt_delta = 0.90, max_treedepth = 10))
  fit = sampling(m,data=stan_data,iter=200,warmup=100,chains=4,thin=4,control = list(adapt_delta = 0.90, max_treedepth = 10))
}

out = rstan::extract(fit)
prediction = out$prediction
estimated.deaths = out$E_deaths
estimated.deaths.cf = out$E_deaths0

JOBID = Sys.getenv("PBS_JOBID")
if(JOBID == "")
  JOBID = as.character(abs(round(rnorm(1) * 1000000)))
print(sprintf("Jobid = %s",JOBID))

save.image(paste0('results/',StanModel,'-',JOBID,'.Rdata'))

save(fit,prediction,dates,reported_cases,deaths_by_country,countries,estimated.deaths,estimated.deaths.cf,out,covariates,file=paste0('results/',StanModel,'-',JOBID,'-stanfit.Rdata'))

# to visualize results
library(bayesplot)
filename <- paste0('base-',JOBID)
plot_labels <- c("School Closure",
                 "Self Isolation",
                 "Public Events",
                 "First Intervention",
                 "Lockdown", 'Social distancing')
alpha = (as.matrix(out$alpha))
colnames(alpha) = plot_labels
g = (mcmc_intervals(alpha, prob = .9))
ggsave(sprintf("results/%s-covars-alpha-log.pdf",filename),g,width=4,height=6)
g = (mcmc_intervals(alpha, prob = .9,transformations = function(x) exp(-x)))
ggsave(sprintf("results/%s-covars-alpha.pdf",filename),g,width=4,height=6)
mu = (as.matrix(out$mu))
colnames(mu) = countries
g = (mcmc_intervals(mu,prob = .9))
ggsave(sprintf("results/%s-covars-mu.pdf",filename),g,width=4,height=6)
dimensions <- dim(out$Rt)
Rt = (as.matrix(out$Rt[,dimensions[2],]))
colnames(Rt) = countries
g = (mcmc_intervals(Rt,prob = .9))
ggsave(sprintf("results/%s-covars-final-rt.pdf",filename),g,width=4,height=6)
system(paste0("Rscript plot-3-panel.r ", filename,'.Rdata'))
system(paste0("Rscript plot-forecast.r ",filename,'.Rdata')) ## to run this code you will need to adjust manual values of forecast required


library(np)
setwd("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/12_sinking-marbles-prior15/results/")

# load new priors
load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/26_sinking-marbles-prior15_replication/results/data/r.RData")
rnew = r
length(levels(as.factor(r$workerid)))

r = read.table("data/sinking_marbles.tsv", sep="\t", header=T)
r = r[,c("workerid", "rt", "effect", "cause", "object_level", "response", "object")]
#
r$Item = as.factor(paste(r$effect,r$object))

# combine datasets
d = merge(r,rnew,all=T)
summary(d)
r = d
summary(r)
r$workerid = as.factor(as.character(r$workerid))
length(levels(r$workerid))

# write data for mh's prior data analysis (fitting mixtures of binomials?)
write.table(r[,c("workerid","Item","response")],file="/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/bayesian_model_comparison/priors/data/priors.txt",row.names=F,col.names=T,quote=F,sep=",")

# write data for bayesian data analysis (fitting binomials to data in church)
tmp = ddply(r, .(Item), summarise, Responses=paste("(list ",paste(response,collapse=" "),")",sep=""))
head(tmp)
write.table(tmp[,c("Responses")],file="data/data_as_listoflists.txt",row.names=F,col.names=F,quote=F)

## plot subject variability
ggplot(r, aes(x=response)) +
  geom_histogram() +
  facet_wrap(~workerid)
ggsave(file="graphs/subject_variability.pdf",width=20,height=25)

# person 53 gave only one response -- exclude
r = droplevels(subset(r, workerid != "53"))

# how many judgments per item
min(table(r$Item))
max(table(r$Item))
t = as.data.frame(table(r$Item))
t[order(t[,c("Freq")]),]

## plot individual items
r$Item = as.factor(paste(r$effect,r$object))
ggplot(r, aes(x=response)) +
  geom_histogram() +
  facet_wrap(~Item)
ggsave(file="graphs/item_variability.pdf",width=20,height=15)

r$Bin = as.factor(ifelse(r$response == 0, 0, ifelse(r$response < 8, 50, ifelse(r$response < 15, 99, 100))))
ggplot(r, aes(x=Bin)) +
  geom_histogram() +
  facet_wrap(~Item)
ggsave(file="graphs/item_variability_binned.pdf",width=20,height=15)

save(r, file="data/r.RData")

sank = subset(r, effect == "sank" & object == "balloons")
sank
ds = density(sank$response,n=16,from=0,to=15)#,bw=5)#,bw=2)
plot(ds$x,ds$y)
sum(ds$x*ds$y)
str(ds)

ds = density(sank$response,n=16,from=0,to=15)#,bw=5)#,bw=2)
plot(ds$x,ds$y)

seeds = subset(r, effect == "ate the seeds" & object == "birds")
seeds
d = density(seeds$response,n=16,from=0,to=15)#,bw=2)
plot(d$x,d$y)
sum(d$x*d$y)

# playing around, figuring out np package
# tmp = data.frame(Response=ordered(seeds[,c("response")]))
# #tmp = ordered(tmp,levels=c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15))
# bw = npudensbw(tmp)
# summary(bw)
# dens = npudens(tdat=tmp,edat=ordered(c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15)))
# dens$dens
# sum(dens$dens)

ds = density(seeds$response,n=16,from=0,to=15)#,bw=5)#,bw=2)
plot(ds$x,ds$y)

felldown = subset(r, effect == "fell down" & object == "card towers")
felldown
df = density(felldown$response,n=16,from=0,to=15)#,bw=2)
plot(df$x,df$y)
sum(df$x*df$y)

expectations = ddply(r, .(effect,object), summarise, expectation=sum(density(response,n=16,from=0,to=15)$x*density(response,n=16,from=0,to=15)$y),densitysum=sum(density(response,n=16,from=0,to=15)$y))
expectations$expectation_corr = expectations$expectation/expectations$densitysum

# compute modes
modes = ddply(r, .(Item), summarise, Mode=getMode(response))
nrow(modes)
head(modes)
write.table(modes[,c("Item","Mode")],row.names=F,sep="\t",quote=F,file="data/modes.txt")

# compute expectations; still need to normalize in the end because sum of density typically isn't 1
cexpectations = ddply(r, .(effect,object), summarise, expectation=sum(npudens(tdat=ordered(response),edat=ordered(c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15)))$dens*seq(0,15)),densitysum=sum(npudens(tdat=ordered(response),edat=ordered(c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15)))$dens))

cexpectations$expectation_corr = cexpectations$expectation/cexpectations$densitysum
head(cexpectations)

plot(cexpectations$expectation_corr,expectations$expectation_corr)
cor(cexpectations$expectation_corr,expectations$expectation_corr)
cexpectations$old_expectation = expectations$expectation_corr
plot(cexpectations$expectation_corr,cexpectations$old_expectation)

cexpectations[cexpectations$expectation_corr > 14.5 & cexpectations$old_expectation < 10,]
# OK so this test definitely suggests the npudens function is better for these data than the density function: for the two items "sugar cubes dissolved" and "white shirts got stained", where everyone says all of them dissolved/got stained, the expectation with density is only 9.6, and with npudens it's 15 (after correcting, ie normalizing by sum of density)

mean(cexpectations$expectation_corr)
median(cexpectations$expectation_corr)

ggplot(cexpectations, aes(x=expectation_corr)) +
  geom_histogram() +
  scale_x_continuous()

head(cexpectations)
nrow(priors)
nrow(cexpectations)
write.table(cexpectations[,c("effect","object","expectation_corr")],row.names=F,sep="\t",quote=F,file="data/expectations.txt")
ordered = cexpectations[order(cexpectations[,c("expectation_corr")]),c("effect","object","expectation_corr")]
write.table(ordered[,c("effect","object","expectation_corr")],row.names=F,sep="\t",quote=F,file="data/ordered_expectations.txt")
t = table(r$Item)
t

library(plyr)
# get smoothed priors for model
smoothed_dist15 = ddply(r, .(Item), summarise, State = c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15),SmoothedProportion = (npudens(tdat=ordered(response),edat=ordered(c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15)))$dens+0.0000001)/sum(npudens(tdat=ordered(response),edat=ordered(c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15)))$dens+0.0000001))

head(smoothed_dist15)
summary(smoothed_dist15)
sum(smoothed_dist15[smoothed_dist15$Item == "ate the seeds birds",]$SmoothedProportion)

allprobs = smoothed_dist15[smoothed_dist15$State == 15,]
ggplot(allprobs, aes(x=SmoothedProportion)) +
  geom_histogram()

# add smoothed values to data.frame with empirical values

# get empirical unsmoothed priors
priors = as.data.frame(prop.table(table(r$Item,r$response),mar=c(1)))
head(priors)
priors[priors$Var1 == "ate the seeds butterflies",]$Freq
colnames(priors) = c("Item","State","EmpiricalProportion")
row.names(smoothed_dist15) = paste(smoothed_dist15$State,smoothed_dist15$Item)
priors$SmoothedProportion = smoothed_dist15[paste(priors$State, priors$Item),]$SmoothedProportion
head(priors)
plot(priors$SmoothedProportion,priors$EmpiricalProportion)

save(priors, file="data/priors.RData")

meltedpriors = melt(priors, measure.var=c("EmpiricalProportion","SmoothedProportion"),variable="ProportionType")
head(meltedpriors)

ggplot(meltedpriors, aes(x=State, y=value, color=ProportionType, group=ProportionType)) +
  geom_point() +
  geom_line() +
  facet_wrap(~Item)
ggsave(file="graphs/empirical-vs-smoothed-priors.pdf",width=20,height=15)

library(reshape2)
smoothed_dist15$SmoothedProportion = format(round(smoothed_dist15$SmoothedProportion,7), scientific=F)
casted = smoothed_dist15 %>%
  spread(State,SmoothedProportion)
write.table(casted,file="data/smoothed_15marbles_priors_withnames.txt",row.names=F,quote=F,sep="\t")
write.table(casted,file="../../../models/wonky_world/smoothed_15marbles_priors_withnames.txt",row.names=F,quote=F,sep="\t")
write.table(casted[,2:length(colnames(casted))],file="data/smoothed_15marbles_priors.txt",row.names=F,quote=F,sep="\t")
write.table(casted[,1],file="data/items.txt",row.names=F,quote=F,sep="\t")
write.table(casted[,2:length(colnames(casted))],file="../../../models/wonky_world/smoothed_15marbles_priors_withnames.txt",row.names=F,quote=F,sep="\t")

ordered = casted[order(casted[,c("15")]),c("effect","object","15")]
write.table(ordered,file="data/ordered_allstateprobs.txt",row.names=F,quote=F,sep="\t")

## plot individual items
r$Item = as.factor(paste(r$effect,r$object))
row.names(cexpectations) = paste(cexpectations$effect,cexpectations$object)
r$Expectation = cexpectations[as.character(r$Item),]$expectation_corr
ggplot(r, aes(x=response)) +
  geom_histogram() +
  geom_vline(aes(xintercept=Expectation),color="red",size=1) +
  facet_wrap(~Item)
ggsave(file="graphs/item_variability.pdf",width=20,height=15)

##### SMOOTH PRIORS WITH LAPLACE (ie add-1)
resps = seq(0,15)
rred = r[,c("response","Item")]
head(rred)
rred = rbind(rred,data.frame(response = rep(resps,90), Item = rep(levels(rred$Item),each=16)))
nrow(rred)
nrow(r[,c("response","Item")])

t = as.data.frame(table(rred$Item, rred$response))
head(t)
colnames(t) = c("Item","State","Frequency")
nrow(t)

smoothed_dist15 = ddply(t, .(Item), summarise, State=State, SmoothedProportion=Frequency/sum(Frequency))
head(smoothed_dist15,17)

# compute expectations; still need to normalize in the end because sum of density typically isn't 1
expectations = ddply(smoothed_dist15, .(Item), summarise, expectation=sum(as.numeric(as.character(State))*SmoothedProportion))
head(expectations)

mean(expectations$expectation)
median(expectations$expectation)

ggplot(expectations, aes(x=expectation)) +
  geom_histogram() +
  scale_x_continuous()

head(expectations)
nrow(expectations)
write.table(expectations[,c("Item","expectation")],row.names=F,sep="\t",quote=F,file="data/expectations_laplace.txt")

# add smoothed values to data.frame with empirical values

# get empirical unsmoothed priors
priors = as.data.frame(prop.table(table(r$Item,r$response),mar=c(1)))
head(priors)
priors[priors$Var1 == "ate the seeds butterflies",]$Freq
colnames(priors) = c("Item","State","EmpiricalProportion")
row.names(smoothed_dist15) = paste(smoothed_dist15$State,smoothed_dist15$Item)
priors$SmoothedProportion = smoothed_dist15[paste(priors$State, priors$Item),]$SmoothedProportion
head(priors)

save(priors, file="data/priors_laplace.RData")

meltedpriors = melt(priors, measure.var=c("EmpiricalProportion","SmoothedProportion"),variable="ProportionType")
head(meltedpriors)

ggplot(meltedpriors, aes(x=State, y=value, color=ProportionType, group=ProportionType)) +
  geom_point() +
  geom_line() +
  facet_wrap(~Item)
ggsave(file="graphs/empirical-vs-smoothed-priors-laplace.pdf",width=20,height=15)

library(reshape2)
smoothed_dist15$SmoothedProportion = format(round(smoothed_dist15$SmoothedProportion,7), scientific=F)
casted = dcast(smoothed_dist15, Item ~ State, value.var="SmoothedProportion")
write.table(casted,file="data/smoothed_15marbles_priors_withnames_laplace.txt",row.names=F,quote=F,sep="\t")
write.table(casted,file="../../../models/wonky_world/smoothed_15marbles_priors_withnames_laplace.txt",row.names=F,quote=F,sep="\t")
write.table(casted[,2:length(colnames(casted))],file="data/smoothed_15marbles_priors_laplace.txt",row.names=F,quote=F,sep="\t")
#write.table(casted[,1:2],file="data/items.txt",row.names=F,quote=F,sep="\t")
write.table(casted[,2:length(colnames(casted))],file="../../../models/wonky_world/smoothed_15marbles_priors_laplace.txt",row.names=F,quote=F,sep="\t")

## plot individual items
row.names(expectations) = expectations$Item
r$ExpectationLaplace = expectations[as.character(r$Item),]$expectation
ggplot(r, aes(x=response)) +
  geom_histogram() +
  geom_vline(aes(xintercept=ExpectationLaplace),color="red",size=1) +
  facet_wrap(~Item)
ggsave(file="graphs/item_variability_laplace.pdf",width=20,height=15)

# do minimal add-epsilon smoothing
t = as.data.frame(prop.table(table(r$response,r$Item),mar=c(2)))
t$Freq = t$Freq + .000001
colnames(t) = c("State","Item","Freq")
agr = t %>% spread(State, Freq)
write.table(agr,file="data/smoothed_15marbles_priors_epsilon.txt",row.names=F,quote=F,sep="\t")


plot_pcoa_3d <- function(
                         file_in,
                      #groups_in,
                         out_prefix = "Zhou_data_test",
                         my_colors = c('red'),
                         legend_colors = c('red'),
                      #names(legend_colors) <- c('red'),
                         figure_width = 10,
                         figure_height = 10,
                         figure_res = NA,
                         debug = FALSE,
                         PC1 = 1,
                         PC2 = 2,
                         PC3 = NA,
                         method_3d = "scatterplot3d"
                         )
  {

    ####################### CUSTOM SETTINGS #######################

    ## my_colors <- c(
    ##   "1CC.C082"="red",
    ##   "1CC.C085"="red",
    ##   "1CC.C156"="red",
    ##   "1CW.C089"="red",
    ##   "1CW.C096"="red",
    ##   "1CW.C136"="red",
    ##   "1UC.C141"="red",
    ##   "1UC.C149"="red",
    ##   "1UW.C153"="red",
    ##   "2CC.C139"="red",
    ##   "2CC.C154"="blue",
    ##   "2CW.C160"="blue",
    ##   "2UC.C074"="blue",
    ##   "2UC.C091"="blue",
    ##   "2UC.C093"="blue",
    ##   "2UW.C100"="blue",
    ##   "2UW.C126"="blue",
    ##   "2UW.C147"="blue",
    ##   "3CC.C081"="green",
    ##   "3CC.C086"="green",
    ##   "3CC.C116"="green",
    ##   "3CW.C090"="green",
    ##   "3CW.C102"="green",
    ##   "3CW.C151"="green",
    ##   "3UC.C066"="green",
    ##   "3UC.C140"="green",
    ##   "3UW.C101"="green",
    ##   "3UW.C143"="green",
    ##   "4CC.C125"="magenta",
    ##   "4CC.C150"="magenta",
    ##   "4CW.C084"="magenta",
    ##   "4CW.C130"="magenta",
    ##   "4UC.C099"="magenta",
    ##   "4UC.C159"="magenta",
    ##   "4UW.C077"="magenta",
    ##   "4UW.C128"="magenta",
    ##   "4UW.C144"="magenta",
    ##   "5CC.C157"="orange",
    ##   "5CC.C161"="orange",
    ##   "5CW.C075"="orange",
    ##   "5CW.C088"="orange",
    ##   "5CW.C132"="orange",
    ##   "5UC.C146"="orange",
    ##   "5UC.C162"="orange",
    ##   "5UW.C070"="orange",
    ##   "5UW.C098"="orange",
    ##   "6CC.C026"="cyan",
    ##   "6CC.C134"="cyan",
    ##   "6CW.C137"="cyan",
    ##   "6CW.C145"="cyan",
    ##   "6UC.C079"="cyan",
    ##   "6UC.C083"="cyan",
    ##   "6UC.C131"="cyan",
    ##   "6UW.C095"="cyan",
    ##   "6UW.C127"="cyan",
    ##   "6UW.C158"="cyan"
    ##   )

    ## legend_colors <- c ("red", "blue", "green", "magenta", "orange", "cyan")

    ## names (legend_colors) <- c ("1","2","3","4","5","6")

    ## my_pch <- c(
    ##          "1CC.C082"=21,
    ##          "1CC.C085"=21,
    ##          "1CC.C156"=21,
    ##          "1CW.C089"=22,
    ##          "1CW.C096"=22,
    ##          "1CW.C136"=22,
    ##          "1UC.C141"=23,
    ##          "1UC.C149"=23,
    ##          "1UW.C153"=24,
    ##          "2CC.C139"=21,
    ##          "2CC.C154"=21,
    ##          "2CW.C160"=22,
    ##          "2UC.C074"=23,
    ##          "2UC.C091"=23,
    ##          "2UC.C093"=23,
    ##          "2UW.C100"=24,
    ##          "2UW.C126"=24,
    ##          "2UW.C147"=24,
    ##          "3CC.C081"=21,
    ##          "3CC.C086"=21,
    ##          "3CC.C116"=21,
    ##          "3CW.C090"=22,
    ##          "3CW.C102"=22,
    ##          "3CW.C151"=22,
    ##          "3UC.C066"=23,
    ##          "3UC.C140"=23,
    ##          "3UW.C101"=24,
    ##          "3UW.C143"=24,
    ##          "4CC.C125"=21,
    ##          "4CC.C150"=21,
    ##          "4CW.C084"=21,
    ##          "4CW.C130"=22,
    ##          "4UC.C099"=23,
    ##          "4UC.C159"=23,
    ##          "4UW.C077"=24,
    ##          "4UW.C128"=24,
    ##          "4UW.C144"=24,
    ##          "5CC.C157"=21,
    ##          "5CC.C161"=21,
    ##          "5CW.C075"=22,
    ##          "5CW.C088"=22,
    ##          "5CW.C132"=22,
    ##          "5UC.C146"=23,
    ##          "5UC.C162"=23,
    ##          "5UW.C070"=24,
    ##          "5UW.C098"=24,
    ##          "6CC.C026"=21,
    ##          "6CC.C134"=21,
    ##          "6CW.C137"=22,
    ##          "6CW.C145"=22,
    ##          "6UC.C079"=23,
    ##          "6UC.C083"=23,
    ##          "6UC.C131"=23,
    ##          "6UW.C095"=24,
    ##          "6UW.C127"=24,
    ##          "6UW.C158"=24
    ##          )

    my_colors <- c(
      "1CC.C082"="red",
      "1CC.C085"="red",
      "1CC.C156"="red",
      "1CW.C089"="blue",
      "1CW.C096"="blue",
      "1CW.C136"="blue",
      "1UC.C141"="green",
      "1UC.C149"="green",
      "1UW.C153"="magenta",
      "2CC.C139"="red",
      "2CC.C154"="red",
      "2CW.C160"="blue",
      "2UC.C074"="green",
      "2UC.C091"="green",
      "2UC.C093"="green",
      "2UW.C100"="magenta",
      "2UW.C126"="magenta",
      "2UW.C147"="magenta",
      "3CC.C081"="red",
      "3CC.C086"="red",
      "3CC.C116"="red",
      "3CW.C090"="blue",
      "3CW.C102"="blue",
      "3CW.C151"="blue",
      "3UC.C066"="green",
      "3UC.C140"="green",
      "3UW.C101"="magenta",
      "3UW.C143"="magenta",
      "4CC.C125"="red",
      "4CC.C150"="red",
      "4CW.C084"="blue",
      "4CW.C130"="blue",
      "4UC.C099"="green",
      "4UC.C159"="green",
      "4UW.C077"="magenta",
      "4UW.C128"="magenta",
      "4UW.C144"="magenta",
      "5CC.C157"="red",
      "5CC.C161"="red",
      "5CW.C075"="blue",
      "5CW.C088"="blue",
      "5CW.C132"="blue",
      "5UC.C146"="green",
      "5UC.C162"="green",
      "5UW.C070"="magenta",
      "5UW.C098"="magenta",
      "6CC.C026"="red",
      "6CC.C134"="red",
      "6CW.C137"="blue",
      "6CW.C145"="blue",
      "6UC.C079"="green",
      "6UC.C083"="green",
      "6UC.C131"="green",
      "6UW.C095"="magenta",
      "6UW.C127"="magenta",
      "6UW.C158"="magenta"
      )

    my_pch = 21

    legend_colors <- c ("red", "blue", "green", "magenta")

    names (legend_colors) <- c ("CC","CW","UC","UW")

    ## my_colors <- c(
    ##                "Ca"="green",
    ##                "Cb"="green",
    ##                "Cc"="green",
    ##                "Cd"="green",
    ##                "Ce"="green",
    ##                "Ch1a"="purple",
    ##                "Ch1b"="purple",
    ##                "Ch1c"="purple",
    ##                "Ch1d"="purple",
    ##                "Ch1e"="purple",
    ##                "Ch2a"="purple",
    ##                "Ch2b"="purple",
    ##                "Ch2c"="purple",
    ##                "Ch2d"="purple",
    ##                "Ch2e"="purple",
    ##                "Ch3a"="purple",
    ##                "Ch3b"="purple",
    ##                "Ch3c"="purple",
    ##                "Ch3d"="purple",
    ##                "Ch3e"="purple",
    ##                "Ch4a"="purple",
    ##                "Ch4b"="purple",
    ##                "Ch4c"="purple",
    ##                "Ch4d"="purple",
    ##                "Ch4e"="purple",
    ##                "Ch5a"="purple",
    ##                "Ch5b"="purple",
    ##                "Ch5c"="purple",
    ##                "Ch5d"="purple",
    ##                "Ch5e"="purple",
    ##                "E1a"="blue",
    ##                "E1b"="blue",
    ##                "E1c"="blue",
    ##                "E1d"="blue",
    ##                "E1e"="blue",
    ##                "Ra"="orange",
    ##                "Rb"="orange",
    ##                "Rc"="orange",
    ##                "Rd"="orange",
    ##                "Re"="orange",
    ##                "Wa"="brown",
    ##                "Wb"="brown",
    ##                "Wc"="brown",
    ##                "Wd"="brown",
    ##                "We"="brown"
    ##                )

    ## legend_colors <- c ("blue", "green", "purple", "orange", "brown")

    ## names (legend_colors) <- c ("E1","C","Ch","R", "W")

     # OLD VERSION THAT WORKS
      ## points(x=((sorted_my_data[,PC1])[1:5]), y=((sorted_my_data[,PC2])[1:5]), pch=23, col="green", bg = "green", cex=my_cex) #C
      ## points([6:10]), y=((sorted_my_data[,PC2])[6:10]), pch=21, col="purple", bg = "purple", cex=my_cex) #ch1
      ## points(x=((sorted_my_data[,PC1])[11:15]), y=((sorted_my_data[,PC2])[11:15]), pch=22, col="purple", bg = "purple", cex=my_cex) #ch2
      ## points(x=((sorted_my_data[,PC1])[16:20]), y=((sorted_my_data[,PC2])[16:20]), pch=23, col="purple", bg = "purple", cex=my_cex) #ch3
      ## points(x=((sorted_my_data[,PC1])[21:25]), y=((sorted_my_data[,PC2])[21:25]), pch=24, col="purple", bg = "purple", cex=my_cex) #ch4
      ## points(x=((sorted_my_data[,PC1])[26:30]), y=((sorted_my_data[,PC2])[26:30]), pch=25, col="purple", bg = "purple", cex=my_cex) #ch5
      ## points(x=((sorted_my_data[,PC1])[31:35]), y=((sorted_my_data[,PC2])[31:35]), pch=21, col="blue", bg = "blue", cex=my_cex) #E1
      ## points(x=((sorted_my_data[,PC1])[36:40]), y=((sorted_my_data[,PC2])[36:40]), pch="X", col="orange", bg = "orange", cex=0.7*my_cex, lwd=3) #R
      ## points(x=((sorted_my_data[,PC1])[41:45]), y=((sorted_my_data[,PC2])[41:45]), pch="+", col="brown", bg = "brown", cex=my_cex, lwd=3) #W

    ###############################################################

    if(debug==TRUE){print("made it here 1")}
    ######################################################### MAIN #########################################################
    # read file_in into a list
    con <- file(file_in)
    num_lines <- length(readLines(con))
    if(debug==TRUE){print(paste("num_lines:", num_lines))}
    open(con)
    results.list <<- list();
    current.line <- 1
    while (length(line <- readLines(con, n = 1, warn = FALSE)) > 0) {
      results.list[[current.line]] <<- line
      current.line <- current.line + 1
    }
    close(con)

    # parse file_in into Eigen values and Eigen vectors
    num_eigen_values <- length(grep("PC", results.list)) # need to figure out how to do emty line regex in R ...

    eigen_value.list <<- vector("list", num_eigen_values)
    eigen_vector.list <<- vector("list", num_eigen_values)
    value.count <- 1
    vector.count <- 1

    if(debug==TRUE){print("made it here 2")}

    for (i in 1:num_lines){
      my_line <<- noquote(results.list[i])

      if (any(grep("^#", my_line))==TRUE){
      }else{
        if (any(grep("PC", my_line))==TRUE){ # pull out the eigen value
          eigen_value.list[value.count] <<- my_line
          value.count <- value.count + 1
          if(debug==TRUE){print(paste("PC", my_line))}
        }else if (any(grep("[0-9]", my_line))==TRUE){ # pull out the eigen vectors
          eigen_vector.list[vector.count] <<- my_line
          vector.count <- vector.count + 1
        }else{print("encountered empty variable")}

      }
    }

    if(debug==TRUE){print("made it here 3")}

    # Split list of eigen vectors into a vector
    vector_list <<- strsplit(as.character(eigen_vector.list), split="\t")

    my_names <<- vector("list", num_eigen_values)
    for (i in 1:num_eigen_values){
      my_names[i] <<- vector_list[[i]][1]
    }

    my_data <<- matrix(ncol = num_eigen_values, nrow = num_eigen_values)
    for (i in 1:num_eigen_values){
      for (j in 1:num_eigen_values){
        my_data[i,j] <<- vector_list[[i]][j+1]
      }
    }

    if(debug==TRUE){print("made it here 4")}

    rownames(my_data) <<- my_names

    eigen_value.names <<- vector("list", num_eigen_values)
    for (i in 1:num_eigen_values){
      pcName_pcEigen <- unlist(strsplit(as.character(eigen_value.list[i]), split="\t"))
      pcName <- gsub("\"", "", (pcName_pcEigen[1]))
      pcEigen <- gsub(" ", "", paste(  (round( as.numeric(pcName_pcEigen[2]), digits = 4))*100, "%"))
      eigen_value.names[i] <<- paste( pcName, "::", pcEigen, "of observed variation")
    }

    if(debug==TRUE){print("made it here 5")}

    sorted_my_data <- my_data[order(rownames(my_data)), ]

    colnames(sorted_my_data) <- eigen_value.names

    write.table(sorted_my_data, file = "PCoA_sorted_data.txt", col.names=NA, row.names = TRUE, sep="\t", quote=FALSE)
    # use this table to double check point/ color ordering

    if(debug==TRUE){print("made it here 6")}

    my_sample_names <- as.vector( gsub("\"", "", rownames(sorted_my_data)), mode="character")
    my_ordered_colors <- ( my_colors[ my_sample_names[1:length(my_sample_names)] ])

    if (  length(my_pch) > 1 ){
      my_ordered_pch <-  ( my_pch[ my_sample_names[1:length(my_sample_names)] ])
    }else{
      my_ordered_pch <- my_pch
    }

    if(debug==TRUE){print(my_sample_names)}
    if(debug==TRUE){print(my_ordered_colors)}

    if(debug==TRUE){print("made it here 7")}

    ########################### PLOT 2d  ##########################
    if(identical(PC3, NA)){ # plot in 2d

      image_out <- gsub(" ", "", (paste(out_prefix, ".2d_plot.pdf")))
      legend_out <- gsub(" ", "", (paste(out_prefix, ".legend.pdf")))

      if(debug==TRUE){print("made it here 8")}

      pdf(file=image_out, width = figure_width, height = figure_height)

      plot(
           x = sorted_my_data[,PC1],
           y = sorted_my_data[,PC2],
           type="n",
           xlab = eigen_value.names[PC1],
           ylab = eigen_value.names[PC2],
           cex = 0.8
           )
      my_cex <- 1.2

      if(debug==TRUE){print("made it here 9")}

      points(
             x=(sorted_my_data[,PC1]),
             y=(sorted_my_data[,PC2]),
             pch=my_ordered_pch,
             col=my_ordered_colors,
             bg=my_ordered_colors,
             cex=my_cex
             )

      if(debug==TRUE){print("made it here 10")}

      title( (paste(out_prefix,"\n", "PC", PC1, "vs PC", PC2 )), cex.main = 0.8)
      dev.off()

      if(debug==TRUE){print("made it here 11")}

      # produce a speparte figure with the legend
      pdf (file=legend_out, width = 2, height = 4)
      plot.new ()
      legend (0, 1, legend = names(legend_colors), pch = 18, col = legend_colors )
      dev.off ()

    }
    ###############################################################

    ########################### PLOT 3d  ##########################

    if(!(identical(PC3, NA))){ # create 3d rendering with scatterplot3d (pdf) or rgl (interactive image)

      image_out <- gsub(" ", "", (paste(out_prefix, ".3d_plot.pdf")))
      legend_out <- gsub(" ", "", (paste(out_prefix, ".legend.pdf")))

      if(identical(method_3d, "scatterplot3d")){

        require(scatterplot3d)

        # scaling for the axes -- autoscaling stinks
        x_range <- as.numeric(range(sorted_my_data[,PC1])[2]) - as.numeric(range(sorted_my_data[,PC1])[1])
        x_lim_max <- ( as.numeric(range(sorted_my_data[,PC1])[2]) + 0.25*x_range)
        x_lim_min <- ( as.numeric(range(sorted_my_data[,PC1])[1]) - 0.25*x_range)

        y_range <- as.numeric(range(sorted_my_data[,PC2])[2]) - as.numeric(range(sorted_my_data[,PC2])[1])
        y_lim_max <- ( as.numeric(range(sorted_my_data[,PC2])[2]) + 0.25*y_range)
        y_lim_min <- ( as.numeric(range(sorted_my_data[,PC2])[1]) - 0.25*y_range)

        z_range <- as.numeric(range(sorted_my_data[,PC3])[2]) - as.numeric(range(sorted_my_data[,PC3])[1])
        z_lim_max <- ( as.numeric(range(sorted_my_data[,PC3])[2]) + 0.25*z_range)
        z_lim_min <- ( as.numeric(range(sorted_my_data[,PC3])[1]) - 0.25*z_range)

        pdf(file=image_out, width = figure_width, height = figure_height)
        my_3d_plot <- scatterplot3d(
                                    x<-sorted_my_data[,PC1],
                                    #xlim = c( x_lim_min, x_lim_max ),
                                    y<-sorted_my_data[,PC2],
                                    #ylim = c( y_lim_min, y_lim_max ),
                                    z<-sorted_my_data[,PC3],
                                    #zlim = c( z_lim_min, z_lim_max ),
                                    type="n",
                                    xlab = eigen_value.names[PC1],
                                    ylab = eigen_value.names[PC2],
                                    zlab = eigen_value.names[PC3],
                                    cex.axis = 0.8
                                    )
        my_cex <- 1.2

        my_3d_plot$points3d(
                 x=((sorted_my_data[,PC1])),
                 y=((sorted_my_data[,PC2])),
                 z=((sorted_my_data[,PC3])),
                 pch=my_ordered_pch,
                 col=my_ordered_colors,
                 bg=my_ordered_colors,
                 cex=my_cex
                 )

        ## my_3d_plot$points3d(x=((sorted_my_data[,PC1])[1:5]), y=((sorted_my_data[,PC2])[1:5]), z=((sorted_my_data[,PC3])[1:5]), pch=23, col="green", bg = "green", cex=my_cex)#C
        ## my_3d_plot$points3d(x=((sorted_my_data[,PC1])[6:10]), y=((sorted_my_data[,PC2])[6:10]), z=((sorted_my_data[,PC3])[1:5]), pch=21, col="purple", bg = "purple", cex=my_cex) #ch1
        ## my_3d_plot$points3d(x=((sorted_my_data[,PC1])[11:15]), y=((sorted_my_data[,PC2])[11:15]), z=((sorted_my_data[,PC3])[1:5]), pch=22, col="purple", bg = "purple", cex=my_cex) #ch2
        ## my_3d_plot$points3d(x=((sorted_my_data[,PC1])[16:20]), y=((sorted_my_data[,PC2])[16:20]), z=((sorted_my_data[,PC3])[1:5]), pch=23, col="purple", bg = "purple", cex=my_cex) #ch3
        ## my_3d_plot$points3d(x=((sorted_my_data[,PC1])[21:25]), y=((sorted_my_data[,PC2])[21:25]), z=((sorted_my_data[,PC3])[1:5]), pch=24, col="purple", bg = "purple", cex=my_cex) #ch4
        ## my_3d_plot$points3d(x=((sorted_my_data[,PC1])[26:30]), y=((sorted_my_data[,PC2])[26:30]), z=((sorted_my_data[,PC3])[1:5]), pch=25, col="purple", bg = "purple", cex=my_cex) #ch5
        ## my_3d_plot$points3d(x=((sorted_my_data[,PC1])[31:35]), y=((sorted_my_data[,PC2])[31:35]), z=((sorted_my_data[,PC3])[1:5]), pch=21, col="blue", bg = "blue", cex=my_cex) #E1
        ## my_3d_plot$points3d(x=((sorted_my_data[,PC1])[36:40]), y=((sorted_my_data[,PC2])[36:40]), z=((sorted_my_data[,PC3])[1:5]), pch="X", col="orange", bg = "orange", cex=0.7*my_cex, lwd=3) #R
        ## my_3d_plot$points3d(x=((sorted_my_data[,PC1])[41:45]), y=((sorted_my_data[,PC2])[41:45]), z=((sorted_my_data[,PC3])[1:5]), pch="+", col="brown", bg = "brown", cex=my_cex, lwd=3) #W

        title( (paste(out_prefix,"\n", "PC", PC1, "vs PC", PC2 , "vs PC", PC3 )), cex.main = 0.8)
        dev.off()

        pdf (file=legend_out) #, width = 2, height = 4)

        plot.new ()
        legend (0, 1, legend = names (legend_colors), pch = 18, col = legend_colors )
        dev.off ()

        ## scatterplot3d(x, y=NULL, z=NULL, color=par("col"), pch=NULL,
        ##               main=NULL, sub=NULL, xlim=NULL, ylim=NULL, zlim=NULL,
        ##               xlab=NULL, ylab=NULL, zlab=NULL, scale.y=1, angle=40,
        ##               axis=TRUE, tick.marks=TRUE, label.tick.marks=TRUE,
        ##               x.ticklabs=NULL, y.ticklabs=NULL, z.ticklabs=NULL,
        ##               y.margin.add=0, grid=TRUE, box=TRUE, lab=par("lab"),
        ##               lab.z=mean(lab[1:2]), type="p", highlight.3d=FALSE,
        ##               mar=c(5,3,4,3)+0.1, col.axis=par("col.axis"),
        ##               col.grid="grey", col.lab=par("col.lab"),
        ##               cex.symbols=par("cex"), cex.axis=0.8 * par("cex.axis"),
        ##               cex.lab=par("cex.lab"), font.axis=par("font.axis"),
        ##               font.lab=par("font.lab"), lty.axis=par("lty"),
        ##               lty.grid=par("lty"), lty.hide=NULL, lty.hplot=par("lty"),
        ##               log="", ...)
      }

      if (identical(method_3d, "rgl")){

        require(rgl)

        open3d()

        x<-sorted_my_data[,PC1]
        y<-sorted_my_data[,PC2]
        z<-sorted_my_data[,PC3]

        my_colors <- c(

                       )

        plot3d(
               x,
               y,
               z,
               #xlab = "test",
               xlab = paste("(x)", eigen_value.names[PC1]),
               ylab = paste("(y)", eigen_value.names[PC2]),
               zlab = paste("(z)", eigen_value.names[PC3]),
               col=my_colors,
               radius = 100
               )

        rgl.sprites(x,y,z,radius=1000,color=cols)

        #rgl.postscript("persp3dd.pdf","pdf")

        ##  rgl.plot3d<-function(z, x, y, cols="red",axes=T,new=T)
        ##   {xr<-range(x)
        ##    x01<-(x-xr[1])/(xr[2]-xr[1])
        ##    yr<-range(y)
        ##    y01<-(y-yr[1])/(yr[2]-yr[1])
        ##    zr<-range(z)
        ##    z01<-(z-zr[1])/(zr[2]-zr[1])

        ##    if(new) rgl.clear()
        ##    if(axes)
        ##      {xlab<-pretty(x)
        ##       ylab<-pretty(y)
        ##       zlab<-pretty(z)
        ##       xat<-(xlab-xr[1])/(xr[2]-xr[1])
        ##       yat<-(ylab-yr[1])/(yr[2]-yr[1])
        ##       zat<-(zlab-zr[1])/(zr[2]-zr[1])
        ##       rgl.lines(c(0,1.1),0,0)
        ##       rgl.lines(0,c(0,1.1),0)
        ##       rgl.lines(0,0,c(0,1.1))
        ##       rgl.texts(xat,-.05,-.05,xlab)
        ##       rgl.texts(-.05,yat,-.05,ylab)
        ##       rgl.texts(-.05,-.05,zat,zlab)
        ##       rgl.texts(c(0.5,-.15,-.15),c(-.15,.5,-.15),c(-.15,-.15,.5),
        ##                 c(deparse(substitute(x)),deparse(substitute(y)),deparse(substitute(z))))
        ##     }

        ##    rgl.spheres(x01,y01,z01,.01,color=cols)
        ##  }

#sprites
        ## rgl.plot3d(sorted_my_data[,PC3],sorted_my_data[,PC1],sorted_my_data[,PC2])

        ## iris.pc<-prcomp(iris[,1:4],scale=T)
        ## rgl.plot3d(iris.pc$x[,1],iris.pc$x[,2],iris.pc$x[,3])
        ## # different colors
        ## rgl.plot3d(iris.pc$x[,1],iris.pc$x[,2],iris.pc$x[,3],col=unclass(iris[,5])+1)

        ## ### https://stat.ethz.ch/pipermail/r-help/2008-May/161202.html
        ## #Install library rgl
        ## #here is the is the function:
        ## rgl.plot3d<-function(z, x, y, cols="red",axes=T,new=T)
        ##   {xr<-range(x)
        ##    x01<-(x-xr[1])/(xr[2]-xr[1])
        ##    yr<-range(y)
        ##    y01<-(y-yr[1])/(yr[2]-yr[1])
        ##    zr<-range(z)
        ##    z01<-(z-zr[1])/(zr[2]-zr[1])

        ##    if(new) rgl.clear()
        ##    if(axes)
        ##      {xlab<-pretty(x)
        ##       ylab<-pretty(y)
        ##       zlab<-pretty(z)
        ##       xat<-(xlab-xr[1])/(xr[2]-xr[1])
        ##       yat<-(ylab-yr[1])/(yr[2]-yr[1])
        ##       zat<-(zlab-zr[1])/(zr[2]-zr[1])
        ##       rgl.lines(c(0,1.1),0,0)
        ##       rgl.lines(0,c(0,1.1),0)
        ##       rgl.lines(0,0,c(0,1.1))
        ##       rgl.texts(xat,-.05,-.05,xlab)
        ##       rgl.texts(-.05,yat,-.05,ylab)
        ##       rgl.texts(-.05,-.05,zat,zlab)
        ##       rgl.texts(c(0.5,-.15,-.15),c(-.15,.5,-.15),c(-.15,-.15,.5),
        ##                 c(deparse(substitute(x)),deparse(substitute(y)),deparse(substitute(z))))
        ##     }

        ##    rgl.spheres(x01,y01,z01,.01,color=cols)
        ##  }

        ## #and here is how you call it
        ## library(rgl)
        ## data(iris)

        ## iris.pc<-prcomp(iris[,1:4],scale=T)
        ## rgl.plot3d(iris.pc$x[,1],iris.pc$x[,2],iris.pc$x[,3])
        ## # different colors
        ## rgl.plot3d(iris.pc$x[,1],iris.pc$x[,2],iris.pc$x[,3],col=unclass(iris[,5])+1)

        ###########################################################################

        ## ### https://stat.ethz.ch/pipermail/r-help/2008-May/161202.html
        ## #Install library rgl
        ## #here is the is the function:
        ## rgl.plot3d<-function(z, x, y, cols="red",axes=T,new=T)
        ##   {xr<-range(x)
        ##    x01<-(x-xr[1])/(xr[2]-xr[1])
        ##    yr<-range(y)
        ##    y01<-(y-yr[1])/(yr[2]-yr[1])
        ##    zr<-range(z)
        ##    z01<-(z-zr[1])/(zr[2]-zr[1])

        ##    if(new) rgl.clear()
        ##    if(axes)
        ##      {xlab<-pretty(x)
        ##       ylab<-pretty(y)
        ##       zlab<-pretty(z)
        ##       xat<-(xlab-xr[1])/(xr[2]-xr[1])
        ##       yat<-(ylab-yr[1])/(yr[2]-yr[1])
        ##       zat<-(zlab-zr[1])/(zr[2]-zr[1])
        ##       rgl.lines(c(0,1.1),0,0)
        ##       rgl.lines(0,c(0,1.1),0)
        ##       rgl.lines(0,0,c(0,1.1))
        ##       rgl.texts(xat,-.05,-.05,xlab)
        ##       rgl.texts(-.05,yat,-.05,ylab)
        ##       rgl.texts(-.05,-.05,zat,zlab)
        ##       rgl.texts(c(0.5,-.15,-.15),c(-.15,.5,-.15),c(-.15,-.15,.5),
        ##                 c(deparse(substitute(x)),deparse(substitute(y)),deparse(substitute(z))))
        ##     }

        ##    rgl.spheres(x01,y01,z01,.01,color=cols)
        ##  }

        ## #and here is how you call it
        ## library(rgl)
        ## data(iris)

        ## iris.pc<-prcomp(iris[,1:4],scale=T)
        ## rgl.plot3d(iris.pc$x[,1],iris.pc$x[,2],iris.pc$x[,3])
        ## # different colors
        ## rgl.plot3d(iris.pc$x[,1],iris.pc$x[,2],iris.pc$x[,3],col=unclass(iris[,5])+1)

      }

    } # close 3d loop

  } # close function


library(tidyverse)

setwd("F:/SS18/Kurse/PsyLab/")
#setwd("/data/Share/SS18/Kurse/PsyLab")
#setwd("C:/Users/tillh/Desktop/Programming/R/Homework")

# read the data
d = readr::read_csv("results_final.csv") %>%
  # only look at main trials
  filter(block != "practice") %>%
  # kick out all participants with less than 85% correct in the main trials
  group_by(submission_id) %>% mutate(correctnessScore = mean(ifelse(correct == 'true', 1, 0))) %>%
  filter(correctnessScore > 0.85) %>% ungroup() %>%
  # only look at correct trials (correct==true) and kick out catch trials (target!=false)
  filter(correct == "true" & target != "false") %>%
  # change some columns to be in the right format
  mutate(org = as.integer(org),
         timeBCT = as.factor(timeBCT),
         orgPrime = org,
         target = as.integer(target),
         targetPrime = target
         ) %>%
  # get the main conditions valid_cue vs invalid_cue
  mutate(conditionCue = factor(
    case_when( orgPrime == targetPrime ~ "valid_cue",
               TRUE ~ "invalid_cue"),
    ordered = T, levels = c("valid_cue", "invalid_cue"))) %>%
  # get the condition left vs right visual field
  mutate(conditionField = factor(
    case_when((targetPrime == 0 | targetPrime == 4) ~ "left_field",
              TRUE ~ "right_field"),
    ordered = T, levels = c("left_field", "right_field"))) %>%
  # get the condition horizontal vs vertical orientation
  mutate(conditionOrientation = factor(
    case_when(rotate == "false" ~ "vertical",
              TRUE ~ "horizontal"),
    ordered = T, levels = c("horizontal", "vertical")))

# remove outliers
d_clean = d  %>% group_by(conditionCue, conditionField, conditionOrientation) %>%
  # kick out fastest 2.5% for all three main conditions (conditionCue, conditionField, conditionOrientation)
  # and kick out slowest 2.5% for all conditions
  mutate(outlier = ifelse(log(RT) > quantile(log(RT), probs = 0.975), 1,
                          ifelse(log(RT) < quantile(log(RT), probs = 0.025), 1, 0))) %>% ungroup() %>%
  filter(outlier == 0)

# summarize the RTs
dsummary = d_clean %>% group_by(conditionCue, conditionField, conditionOrientation, timeBCT) %>%
  summarize(meanRT = mean(RT)) %>%
  ungroup()
dsummary

meanCue = d_clean %>% #group_by(conditionCue) %>%
  summarize(meanRT = mean(RT)) %>%
  ungroup()
meanCue

# plot condition valid cue vs invalid cue
ggplot(d_clean, aes(y = log(RT), x = conditionCue)) + geom_violin()
ggplot(d_clean, aes(x = log(RT), color = conditionCue)) + geom_density()

ggplot(d_clean, aes(x = happy, color = happy)) + geom_density()

# plot condition left_field vs right_field
ggplot(d_clean, aes(y = log(RT), x = conditionField)) + geom_violin()
ggplot(d_clean, aes(x = log(RT), color = conditionField)) + geom_density()

# plot condition horizontal vs vertical orientation
ggplot(d_clean, aes(y = log(RT), x = conditionOrientation)) + geom_violin()
ggplot(d_clean, aes(x = log(RT), color = conditionOrientation)) + geom_density()

# plot condition timeBCT
ggplot(d_clean, aes(y = log(RT), x = timeBCT)) + geom_violin()
ggplot(d_clean, aes(x = log(RT), color = timeBCT)) + geom_density()

# do a linear model to predict log RT
# valid_cue vs invalid_cue, left vs right and horizontal vs vertical and timeBCT
modLM = lm(log(RT) ~ conditionCue + conditionField + conditionOrientation + timeBCT, data = d_clean)
summary(modLM)

# check if all combinations of conditions are normal distributed
qqnorm(modLM$residuals)
qqline(modLM$residuals)

######################SECOND ANALYSIS ONLY INVALID CUES###########################

# second analysis only for the invalid cues
d_invalid = d %>%
  # kick out all valid_cues
  filter(conditionCue == "invalid_cue") %>%
  # divide invalid_cue in between_object (cued) and within_object (uncued)
  mutate(conditionRectangle = factor(
    case_when((rotate == "false" & abs(orgPrime - targetPrime) > 1)
              | (rotate == "true" & abs(orgPrime - targetPrime) == 1) ~ "within_object",
              TRUE ~ "between_object"),
    ordered = T, levels = c("within_object", "between_object"))) %>%
  # divide invalid_cue in between_field (horizontal) and within_field (vertical)
  mutate(conditionShift = factor(
    case_when((rotate == "false" & conditionRectangle == "within_object")
              | (rotate == "true" & conditionRectangle == "between_object") ~ "vertical_shift",
              TRUE ~ "horizontal_shift"),
    ordered = T, levels = c("vertical_shift", "horizontal_shift")))

# remove outliers
d_invalid_clean = d_invalid %>% group_by(conditionField, conditionRectangle, conditionShift) %>%
  # kick out fastest 2.5% for all three main conditions (conditionField, conditionRectangle, conditionShift)
  # and kick out slowest 2.5% for all conditions
  mutate(outlier = ifelse(log(RT) > quantile(log(RT), probs = 0.975), 1,
                          ifelse(log(RT) < quantile(log(RT), probs = 0.025), 1, 0))) %>% ungroup() %>%
  filter(outlier == 0)

# summarize the RTs
d_invalid_summary = d_invalid_clean %>% group_by(conditionRectangle, conditionField, conditionShift) %>%
  summarize(meanRT = mean(RT)) %>%
  ungroup()
d_invalid_summary

# plot condition between_object vs within_object
ggplot(d_invalid_clean, aes(y = log(RT), x = conditionRectangle)) + geom_violin()
ggplot(d_invalid_clean, aes(x = log(RT), color = conditionRectangle)) + geom_density()

# plot condition left_field vs right_field
ggplot(d_invalid_clean, aes(y = log(RT), x = conditionField)) + geom_violin()
ggplot(d_invalid_clean, aes(x = log(RT), color = conditionField)) + geom_density()

# plot condition horizontal vs vertical shift
ggplot(d_invalid_clean, aes(y = log(RT), x = conditionShift)) + geom_violin()
ggplot(d_invalid_clean, aes(x = log(RT), color = conditionShift)) + geom_density()

# do a linear model to predict log RT
# between_object vs within_object, left_field vs right_field and horizontal_shift vs vertical_shift
modInvalidLM = lm(log(RT) ~ conditionRectangle + conditionField + conditionShift, data = d_invalid_clean)
summary(modInvalidLM)

# check if all combinations of conditions are normal distributed
qqnorm(modInvalidLM$residuals)
qqline(modInvalidLM$residuals)

######

# Additional exploratory stuff
# add analysis of blocks
# questions at start etc.
# maybe do a hierachial model
# library(lme4)
# modInvalidLMER = lmer(log(RT) ~ conditionRectangle + conditionField + conditionShift + (1 | submission_id), data = d_invalid)
# summary(modInvalidLMER)
# add further plots and analyses


#' @export
bib_dotprod = function(x, y)
{
  storage.mode(x) = "double"
  storage.mode(y) = "double"
  .Call("bib_dotprod_", x, y)
}

#' @export
bib_vnorm = function(x)
{
  storage.mode(x) = "double"
  .Call("bib_vnorm_", x)
}

#' @export
bib_vscale = function(alpha, x)
{
  storage.mode(x) = "double"
  .Call("bib_vscale_", as.double(alpha), x)
}


#' ---
#' title: "Prior probabilities in the interpretation of 'some': analysis of model predictions and empirical data"
#' author: "Judith Degen"
#' date: "November 28, 2014"
#' ---

library(ggplot2)
theme_set(theme_bw(18))
setwd("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/models/complex_prior/smoothed_unbinned15/results/")
source("rscripts/helpers.r")

#' get model predictions
load("data/mp-sliderpriors.RData")
mp = read.table("data/parsed_priorslider_results.tsv", quote="", sep="\t", header=T)
nrow(mp)
head(mp)
summary(mp)
mp$Item = as.factor(gsub("_"," ",mp$Item))

# get prior expectations
priorexpectations = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/12_sinking-marbles-prior15/results/data/expectations.txt",sep="\t", header=T, quote="")
row.names(priorexpectations) = paste(priorexpectations$effect,priorexpectations$object)
head(priorexpectations)
mp$PriorExpectation_number = priorexpectations[as.character(mp$Item),]$expectation

priorprobs = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/12_sinking-marbles-prior15/results/data/smoothed_15marbles_priors_withnames.txt",sep="\t", header=T, quote="")
head(priorprobs)
row.names(priorprobs) = paste(priorprobs$effect,priorprobs$object)
mpriorprobs = melt(priorprobs, id.vars=c("effect", "object"))
head(mpriorprobs)
row.names(mpriorprobs) = paste(mpriorprobs$effect,mpriorprobs$object,mpriorprobs$variable)
mp$PriorProbability_number = mpriorprobs[paste(as.character(mp$Item)," X",mp$State,sep=""),]$value
mp$AllPriorProbability_number = priorprobs[paste(as.character(mp$Item)),]$X15
head(mp)

load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/23_sinking-marbles-prior-sliders-exactly/results/data/agr-normresponses.RData")
row.names(agr) = paste(agr$slider_id, agr$Item)
expectations = ddply(agr, .(Item), summarise, expectation = sum(slider_id*normresponse))
row.names(expectations) = expectations$Item
mp$PriorProbability_slider = agr[paste(mp$State, mp$Item),]$normresponse
mp$PriorProbability_slider_ymin = agr[paste(mp$State, mp$Item),]$YMin
mp$PriorProbability_slider_ymax = agr[paste(mp$State, mp$Item),]$YMax
mp$PriorExpectation_slider = expectations[as.character(mp$Item),]$expectation

save(mp, file="data/mp-sliderpriors.RData")

ub = droplevels(subset(mp, State == 15))
agr = aggregate(PosteriorProbability ~ Item + SpeakerOptimality + PriorProbability_slider + PriorProbability_slider_ymin + PriorProbability_slider_ymax, FUN=mean, data=ub)
agr$CILow = aggregate(PosteriorProbability ~ Item + SpeakerOptimality, FUN=ci.low, data=ub)$PosteriorProbability
agr$CIHigh = aggregate(PosteriorProbability ~ Item + SpeakerOptimality, FUN=ci.high, data=ub)$PosteriorProbability
agr$YMin = agr$PosteriorProbability - agr$CILow
agr$YMax = agr$PosteriorProbability + agr$CIHigh

ggplot(agr, aes(x=PriorProbability_slider, y=PosteriorProbability, color=as.factor(SpeakerOptimality))) +
  geom_point() +
  #geom_line() +
  geom_errorbar(aes(ymin=YMin,ymax=YMax)) +
  #geom_errorbarh(aes(xmin=PriorProbability_slider_ymin,xmax=PriorProbability_slider_ymax)) +
  facet_wrap(~SpeakerOptimality)
ggsave("graphs/mp-priorsliders.pdf",height=7)

######################
# get empirical state posteriors:
load("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/16_sinking-marbles-sliders-certain/results/data/r.RData")
head(r)
# because posteriors come in 4 bins, make Bin variable for model prediction dataset:
mp$Proportion = as.factor(ifelse(mp$State == 0, "0", ifelse(mp$State == 15, "100", ifelse(mp$State < 8, "1-50", "51-99"))))

some = droplevels(subset(r, quantifier == "Some"))
agr = aggregate(normresponse ~ Item + Proportion,data=r,FUN=mean)
agr$CILow = aggregate(normresponse ~ Item + Proportion,data=r, FUN=ci.low)$normresponse
agr$CIHigh = aggregate(normresponse ~ Item + Proportion,data=r,FUN=ci.high)$normresponse
agr$YMin = agr$normresponse - agr$CILow
agr$YMax = agr$normresponse + agr$CIHigh
row.names(agr) = paste(agr$Item, agr$Proportion)
mp$PosteriorProbability_empirical = agr[paste(mp$Item,mp$Proportion),]$normresponse
mp$PosteriorProbability_empirical_ymin = agr[paste(mp$Item,mp$Proportion),]$YMin
mp$PosteriorProbability_empirical_ymax = agr[paste(mp$Item,mp$Proportion),]$YMax

ub = droplevels(subset(mp, State == 15))
agr = aggregate(PosteriorProbability ~ Item + SpeakerOptimality + PosteriorProbability_empirical + PosteriorProbability_empirical_ymin + PosteriorProbability_empirical_ymax, FUN=mean, data=ub)
agr$CILow = aggregate(PosteriorProbability ~ Item + SpeakerOptimality, FUN=ci.low, data=ub)$PosteriorProbability
agr$CIHigh = aggregate(PosteriorProbability ~ Item + SpeakerOptimality, FUN=ci.high, data=ub)$PosteriorProbability
agr$YMin = agr$PosteriorProbability - agr$CILow
agr$YMax = agr$PosteriorProbability + agr$CIHigh

ggplot(agr, aes(x=PosteriorProbability, y=PosteriorProbability_empirical, color=as.factor(SpeakerOptimality))) +
  geom_point() +
  #geom_line() +
  geom_errorbarh(aes(xmin=YMin,xmax=YMax)) +
  geom_errorbar(aes(ymin=PosteriorProbability_empirical_ymin,ymax=PosteriorProbability_empirical_ymax)) +
  geom_abline(intercept=0,slope=1,color="gray60") +
  facet_wrap(~SpeakerOptimality)
ggsave("graphs/mp-empirical-priorsliders.pdf",height=7)

library(hydroGOF)

test = ddply(agr, .(SpeakerOptimality), summarise, mse=gof(PosteriorProbability, PosteriorProbability_empirical)["MSE",],r=gof(PosteriorProbability, PosteriorProbability_empirical)["r",],R2=gof(PosteriorProbability, PosteriorProbability_empirical)["R2",])
test = test[order(test[,c("mse")]),]
head(test,10)
test = test[order(test[,c("r")],decreasing=T),]
head(test,10)
test = test[order(test[,c("R2")],decreasing=T),]
head(test,10)
head(some)

#plot empirical against predicted expectations for "some"
load("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/13_sinking-marbles-priordv-15/results/data/r.RData")
summary(r)
r$Item = as.factor(paste(r$effect, r$object))
agr = aggregate(ProportionResponse ~ Item + quantifier, data=r, FUN=mean)
agr$Quantifier = as.factor(tolower(agr$quantifier))
row.names(agr) = paste(agr$Item, agr$Quantifier)
mp$PosteriorExpectation_empirical = agr[paste(mp$Item,"some"),]$ProportionResponse*15

agr = aggregate(PosteriorProbability ~ Item + State + SpeakerOptimality + PriorExpectation_slider + PosteriorExpectation_empirical, FUN=mean, data=mp)

pexpectations = ddply(agr, .(Item,SpeakerOptimality,PriorExpectation_slider,PosteriorExpectation_empirical), summarise, PosteriorExpectation_predicted=sum(State*PosteriorProbability))
head(pexpectations)
some=pexpectations

library(hydroGOF)

test = ddply(some, .(SpeakerOptimality), summarise, mse=gof(PosteriorExpectation_predicted, PosteriorExpectation_empirical)["MSE",],r=gof(PosteriorExpectation_predicted, PosteriorExpectation_empirical)["r",],R2=gof(PosteriorExpectation_predicted, PosteriorExpectation_empirical)["R2",])
test = test[order(test[,c("mse")]),]
head(test,10)
test = test[order(test[,c("r")],decreasing=T),]
head(test,10)
test = test[order(test[,c("R2")],decreasing=T),]
head(test,10)
head(some)

ggplot(some, aes(x=PriorExpectation_slider, y=PosteriorExpectation_empirical, color=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth(method='lm') +
  #geom_line() +
  #geom_errorbarh(aes(xmin=YMin,xmax=YMax)) +
  #geom_errorbar(aes(ymin=PosteriorProbability_empirical_ymin,ymax=PosteriorProbability_empirical_ymax)) +
  geom_abline(intercept=0,slope=1,color="gray60") +
  facet_wrap(~SpeakerOptimality)
ggsave("graphs/mp-exps-priorsliders.pdf",height=7)

ggplot(some, aes(x=PosteriorExpectation_predicted, y=PosteriorExpectation_empirical, color=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth(method='lm') +
  #geom_line() +
  #geom_errorbarh(aes(xmin=YMin,xmax=YMax)) +
  #geom_errorbar(aes(ymin=PosteriorProbability_empirical_ymin,ymax=PosteriorProbability_empirical_ymax)) +
  geom_abline(intercept=0,slope=1,color="gray60") +
  facet_wrap(~SpeakerOptimality)
ggsave("graphs/mp-empirical-exps-priorsliders.pdf",height=7)

ggplot(some[some$SpeakerOptimality == 3,], aes(x=PriorExpectation_slider, y=PosteriorExpectation_empirical, color=as.factor(SpeakerOptimality))) +
  geom_point() +
  geom_smooth() +
  scale_color_manual(values=c("darkred")) +
  scale_x_continuous(limits=c(0,15), breaks=seq(1,15,by=2), name="Prior expectation") +
  scale_y_continuous(limits=c(0,15), breaks=seq(1,15,by=2), name="Posterior expectation")

ggsave("graphs/mp-empirical-exps-priorsliders.pdf",height=7)


# Add additional bioclimatic parameters

library(sf)
library(pryr)

OutFile = "../data/pixel-based/climate/climate-extended.gpkg"

# Based on dismo::biovars but on non-temperature/precipitation

AllClimateData = st_read("../data/pixel-based/climate/climate.gpkg")

print("Calculating solar radiation biovars")
srads = sprintf("wc2.0_30s_srad_%02d", 01:12)
AllClimateData$min.srad = apply(as.data.frame(AllClimateData)[,srads], 1, min, na.rm=TRUE)
AllClimateData[["min.srad"]][AllClimateData$min.srad == Inf] = NA
AllClimateData$max.srad = apply(as.data.frame(AllClimateData)[,srads], 1, max, na.rm=TRUE)
AllClimateData[["max.srad"]][AllClimateData$max.srad == Inf] = NA
AllClimateData$mean.srad = apply(as.data.frame(AllClimateData)[,srads], 1, mean, na.rm=TRUE)
AllClimateData[["mean.srad"]][is.nan(AllClimateData$mean.srad)] = NA

print("Calculating wind speed biovars")
winds = sprintf("wc2.0_30s_wind_%02d", 01:12)
AllClimateData$min.wind = apply(as.data.frame(AllClimateData)[,winds], 1, min, na.rm=TRUE)
AllClimateData[["min.wind"]][AllClimateData$min.wind == Inf] = NA
AllClimateData$max.wind = apply(as.data.frame(AllClimateData)[,winds], 1, max, na.rm=TRUE)
AllClimateData[["max.wind"]][AllClimateData$max.wind == Inf] = NA
AllClimateData$mean.wind = apply(as.data.frame(AllClimateData)[,winds], 1, mean, na.rm=TRUE)
AllClimateData[["mean.wind"]][is.nan(AllClimateData$mean.wind)] = NA

print("Calculating water vapour biovars")
vaprs = sprintf("wc2.0_30s_vapr_%02d", 01:12)
AllClimateData$min.vapr = apply(as.data.frame(AllClimateData)[,vaprs], 1, min, na.rm=TRUE)
AllClimateData[["min.vapr"]][AllClimateData$min.vapr == Inf] = NA
AllClimateData$max.vapr = apply(as.data.frame(AllClimateData)[,vaprs], 1, max, na.rm=TRUE)
AllClimateData[["max.vapr"]][AllClimateData$max.vapr == Inf] = NA
AllClimateData$mean.vapr = apply(as.data.frame(AllClimateData)[,vaprs], 1, mean, na.rm=TRUE)
AllClimateData[["mean.vapr"]][is.nan(AllClimateData$mean.vapr)] = NA

# Apply function for getting the month number from colnames.
# apply_fun is the actual function to run
GetMonthNumberApply = function(x, apply_fun)
{
    DesiredName = names(apply_fun(x))
    if (length(DesiredName) <= 0)
        return(NA)
    return(substr(DesiredName, 16, 17))
}

# Additional biovars based on `which`: all variables at the hottest/coldest month, wettest/driest month
tmins = sprintf("wc2.0_30s_tmin_%02d", 01:12)
tmaxs = sprintf("wc2.0_30s_tmax_%02d", 01:12)
precs = sprintf("wc2.0_30s_prec_%02d", 01:12)
AllClimateData$cold = apply(as.data.frame(AllClimateData)[,tmins], 1, GetMonthNumberApply, which.min)
AllClimateData$warm = apply(as.data.frame(AllClimateData)[,tmaxs], 1, GetMonthNumberApply, which.max)
AllClimateData$dry = apply(as.data.frame(AllClimateData)[,precs], 1, GetMonthNumberApply, which.min)
AllClimateData$wet = apply(as.data.frame(AllClimateData)[,precs], 1, GetMonthNumberApply, which.max)

# Apply function that obtains the data from the right column by number
# variable: variable name (prec/vapr/etc.)
# according_to: ColdMonthNum/WarmMonthNum/DryMonthNum/WetMonthNum
GetDataFromIndex = function(x, variable, according_to)
{
    according_to = x[[according_to]]
    if (is.na(according_to))
        return(NA)
    x[[grep(paste0(variable, "_", according_to), names(x))]]
}

# Make all combinations (some probably already included in bioXX)
Combinations = expand.grid(c("srad", "wind", "vapr", "prec", "tmin", "tmax", "tavg"),
                           c("cold", "warm", "wet", "dry"), stringsAsFactors = FALSE)

for (c in 1:nrow(Combinations))
{
    VarName = paste(Combinations[c,2], Combinations[c,1], sep = ".")
    print(VarName)

    ChunkSize = 5000
    DataLength = nrow(AllClimateData)
    Iterator = seq(1, DataLength, ChunkSize)
    pb = txtProgressBar(min = 1, max = DataLength, style = 3)
    Variable = numeric(DataLength)
    for (i in Iterator)
    {
        ChunkEnd = min(i+ChunkSize-1, DataLength)
        DataChunk = as.data.frame(AllClimateData)[i:ChunkEnd,]
        Variable[i:ChunkEnd] = apply(DataChunk, 1, GetDataFromIndex, Combinations[c,1], Combinations[c,2])

        setTxtProgressBar(pb, ChunkEnd)
    }
    AllClimateData[[VarName]] = Variable
    rm(Variable)
    gc()
}

st_write(AllClimateData, OutFile, delete_dsn=TRUE)

# Note: values where all data is NA look like zero everywhere in the row, with derivatives being -inf in some cases and in some cases null


library(tidyverse)
library(readxl)

df <- read_xlsx('data/REPLACES-results.xlsx') %>%
  filter(!is.na(`Submission Date`)) %>%
  select(-ID, -`No Label`) %>%
  mutate(
    id = row_number()
  ) %>%
  mutate_all(tolower)

questions <- colnames(df)
colnames(df) <- c("submission_date", "consent", "current_role", "freq_frontline_ops", "freq_falls", "percent_non_convey", "percent_falls_pathway", "percent_falls_gp", "pt_struggle_meds", "percent_pt_diff_meds", "risk_factors_meds_diff", "refer_cmr", "important_cmr_refer", "care_plan", "id")

df1 <- df %>%
  mutate(
    refer_cmr = ifelse(grepl("know", refer_cmr), "unsure", refer_cmr),
    non_convey = case_when(
      as.numeric(percent_non_convey) < 60 ~ "0-50%",
      as.numeric(percent_non_convey) >= 80 ~ "80-100%",
      TRUE ~ "60-70%"
    )
  )

glimpse(df1)

# Rows: 146
# Columns: 15
# $ submission_date        <chr> "2019-10-31 12:38:13", "2019-10-31 12:26...
# $ consent                <chr> "i have read the study information, and ...
# $ current_role           <chr> "paramedic", "locality manager", "parame...
# $ freq_frontline_ops     <chr> "full-time (37.5 hours a week)", "part-t...
# $ freq_falls             <chr> "more than once a shift", "once a month"...
# $ percent_non_convey     <chr> "50", "20", "80", "10", "60", "80", "0",...
# $ percent_falls_pathway  <chr> "50", "100", "60", "10", "60", "50", "10...
# $ percent_falls_gp       <chr> "20", "20", "60", "10", "100", "20", "10...
# $ pt_struggle_meds       <chr> "loads of boxes of medication that are o...
# $ percent_pt_diff_meds   <chr> "30", "0", "30", "10", "50", "30", "20",...
# $ risk_factors_meds_diff <chr> "1patient says they wish they could stop...
# $ refer_cmr              <chr> "yes and work in the leeds area", "no, b...
# $ important_cmr_refer    <chr> "very important", "important", "importan...
# $ care_plan              <chr> "referral to falls team\r\n\r\nfall patt...
# $ id                     <chr> "1", "2", "3", "4", "5", "6", "7", "8", ...

df1 %>%
  select(starts_with("percent")) %>%
  mutate_all(as.numeric) %>%
  pivot_longer(., cols = everything(), names_to="item", values_to = "percent") %>%
  ggplot(aes(x = percent, fill = item)) +
  scale_fill_viridis_d() +
  scale_x_continuous(name = "Percentage of cases", labels = seq(0, 100, 10), breaks = seq(0, 100, 10)) +
  geom_density(alpha = 0.4)

df1 %>%
  select(starts_with("percent")) %>%
  mutate_all(as.numeric) %>%
  pivot_longer(., cols = everything(), names_to="item", values_to = "percent") %>%
  count(item, percent) %>%
  ggplot(aes(x = percent, y = n, fill = item)) +
  #scale_fill_viridis_d() +
  scale_x_continuous(name = "Percentage of cases", labels = seq(0, 100, 10), breaks = seq(0, 100, 10)) +
  geom_area(alpha = 0.4, position="identity") +
  facet_wrap(~item)

df1 %>% count(forcats::fct_lump(current_role, 9, other_level = "other"), sort = T)

# `forcats::fct_lump(current_role, 9, other_level = "other")`     n
# <fct>                                                       <int>
# 1 paramedic                                                      65
# 2 newly qualified paramedic                                      21
# 3 emergency care assistant                                       13
# 4 emergency medical technician (emt1, emt2, or similar)           9
# 5 clinical supervisor                                             8
# 6 eca                                                             8
# 7 advanced paramedic (e.g. ecp/ucp)                               7
# 8 specialist paramedic (e.g. paramedic practitioner)              6
# 9 other                                                           6
# 10 student paramedic                                              3

df2 <- df1 %>% mutate(
  current_role = forcats::fct_lump(current_role, 9, other_level = "other")
)

df1 %>% count(freq_frontline_ops)
df1 %>% count(freq_falls, sort = T)
df1 %>% count(percent_non_convey, sort = T)
df1 %>% count(percent_falls_pathway, sort = T)
df1 %>% count(percent_falls_gp, sort = T)
df1 %>% count(percent_pt_diff_meds, sort = T)
df1 %>% count(refer_cmr, sort = T)
df1 %>% count(important_cmr_refer, sort = T)

# Process risk factors list
x <- df1$risk_factors_meds_diff[137]
str_split(str_replace(x,"\\d+\\s?", ""), "\r\n\\d+\\s?", simplify = F)
y <- str_split(x, "\r\n\\s?", simplify = F)

processChoices <- function(x) {

  item <- strsplit(x, "(?<=[\\d+])\\s?", perl = T)
  print(item)

}

#map(y,processChoices)

# df1 %>% separate(col="risk_factors_meds_diff", into=c("number", "item"), sep="\\d+\\s?") %>% select(number, item)
#
# df1 %>% select(risk_factors_meds_diff) %>% map_df(.,processChoices)

rank_df <- df1 %>%
  # Split character vector into list and then put each row of the list on a new dataframe row
  unnest(y = str_split(risk_factors_meds_diff, "\r\n\\s?", simplify = F)) %>% select(id, y) %>%
  # Separate the number (rank) from the risk factor (item)
  separate(col="y", into=c("rank", "item"), sep = "(?<=[\\d+])\\s?") %>%
  filter(
    # Only going to look at top 5 since likely people got bored after
    # dragging and dropping 5 risk factors around the screen
    rank <= 5,
    # Rank 10 was split into 1 and 0. Not a problem since not including it, but it needs removing
    item != 0
  ) %>%
  mutate(
    item = str_replace(item, "\\r?\\s?\\d+", ""),
    item = ifelse(grepl("can", item), "patient cannot recall all their prescribed medicines", item)
  )

totals_df <- rank_df %>%
  count(item, rank) %>%
  group_by(item) %>%
  summarise(
    tot_n = sum(n),
    total = 5*first(n[rank == "1"], default = 0) + 4*first(n[rank == "2"], default = 0) + 3*first(n[rank == "3"], default = 0) + 2*first(n[rank == "4"], default = 0) + first(n[rank == "5"], default = 0)
  ) %>%
  arrange(desc(total))

rank_df %>%
  mutate(
    item = factor(item)
  ) %>%
  ggplot(aes(x = item, fill = rank)) +
  geom_bar()

# Check choices have been correctly extracted:
# df1 %>% filter(id == 22) %>% select(risk_factors_meds_diff) %>% pull(risk_factors_meds_diff)

# [1] "1 patient says they find it difficult to take their medicines\r\n2 patient says they are not taking medicines as prescribed\r\n3 carer says that patient not taking medicines as prescribed\r\n4 unused medicines around the home\r\n5 patient says they wish they could stop taking some of their medicines\r\n6 expired medicines in the home\r\n7 medicines kept in multiple places\r\n8 medicines kept in hard to reach locations\r\n9 patient says they have trouble taking their medicines on time\r\n10 patient can’t recall all their prescribed medicines"

# rank_df %>% filter(id == 22) %>% select(rank, item)
#
# # A tibble: 5 x 2
# rank  item
# <chr> <chr>
# 1 1     patient says they find it difficult to take their medicines
# 2 2     patient says they are not taking medicines as prescribed
# 3 3     carer says that patient not taking medicines as prescribed
# 4 4     unused medicines around the home
# 5 5     patient says they wish they could stop taking some of their medicines

library(tableone)

summary_table <- CreateTableOne(
  data = df2,
  vars = c("current_role", "freq_frontline_ops", "freq_falls", "important_cmr_refer"),
  strata = "refer_cmr",
  factorVars = c("current_role", "freq_frontline_ops", "freq_falls", "important_cmr_refer"),
  test = F,
  addOverall = T
)
kableone(summary_table)


context('Test createphenotype functions')

noiseBg <- noiseBgEffects(N=100, P=10)
noiseFixed <- noiseFixedEffects(N=100, P=10)
noiseCorrelated <- correlatedBgEffects(N=100, P=10, pcorr=0.6)
genotypes <- simulateGenotypes(N=100, NrSNP=20, verbose=FALSE)
kinship <- getKinship(N=100, X=genotypes$genotypes, standardise=TRUE,
                      verbose=FALSE)
causalSNPs <- getCausalSNPs(N=100, genotypes=genotypes$genotypes, verbose=FALSE)
geneticFixed <- geneticFixedEffects(X_causal=causalSNPs, P=10, N=100,
                                    verbose=FALSE)
geneticBg <- geneticBgEffects(P=10, N=100, kinship=kinship)

context("Tests rescaleVariance")
test_that("rescaleVariance fails when propvar is not numeric", {
    expect_error(rescaleVariance(noiseBg$shared, propvar = 'a'),
                 "propvar needs to be numeric")
})
test_that("rescaleVariance fails when propvar is out of range", {
    expect_error(rescaleVariance(noiseBg$shared, propvar = 1.1),
                 "propvar cannot be less than 0 and or greater than 1")
})
test_that("rescaleVariance fails when component is not a matrix", {
    expect_error(rescaleVariance(data.frame(noiseBg$shared), propvar = 0.1),
                 "component needs to be a matrix")
})
test_that("rescaleVariance returns NULL when no propvar is specified", {
    expect_equal(rescaleVariance(noiseBg$shared, propvar = 0), NULL)
})

test_that("rescaleVariance returns correclty scaled average column variance", {
    tmp <- rescaleVariance(noiseBg$shared, propvar = 0.1)
    expect_equal(mean(diag(var(tmp$component))), 0.1, tolerance=5e-5)
})

context("Tests setModel")
test_that("setModel fails with input error", {
    expect_error(setModel(), "No variance components specified")
})

test_that("setModel fails with out of range error", {
    expect_error(setModel(genVar=0.4, h2s=1.2, theta=0.8,  eta=0.8,
                          delta=0.2, gamma=0.8, rho=0.2, phi=0.6,
                          alpha=0.8, pcorr=0.6, pIndependentConfounders=0.4,
                          pTraitIndependentConfounders=0.2,
                          pIndependentGenetic=0.4,
                          pTraitIndependentGenetic=0.2, verbose=FALSE),
                 "Proportions have to be specified between 0 and 1:")
})
test_that("setModel fails with missing variance error", {
    expect_error(setModel(h2s=1, theta=0.8,  eta=0.8,
                          delta=0.2, gamma=0.8, rho=0.2, phi=0.6,
                          alpha=0.8, pcorr=0.6, pIndependentConfounders=0.4,
                          pTraitIndependentConfounders=0.2,
                          pIndependentGenetic=0.4,
                          pTraitIndependentGenetic=0.2, verbose=FALSE),
                 "Neither genVar nor noiseVar are provided, thus")
})

test_that("setModel fails with sum of variance error", {
    expect_error(setModel(genVar=0.2, noiseVar=0.9, h2s=1, theta=0.8,  eta=0.8,
                          delta=0.2, gamma=0.8, rho=0.2, phi=0.6,
                          alpha=0.8, pcorr=0.6, pIndependentConfounders=0.4,
                          pTraitIndependentConfounders=0.2,
                          pIndependentGenetic=0.4,
                          pTraitIndependentGenetic=0.2, verbose=FALSE),
                 "Sum of genetic variance and noise variance is greater than 1")
})

test_that("setModel fails with extra noise component error", {
    expect_error(setModel(noiseVar=0, h2s=1, theta=0.8,  eta=0.8,
                          delta=0.2, gamma=0.8, rho=0.2, phi=0.6,
                          alpha=0.8, pcorr=0.6, pIndependentConfounders=0.4,
                          pTraitIndependentConfounders=0.2,
                          pIndependentGenetic=0.4,
                          pTraitIndependentGenetic=0.2, verbose=FALSE),
                 "The noise variance is set to 0 ")
})

test_that("setModel fails with extra genetic component error", {
    expect_error(setModel(genVar=0, h2s=1, theta=0.8,  eta=0.8,
                          delta=0.2, gamma=0.8, rho=0.2, phi=0.6,
                          alpha=0.8, pcorr=0.6, pIndependentConfounders=0.4,
                          pTraitIndependentConfounders=0.2,
                          pIndependentGenetic=0.4,
                          pTraitIndependentGenetic=0.2, verbose=FALSE),
                 "The genetic variance is set to 0 ")
})

test_that("setModel fails with missing noise component error", {
    expect_error(setModel(noiseVar=0.8, h2s=1, theta=0.8,  eta=0.8,
                          pcorr=0.6, pIndependentConfounders=0.4,
                          pTraitIndependentConfounders=0.2,
                          pIndependentGenetic=0.4,
                          pTraitIndependentGenetic=0.2,
                          verbose=FALSE),
                 "Neither delta ")
})

test_that("setModel fails with proportions larger than 1 error", {
    expect_error(setModel(noiseVar=0.8, h2s=1, theta=0.8, delta=0.8, phi=0.2,
                          rho=0.2, eta=0.8,
                          pcorr=0.6, pIndependentConfounders=0.4,
                          pTraitIndependentConfounders=0.2,
                          pIndependentGenetic=0.4,
                          pTraitIndependentGenetic=0.2,
                          verbose=FALSE),
                 "Sum of the proportion of the variance of noise")
})

test_that("setModel fails with proportions less than 1 error", {
    expect_error(setModel(noiseVar=0.8, h2s=1, theta=0.8, delta=0.2, phi=0.2,
                          rho=0.2, eta=0.8,
                          pcorr=0.6, pIndependentConfounders=0.4,
                          pTraitIndependentConfounders=0.2,
                          pIndependentGenetic=0.4,
                          pTraitIndependentGenetic=0.2,
                          verbose=FALSE),
                 "Sum of the proportion of the variance of noise")
})

test_that("setModel fails with insufficient noise component error", {
    expect_error(setModel(noiseVar=0.8, h2s=1, theta=0.8,  eta=0.8,
                          delta=0.8, pcorr=0.6, pIndependentConfounders=0.4,
                          pTraitIndependentConfounders=0.2,
                          pIndependentGenetic=0.4,
                          pTraitIndependentGenetic=0.2,
                          verbose=FALSE),
                 "Not enough components provided to set proportions of")
})

test_that("setModel fails with insufficient genetic component error", {
    expect_error(setModel(genVar=0.8, theta=0.8,  eta=0.8,
                          delta=0.2, gamma=0.8, rho=0.2, phi=0.6,
                          alpha=0.8, pcorr=0.6, pIndependentConfounders=0.4,
                          pTraitIndependentConfounders=0.2,
                          pIndependentGenetic=0.4,
                          pTraitIndependentGenetic=0.2, verbose=FALSE),
                 "Neither genetic variant effect variance")
})

test_that("setModel fails with sum of genetic component error", {
    expect_error(setModel(genVar=0.8, h2s=0.4, h2bg=0.3, theta=0.8,  eta=0.8,
                          delta=0.2, gamma=0.8, rho=0.2, phi=0.6,
                          alpha=0.8, pcorr=0.6, pIndependentConfounders=0.4,
                          pTraitIndependentConfounders=0.2,
                          pIndependentGenetic=0.4,
                          pTraitIndependentGenetic=0.2, verbose=FALSE),
                 "Sum of the proportion of the variance of genetic")
})

context("Tests runSimulation")
test_that("runSimulation returns correct output", {
    expect_equal(length(runSimulation(N=10, P=5, genVar=1, h2s=0.2)), 5)
})


# Takes input from correlation-histogram.py

library("ggplot2")
setwd("~/dev/BitFunnel/src/Scripts")

png(filename="term-term.png",width=1600,height=1200)
# df <- read.csv(header=FALSE, file="wat.csv")
term_term <- read.csv(header=TRUE, file="/tmp/term-term.csv")

ggplot(data=term_term, aes(x=bucket, y=count, fill=treatment)) + geom_bar(stat="identity", position="dodge")  +
  scale_y_log10() +
  theme_bw() +
  theme(axis.text = element_text(size=40),
        axis.title = element_text(size=40),
        legend.title=element_text(size=40),
        legend.text=element_text(size=40))
dev.off()

png(filename="term-all.png",width=1600,height=1200)
# df <- read.csv(header=FALSE, file="wat.csv")
term_all <- read.csv(header=TRUE, file="/tmp/term-all.csv")

ggplot(data=term_all, aes(x=bucket, y=count, fill=treatment)) + geom_bar(stat="identity", position="identity", alpha=.5)  +
  scale_y_log10() +
  theme_bw() +
  theme(axis.text = element_text(size=40),
        axis.title = element_text(size=40),
        legend.title=element_text(size=40),
        legend.text=element_text(size=40))
dev.off()


# Packages
library(tidyverse)
library(magrittr)
library(ggplot2)
library(geomnet)
library(ggnetwork)
library(sf)
library(ggmap)
library(sp)
library(rgdal)
library(leaflet)
library(xlsx)
library(data.table)
library(mapview)
library(mapedit)
library(matlib)
library(nngeo)
library(writexl)
library(here)
library(MASS)

source("./R/simulation_funs.r")
source("./R/functions.r")

reclass <- function (df, vec_types) {
  for (i in 1:ncol(df)) {
    type <- vec_types[i]
    class(df[ , i]) <- type
  }
  return(df)
}

create_surveynet <- function(points, observations, dest_crs = NA, axes = c("Easting", "Northing")){
  points_col_type <- c("numeric", "text", "numeric", "numeric", "numeric", "logical", "logical", "logical")
  obs_col_type <- c("numeric", "text", "text", rep("numeric", 19))
  # reading data
  points <- reclass(df = as.data.frame(points), vec_types = points_col_type) %>% mutate_at(., .vars = c("Name"), as.character)
  observations <- reclass(df = as.data.frame(observations), vec_types = obs_col_type) %>% mutate_at(., .vars = c("from", "to"), as.character)

  if(sum(rowSums(is.na(points[, c("x", "y")])) != 0) != 0){
    warning("Network has no spatial coordinates")}else{
      # Creating sf class from observations
      observations$x_from <- points$x[match(observations$from, points$Name)]
      observations$y_from <- points$y[match(observations$from, points$Name)]
      observations$x_to <- points$x[match(observations$to, points$Name)]
      observations$y_to <- points$y[match(observations$to, points$Name)]

      points <- points %>% as.data.frame() %>% sf::st_as_sf(coords = c("x","y"), remove = FALSE)
      if(which(axes == "Easting") == 2){points <- points %>% dplyr::rename(x = y,  y = x)}

      observations <- observations %>% dplyr::mutate(id = seq.int(nrow(.))) %>% split(., f = as.factor(.$id)) %>%
        lapply(., function(row) {lmat <- matrix(unlist(row[c("x_from", "y_from", "x_to", "y_to")]), ncol = 2, byrow = TRUE)
        st_linestring(lmat)}) %>%
        sf::st_sfc() %>%
        sf::st_sf(observations, 'geometry' = .) %>%
        dplyr::mutate(ID = 1:n())
    }

  #if(sum(rowSums(is.na(observations[, c("HzD", "HzM", "HzS")])) != 0) != 0){stop("There is uncomplete observations")}

  observations <- observations %>% dplyr::mutate(Hz = HzD + HzM/60 + HzS/3600,
                                                 Vz = VzD + VzM/60 + VzS/3600,
                                                 tdh = SD*cos(Vz*pi/180),
                                                 distance = (!is.na(HD) | !is.na(SD)) & !is.na(sd_dist),
                                                 direction = !is.na(Hz) & !is.na(sd_Hz),
                                                 diff_level = (!is.na(dh) | !is.na(tdh)))

  # In network design, observation is included if measurement standard is provided
  if(observations %>% purrr::when(is(., "sf") ~ st_drop_geometry(.), ~.) %>% dplyr::select(HzD, HzM, HzS) %>% is.na() %>% all()){
    observations$direction[!is.na(observations$sd_Hz)] <- TRUE
  }
  if(observations %>% purrr::when(is(., "sf") ~ st_drop_geometry(.), ~.) %>% dplyr::select(HD, SD) %>% is.na() %>% all()){
    observations$distance[!is.na(observations$sd_dist)] <- TRUE
  }
  if(observations %>% purrr::when(is(., "sf") ~ st_drop_geometry(.), ~.) %>% dplyr::select(dh) %>% is.na() %>% all()){
    observations$diff_level[(!is.na(observations$dh) | !is.na(observations$sd_dh) | !is.na(observations$d_dh) | !is.na(observations$n_dh))] <- TRUE
  }

  # Eliminacija merenih duzina i visinsih razlika izmedju fiksnih tacaka duzina izmedju
  # checking for fixed points
  # TODO what in case of no-fixed points
  fixed_points <- points %>% dplyr::filter(FIX_2D | FIX_1D) %>% .$Name

  if(length(fixed_points) > 1){
    observations[observations$from %in% fixed_points & observations$to %in% fixed_points, "distance"] <- FALSE
    observations[observations$from %in% fixed_points & observations$to %in% fixed_points, "diff_level"] <- FALSE
  }

  # Setting coordinate system
  if(!is.na(dest_crs)){
    observations %<>% sf::st_set_crs(dest_crs)
    points %<>% sf::st_set_crs(dest_crs)
  }

  # Creating list
  survey_net <- list(points, observations)
  names(survey_net) <- c("points", "observations")
  return(survey_net)
}

# Read mreza file
mreza <- read_surveynet(file = here::here("Data/Simulation/TETO_extended.xlsx"))
# Simulation
mreza_sim <- sim_snetobs(survey.net = mreza, red = TRUE, seed = 1018)
# Create list and write file
mreza_list <- list(Points = mreza_sim[[1]] %>% st_drop_geometry(), Observations = mreza_sim[[2]] %>% st_drop_geometry() %>% mutate_at(.vars = c("e_cent_from", "e_cent_to", "e_focus", "e_air"), .funs = ~NA) %>% dplyr::select(from:e_air)) %>%
  writexl::write_xlsx(., path = here::here("Data/Simulation/TETO_extended_sim.xlsx"))
# Read simulated mreza
mreza_sim <- read_surveynet(file = here::here("Data/Simulation/TETO_extended_sim.xlsx"))
mreza_sim$observations$sd_Hz <- 10
mreza_sim$observations$sd_dist <- 3
plot_surveynet(snet = mreza_sim, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)
mreza_adj <- adjust.snet(adjust = TRUE, survey.net = mreza_sim, dim_type = "2D", sd.apriori = 3,  all = TRUE, prob = 0.95)

# Objekat
j4 <- readxl::read_xlsx(here::here("Data/Simulation/j4_cross.xlsx"))

j4 <- j4 %>% tidyr::separate(., col = "Tacka", into = c("h", "v"), sep = "/")
vv <- sample(paste(c(3:7)), size = 2)
hh <- sample(c("TA", "TB", "TC", "T"), size = 2)

object_points <- j4 %>% dplyr::filter(h %in% hh & v %in% vv) %>% dplyr::mutate(id = 1:n(), Name = paste(h, v, sep = "_"), h = NA, FIX_2D = FALSE, FIX_1D = NA, Point_object = TRUE) %>% dplyr::select(id, Name, x = Y, y = X, h, FIX_2D, FIX_1D, Point_object)# %>% sf::st_as_sf(coords = c("X","Y"), remove = FALSE)

stations <- sample(mreza_adj[[2]][[1]]$Name, 3)

station_points <- mreza_adj[[2]][[1]] %>% st_drop_geometry() %>% dplyr::filter(Name %in% stations) %>% dplyr::select(id, Name, x = x, y = y, h, FIX_2D, Point_object) %>% dplyr::mutate(FIX_2D = TRUE, FIX_1D = NA)

points <- rbind(station_points, object_points)

target_obs <- data.frame(from = as.character(rep(station_points$Name, each = dim(object_points)[1])), to = as.character(rep(object_points$Name, dim(station_points)[1])), stringsAsFactors = FALSE) %>% mutate(ID = 1:n(), HzD = NA, HzM = NA, HzS = NA, HD = NA, SD = NA, VzD = NA, VzM = NA, VzS = NA, dh = NA, sd_Hz = 7, sd_dist = 3, sd_Vz = NA, sd_dh = NA, d_dh = NA, n_dh = NA, e_cent_from = 0.8, e_cent_to = 1.2, e_focus = 0, e_air = 0.6) %>% dplyr::select(ID, everything())

net_obs <- mreza[[2]] %>% dplyr::filter(from %in% stations & to %in% stations) %>% st_drop_geometry() %>% dplyr::select(from, to) %>%
    mutate(ID = 1:n(), HzD = NA, HzM = NA, HzS = NA, HD = NA, SD = NA, VzD = NA, VzM = NA, VzS = NA, dh = NA, sd_Hz = 3, sd_dist = 3, sd_Vz = NA, sd_dh = NA, d_dh = NA, n_dh = NA, e_cent_from = 0.8, e_cent_to = 0.8, e_focus = 0, e_air = 0.6) %>% dplyr::select(ID,from, to, HzD:e_air)

l1 <- split(target_obs, f = factor(target_obs$from, levels = unique(target_obs$from)))
l2 <- split(net_obs, f = factor(net_obs$from, levels = unique(target_obs$from)))

observations <- purrr::map2(.x = l2, .y = l1, .f = rbind) %>% do.call(rbind, .) %>% dplyr::mutate(ID = 1:n())

mreza_ispit <- create_surveynet(points = points, observations = observations)

mreza_ispit_sim <- sim_snetobs(survey.net = mreza_ispit, red = TRUE, seed = 2020)

mreza_list <- list(Points = mreza_ispit_sim[[1]] %>% st_drop_geometry() %>% dplyr::mutate_at(.vars = c("x", "y"), ~round(., 3)), Observations = mreza_ispit_sim[[2]] %>% st_drop_geometry() %>% mutate_at(.vars = c("sd_Hz", "sd_dist", "e_cent_from", "e_cent_to", "e_focus", "e_air"), .funs = ~NA) %>% dplyr::select(from:e_air)%>% split(., f = factor(.$from, levels = unique(.$from))) %>% lapply(., function(x) dplyr::arrange(x, HzD)) %>% do.call(rbind, .))

mreza_list %>% writexl::write_xlsx(., path = here::here("Data", "ispit_10_6_2020.xlsx"))
ispit <- read_surveynet(file = here::here("Data", "ispit_10_6_2020.xlsx"))

mreza_sim_ispit <- create_surveynet(points = ispit[[1]] %>% dplyr::select(id,Name,x,y,h,FIX_2D,FIX_1D,Point_object) %>% st_drop_geometry(), observations = ispit[[2]] %>% mutate(ID = 1:n()) %>% dplyr::select(ID,from:e_air) %>% st_drop_geometry())

mreza_sim_ispit[[2]] <- mreza_sim_ispit[[2]] %>% dplyr::mutate(Hz = HzD + HzM/60 + HzS/3600,
                                                               Vz = VzD + VzM/60 + VzS/3600,
                                                               tdh = SD*cos(Vz*pi/180),
                                                               distance = (!is.na(HD) | !is.na(SD)) | !is.na(sd_dist),
                                                               direction = !is.na(Hz) | !is.na(sd_Hz),
                                                               diff_level = (!is.na(dh) | !is.na(tdh)))

mreza_sim_ispit$observations$sd_Hz <- 5
mreza_sim_ispit$observations$sd_dist <- 3

mreza_adj_ispit <- adjust.snet(adjust = TRUE, survey.net = mreza_sim_ispit, dim_type = "2D", sd.apriori = 5,  all = TRUE, prob = 0.95, maxiter = 1)

plot_surveynet(snet = mreza_sim_ispit, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)

save(mreza_adj_ispit, file = "resenje_10062020.Rdata")


  # ------------------------
  # mean body size

  bodysize = function(x, factors=c("trip", "set"), variable, logtransform=T) {
    if (logtransform) x[,variable]=log10(x[,variable])

    x = x[is.finite(x[,variable]),]

    m = as.data.frame.table(tapply(X=x[,variable], INDEX=x[,factors], FUN=mean, simplify=T, na.rm=T))
    n = as.data.frame.table(tapply(X=x[,variable], INDEX=x[,factors], FUN=length, simplify=T))
    v = as.data.frame.table(tapply(X=x[,variable], INDEX=x[,factors], FUN=var, simplify=T, na.rm=T))

    names(m) = c(factors, paste(variable,"mean",sep="."))
    names(n) = c(factors, paste(variable,"n",sep="."))
    names(v) = c(factors, paste(variable,"var",sep="."))

    m = factor2character(m, factors)
    v = factor2character(v, factors)
    n = factor2character(n, factors)

    all = merge(x=m, y=v, by=factors, all=T)
    all = merge(x=all, y=n, by=factors, all=T)

    return(all)
  }


context("Checking mkonfound")

library(lme4)
library(mice)

popmis <- popmis[1:100, ]

testmod1 <- lm(teachpop ~ texp + sex, data = popmis)
testmod2 <- lmer(teachpop ~ texp + sex + (1 | school), data = popmis)

output1 <- konfound(testmod1, texp, test_all = TRUE, to_return = "raw_output")
output2 <- konfound(testmod2, texp, test_all = TRUE, to_return = "raw_output")

test_that("mkonfound works for lm and lmer outout", {
  expect_is(output1, "data.frame")
  expect_is(output2, "data.frame")
})