params <- chrpfdnm %>% group_by(ID) %>% summarise(n=n()) %>% summarise(mean=mean(n), sd=sd(n))

##############################################################################
# Calculate individual-level AUC from the GoNL DNMs
#
# Each iteration calculates the AUC for the following:
# AUC under 3-mer model
# Permuted AUC under 3-mer model
# AUC under logit model
# Permuted AUC under logit model
##############################################################################
nperm <- 258

aucperm <- rep(0,nperm)
aucperm3 <- aucperm

ids <- unique(chrpfdnm$ID)
numind <- length(ids)
aucind <- rep(0, numind)
aucind3 <- aucind

for(i in 1:nperm){
	### Run permutations
	cat("Permuting AUC", "(", i, "of", nperm, ")...\n")
	ndnms <- round(rnorm(1, params$mean, params$sd), 0)
	nsamp <- 1000000

	chrpsub <- rbind(chrpfdnm[sample(nrow(chrpfdnm), ndnms),], chrpfa) %>%
		arrange(MU)
	chrpsub$prop <- cumsum(chrpsub$OBS)/sum(chrpsub$OBS)
	chrpsub2 <- chrpsub[sample(nrow(chrpsub), nsamp),] %>%
	  arrange(MU) %>%
	  mutate(ntile=ntile(MU, 1000))

	chrpsub3 <- chrpsub %>% arrange(MU3)
	chrpsub3$prop <- cumsum(chrpsub3$OBS)/sum(chrpsub3$OBS)
	chrpsub3a <- chrpsub3[sample(nrow(chrpsub3), nsamp),] %>%
		arrange(MU3, prop) %>%
		mutate(ntile=ntile(MU3, 1000))

	auctmp <- chrpsub2 %>% summarise(AUC=1-sum(prop)/nsamp)
	aucperm[i] <- auctmp$AUC
	auctmp3 <- chrpsub3a %>% summarise(AUC=1-sum(prop)/nsamp)
	aucperm3[i] <- auctmp3$AUC

	curid<-ids[i]
	### Get empirical AUC
	cat("Calculating AUC for", curid, "(", i, "of", numind, ")...\n")
	datid<-chrpfdnm %>% filter(ID==curid)

	tmpdat<-rbind(datid, chrpfa) %>% arrange(MU)
	tmpdat$prop<-cumsum(tmpdat$OBS)/sum(tmpdat$OBS)
	tmpdat2<-tmpdat[sample(nrow(tmpdat), nsamp),] %>%
	  arrange(MU) %>%
	  mutate(ntile=ntile(MU, 1000))

	### Repeat with 3-mer model
	tmpdat3<-tmpdat %>% arrange(MU3)
	tmpdat3$prop<-cumsum(tmpdat3$OBS)/sum(tmpdat3$OBS)
	tmpdat3s<-tmpdat3[sample(nrow(tmpdat3), nsamp),] %>%
		arrange(MU3, prop) %>%
		mutate(ntile=ntile(MU3, 1000))

	tmpauc <- tmpdat2 %>% summarise(AUC=1-sum(prop)/nsamp)
	aucind[i]<-tmpauc$AUC
	tmpauc3 <- tmpdat3s %>% summarise(AUC=1-sum(prop)/nsamp)
	aucind3[i]<-tmpauc3$AUC
}

##############################################################################
# Calculate AUC for each individual under the logit and 3-mer models
##############################################################################
# ids<-unique(chrpfdnm$ID)
# numind<-length(ids)
# aucind<-rep(0, numind)
# aucind3<-aucind
#
# for(i in 1:numind){
# 	curid<-ids[i]
# 	cat("Calculating AUC for", curid, "(", i, "of", numind, ")...\n")
# 	datid<-chrpfdnm %>% filter(ID==curid)
# 	tmpdat<-rbind(datid, chrpfa) %>% arrange(MU)
# 	tmpdat$prop<-cumsum(tmpdat$OBS)/sum(tmpdat$OBS)
#
# 	nsamp<-50000
#
# 	tmpdat2<-tmpdat[sample(nrow(tmpdat), nsamp),] %>%
# 	  arrange(MU) %>%
# 	  mutate(ntile=ntile(MU, 1000))
#
# 	tmpauc <- tmpdat2 %>% summarise(AUC=1-sum(prop)/nsamp)
# 	aucind[i]<-tmpauc$AUC
#
# 	### Repeat with 3-mer model
# 	tmpdat3<-tmpdat %>% arrange(MU3)
# 	tmpdat3$prop<-cumsum(tmpdat3$OBS)/sum(tmpdat3$OBS)
#
# 	tmpdat3s<-tmpdat3[sample(nrow(tmpdat3), nsamp),] %>%
# 		arrange(MU3, prop) %>%
# 		mutate(ntile=ntile(MU3, 1000))
#
# 	tmpauc3 <- tmpdat3s %>% summarise(AUC=1-sum(prop)/nsamp)
# 	aucind3[i]<-tmpauc3$AUC
# }

##############################################################################
# Function checks if elements in a exist in b
# Output is binary vector of length same as b
##############################################################################
toBin <- function(a,b){
	as.numeric(is.element(b,a))
}

##############################################################################
# Simulate mutations by randomly selecting sites and checking if
# Bernoulli(mu)==1; loop continues until we have simulated the same number
# of sites as in observed data
##############################################################################
nsim<-200

for(i in 1:nsim){
	cat("Running simulation", i, "of", nsim, "...\n")
	nsample <- 20000
	mutated <- c()
	# nsites<-round(rnorm(1, params$mean, params$sd), 0)
  nsites <- 10171

	while(length(mutated) < nsites){
		rowind <- sample(nrow(chrp), nsample)
		row <- chrp[rowind,]
		mu <- row$MU

		batch <- sapply(mu, function(x) rbinom(1,1,x))
		mutated <- c(mutated, row$POS[which(as.logical(batch))])
	}

	# chrp$TMP <- toBin(mutated[1:nsites], chrp$POS)
	mus <- toBin(mutated, chrp$POS)
	nsimi <- sum(mus)
	chrp$last <- cumsum(mus)/nsimi

	colnames(chrp)[ncol(chrp)] <- paste0("simprop", i)
}

##############################################################################
# Subsample 100k sites, resort by mu, add percentile column, and coerce
# from wide to long format
#
# Can delete chrp after this step
##############################################################################
cat("Subsampling data...\n")
nsamp<-100000

chrp2<-chrp[sample(nrow(chrp), nsamp),] %>%
  arrange(MU) %>%
  mutate(ntile=ntile(MU, 1000)) %>%
  gather(group, val, .dots=grep("prop", names(chrp)))

auc <- chrp2 %>% group_by(group) %>% summarise(AUC=1-sum(val)/nsamp)

cat("Cleaning up memory...\n")
gc()

##############################################################################
# Summarize simulated data for ROC plots
##############################################################################
chrp2_nt_mean<-chrp2 %>%
  group_by(group, ntile) %>%
  summarise(val=mean(val))

# Get subsets of true and simulated data
chrp2_nt_sim<-chrp2_nt_mean[chrp2_nt_mean$group!="prop",]
chrp2_nt_obs<-chrp2_nt_mean[chrp2_nt_mean$group=="prop",]

# Calculate lower/upper range from simulations
# (can switch commented summarise() lines to use CI)
chrp2_lb<-chrp2_nt_sim %>%
  group_by(ntile) %>%
  # summarise(lb=t.test(val)$conf.int[1]) %>%
	summarise(lb=max(val)) %>%
  mutate(group="lb") %>%
  dplyr::select(group, ntile, lb)

chrp2_ub<-chrp2_nt_sim %>%
  group_by(ntile) %>%
  # summarise(ub=t.test(val)$conf.int[2]) %>%
	summarise(ub=min(val)) %>%
  mutate(group="ub") %>%
  dplyr::select(group, ntile, ub)

# Add bounds to data frame
chrp2_nt_obs$lb <- chrp2_lb$lb
chrp2_nt_obs$ub <- chrp2_ub$ub

##############################################################################
# Combine AUC data to generate ROC plot
##############################################################################
full_auc_dat<-rbind(data.frame(chrp2_nt_obs[,1:3]), data.frame(chrp3b))
names(full_auc_dat)[1]<-"Model"
full_auc_dat$Model<-ifelse(full_auc_dat$Model=="prop", "Logit", "3-mer")
full_auc_bounds<-chrp2_nt_obs[,c(2:5)]

ggplot()+
  geom_line(data=full_auc_dat,
		aes(x=(1000-ntile)/1000, y=1-val, group=Model, colour=Model), size=1.2)+
  geom_abline(intercept=0, slope=1)+
  geom_ribbon(data=full_auc_bounds,
		aes(x=(1000-ntile)/1000, y=1-val, ymin=1-ub, ymax=1-lb), alpha=0.2)+
	scale_colour_manual(values=cbbPalette[2:3])+
  coord_cartesian(xlim=c(0,1))+
	xlab("False Positive Rate")+
	ylab("True Positive Rate")+
  theme_bw()+
	theme(
		# legend.position="none",
		axis.title.x=element_text(size=20),
		axis.title.y=element_text(size=20))
  # scale_y_continuous(limits=c(0,1))+
  # scale_x_continuous(limits=c(0,1000), labels=c())
ggsave("/net/bipolar/jedidiah/mutation/images/pseudo_roc_curves.png", height=4, width=7.25)

##############################################################################
# Get AUC data for distribution plots
##############################################################################
auc$model<-"simulated"
auc$obs<-"simulated"

# aucind_df<-data.frame(AUC=aucind, gp="ind")
aucsim<-auc[-1,2:4]
auclogitobs<-data.frame(AUC=aucind, model="logit", obs="observed")
auc3merobs<-data.frame(AUC=aucind3, model="3-mer", obs="observed")
auclogitperm<-data.frame(AUC=aucperm, model="logit", obs="permuted")
auc3merperm<-data.frame(AUC=aucperm3, model="3-mer", obs="permuted")

# All AUCs
plotaucfull<-rbind(aucsim, auclogitobs, auc3merobs, auclogitperm, auc3merperm)
plotaucfull$model<-as.factor(plotaucfull$model)
plotaucfull$model<-relevel(plotaucfull$model, "3-mer")

# No simulations
plotaucnosim<-rbind(auclogitobs, auc3merobs, auclogitperm, auc3merperm)
plotaucnosim$model<-as.factor(plotaucnosim$model)
plotaucnosim$model<-relevel(plotaucnosim$model, "3-mer")

# Only observed data (no simulation or permutations)
plotaucobsonly<-rbind(auclogitobs, auc3merobs)
plotaucobsonly$model<-as.factor(plotaucobsonly$model)
plotaucobsonly$model<-relevel(plotaucobsonly$model, "3-mer")

# Observed + Simulated (no permutations)
plotaucnoperm<-rbind(aucsim, auclogitobs, auc3merobs)
plotaucnoperm$model<-as.factor(plotaucnoperm$model)
plotaucnoperm$model<-relevel(plotaucnoperm$model, "3-mer")

plotaucmean<-plotaucobsonly %>%
	group_by(model, obs) %>%
	summarise(AUC=mean(AUC))

ggplot()+
	geom_density(data=plotaucfull, aes(x=AUC, colour=model, linetype=obs))+
	geom_density(data=aucsim, aes(x=AUC), colour="black")+
	scale_colour_manual(values=cbbPalette[c(2,3,1)])+
	# geom_vline(data=plotaucmean,
	# 	aes(xintercept=AUC, colour=model, linetype=obs))+
	theme_classic()+
	guides(linetype=F)+
	theme(legend.position="bottom")
ggsave("/net/bipolar/jedidiah/mutation/images/auc_hist.png", height=4, width=4)

# Add paternal age
ages<-read.table("/net/bipolar/jedidiah/mutation/reference_data/DNMs/gonl_fam_age.txt", header=T)
names(ages)<-c("ID", "nDNM", "FatherAge", "MotherAge", "Coverage")
plotaucobsonly<-rbind(auclogitobs, auc3merobs)
plotaucobsonly$ID<-c(ids, ids)
plotaucobsonly<-merge(plotaucobsonly, ages, by="ID")

##############################################################################
# Additional data summaries for paternal age, etc.
##############################################################################
auc_age_cor<-plotaucobsonly %>%
	group_by(model) %>%
	summarise(cor=cor(AUC, FatherAge, method="spearman"),
		cor.p=cor.test(AUC, FatherAge, method="spearman")$p.value,
		cornum=cor(AUC, nDNM, method="spearman"),
		cornum.p=cor.test(AUC, nDNM, method="spearman")$p.value)

fao<-plotaucobsonly %>%
	filter(model=="logit") %>%
	filter(AUC>0.669 | AUC<0.597) %>%
	mutate(quart=ifelse(AUC>0.669, "yes", "no")) %>%
	dplyr::select(quart, FatherAge) %>%
	spread(quart, FatherAge)

# OLD VERSION--early attempt at pseudo-ROC curves
# ggplot(chrp3, aes(x=1000-ntile, y=1-val, group=group, colour=group))+
#   geom_line()
# ggsave("/net/bipolar/jedidiah/mutation/images/psuedo_roc_chr4a.png")

# OLD VERSION--uses true ROC calculations
# devtools::install_github("hadley/ggplot2")
# devtools::install_github("sachsmc/plotROC")
# library(plotROC)
#
# basicplot2<-ggplot(chrp2, aes(d = OBS, m = MU))+
# 	geom_roc()
#
# basicplot2+annotate("text", x = .75, y = .25,
#            label = paste("AUC =", round(calc_auc(basicplot)$AUC, 2)))+
# 	style_roc()
# ggsave("/net/bipolar/jedidiah/mutation/images/chr18_roc2.png")


source("common.r")

df <- read.csv("../results/determinism.csv")

df <- df %>% filter(Commutativity == "true") %>% select(-Commutativity)
maxTime <- max(df %>% select(Time) %>% filter(!((Time == "memout") | (Time == "timeout"))) %>% transform(Time = strtoi(Time)))
outValue <-((maxTime %/% 30) + 10) * 30

df <- df %>%
  transform(Time = ifelse(Time == "memout" | Time == "timeout", outValue, strtoi(Time)) / 1000) %>%
  transform(Pruning = gsub("true", "Yes", gsub("false", "No", Pruning)))

range <- seq(0, max(df %>% select(Time)), by=0.5)
ticks <- range
print(ticks)
ticks[length(ticks)] <- "Timeout"

df <- ddply(df, c("Name", "Pruning"), summarise,
            Mean = mean(Time),
            Trials = length(Time),
            Sd = sd(Time),
            Se = Sd / sqrt(Trials))

plot <- ggplot(df, aes(x=Name,y=Mean,fill=Pruning)) +
  mytheme() +
  scale_fill_manual(values=c("red", "blue")) +
  theme(legend.title = element_text(size = 8),
        legend.position = c(0.85, 0.8),
        axis.text.x=element_text(angle=50, vjust=0.5)) +
  geom_bar(stat="identity",position="dodge") +
  geom_errorbar(aes(ymin=Mean-Se,ymax=Mean+Se,width=.4), position=position_dodge(0.9)) +
  scale_y_continuous(breaks = range, labels = ticks) +
  labs(x = "Benchmark", y = "Time (s)")
mysave("../results/determinism.pdf", plot)


GetEventTimes <- function(eventcodes, datalist) {

  require(dplyr)
  #source('src/GetRaws.R')

  df.list <- list()

  for (eventcode in eventcodes) {
    #### Recode data so event = 1, no event = 0, missing = NA ####
    #
    codeq <- paste0(eventcode, 'q', seq(4)) # get the quarterly codes
    #
    # Creating the event data frame...
    GetRaws(datalist, c(eventcode, codeq)) %>%
      spread(key = code, value = val) %>%
      # missing values replaced with NA
      mutate_at(eventcode, funs(case_when(. < 0 ~ NA_real_,
                                          TRUE ~ as.numeric(.)))) %>%
      mutate_at(eventcode, funs(. - 1)) %>%
      mutate_at(codeq, funs(case_when(. < 0 ~ NA_real_,
                                      TRUE ~ as.numeric(.)))) -> df

    # rename our column variables to make selection easier
    colnames(df) <- c("xwaveid", "wave", "annual", "post03",
                            "post06", "post09", "post12")

    # set the column order to allow column indexing below
    colorder <- c('xwaveid', 'wave', 'pre36', 'pre24', 'pre12', 'post03',
                  'post06', 'post09', 'post12', 'post24', 'post36', 'post48')

    # Add lead and lag variables based on annual event record
    # pre36 = 2-3 years before event
    # pre24 = 1-2 years before event
    # pre12 = 0-1 years before event
    # post03 = 0-3 months after event
    # post06 = 3-6 months after event
    # post09 = 6-9 months after event
    # post12 = 9-12 months after event
    # post24 = 1-2 years after event
    # post36 = 2-3 years after event
    # post48 = 3-4 years after event

    df %>%
      group_by(xwaveid) %>%
      # The annual event record is used to create yearly leads and lags (pre12
      # to post36). If the annual event record is missing (even if quarterly
      # event records are present), then leads and lags will be missing
      mutate(
        pre12  = dplyr::lead(annual, n = 1, order_by = wave),
        pre24  = dplyr::lead(annual, n = 2, order_by = wave),
        pre36  = dplyr::lead(annual, n = 3, order_by = wave),
        post24 = dplyr::lag(annual, n = 1, order_by = wave),
        post36 = dplyr::lag(annual, n = 2, order_by = wave),
        post48 = dplyr::lag(annual, n = 3, order_by = wave)
      ) %>%
      ungroup() %>%
      select(-annual) %>%
      select(one_of(colorder)) %>%
      mutate(rowsums = rowSums(.[3:12], na.rm = TRUE)) %>%
      filter(rowsums > 0) %>%  #This removes rows containing only zeroes, NAs are counted as zeros,i.e,removes persons with no values in all of the event variables.
      select(-rowsums) -> df

    df.list[eventcode] <- list(df)

  }

  return(df.list)
}


rm(list=ls())

file.prefix  <- commandArgs()[4]
FDR_index_remove_variants  <- as.integer(commandArgs()[5])

# ------------------------------------------- #
# -- SNP QCII: HF across entire collection -- #
# ------------------------------------------- #

fdr.hf  <- read.table(file=paste(file.prefix, ".1.txt", sep=""), header=T)

fdr  <- -log10(fdr.hf$FDR)
pval <- -log10(fdr.hf$HF_pval_worstbatchremoved_ctrls)

png(file=paste(file.prefix, ".1.png", sep=""), width=720, height=720)

plot(fdr, fdr.hf$Fail_worstbatchremoved_ctrls_cases/1000, xlim=c(1,10), ylim=c(0,200), xlab="-log10(FDR threshold)", ylab="# SNPs failed (x 1,000)", pch=17, col="black", type="b", yaxt="n", xaxt="n", cex=1.5)
lines(fdr, fdr.hf$Fail_allbatches_ctrls_cases/1000, type="b", pch=20, col="black", cex=1.5)
axis(1, at=seq(1,10,by=1), labels=fdr)
axis(2, at=seq(0,200,by=20), labels=seq(0,200,by=20))
axis(3, at=seq(1,10,by=1), labels=round(pval, digits=1), xlab="")
mtext("-log10(p-value threshold)", side=3, line=2.5)
legend("topright", legend=c("All batches","Worst batch removed"), pch=c(20,17), col=c("black","black"), text.col=rep("black", 2), bty="y", inset=.05, cex=1.5)

# FDR threshold
lines(x=c(FDR_index_remove_variants,FDR_index_remove_variants), y=c(0,150), lty=2, col="red")
text(fdr[FDR_index_remove_variants], fdr.hf$Fail_worstbatchremoved_ctrls_cases[FDR_index_remove_variants]/1000, labels=c(fdr.hf$Fail_worstbatchremoved_ctrls_cases[FDR_index_remove_variants]/1000), pos=4)

dev.off()


library(rstan)
library(reshape2)

all_dat = readRDS('../data/all_melt.RDS')

all_dat = all_dat[which(all_dat$class %in% c('Tenure Track', 'Postdoctoral', 'Graduate')),]
all_dat$class = droplevels(all_dat$class)
all_dat$year= as.numeric(substr(all_dat$date, 1, 4))

tots = aggregate(value ~ date + class, all_dat, sum)

int = all_dat[all_dat$int==TRUE,c('class', 'date', 'month', 'year', 'value' )]
dat_org = merge(int, tots, by = c('date', 'class'))
colnames(dat_org)[5:6] = c('int', 'total')
dat_org = data.frame(dat_org, nint = dat_org$total - dat_org$int)
# levels(dat_org$class) <- c('Graduate', 'Postdoctoral', 'Tenure Track')

classes = c('Tenure Track', 'Postdoctoral', 'Graduate')
years   = seq(2000, 2015)

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

gr_dat = dat_org[which(dat_org$class == 'Graduate'),]
gr_dat = gr_dat[order(gr_dat$date),]
gr_dat$nint_p = gr_dat$nint/gr_dat$total

pd_dat = dat_org[which(dat_org$class == 'Postdoctoral'),]
pd_dat = pd_dat[order(pd_dat$date),]
pd_dat$nint_p = pd_dat$nint/pd_dat$total

tt_dat = dat_org[which(dat_org$class == 'Tenure Track'),]
tt_dat = tt_dat[order(tt_dat$date),]
tt_dat$nint_p = tt_dat$nint/tt_dat$total

date  = tt_dat$date
month = tt_dat$month
year  = tt_dat$year
T     = length(date)

X <- matrix(0, nrow=length(month), ncol=length(unique(month)))
X[cbind(seq_along(month), month)] <- 1

all <- list(T = T,
            N_years = length(unique(year)),
            N_months = length(unique(month)),
            K = 12,
            date = date,
            month = month,
            year  = year-2000+1,
            y_tt  = tt_dat$int,
            N_tt  = tt_dat$total,
            y_gr  = gr_dat$int,
            N_gr  = gr_dat$total,
            y_pd  = pd_dat$int,
            N_pd  = pd_dat$total)

########################################################################################################################################
## plotting functions
########################################################################################################################################

# only works when there are individual month effects
plot_month_ind <- function(month_ind, suff){
  # month_ind = post_m2b$month_ind
  month_ind = apply(month_ind, c(2,3), function(x) quantile(x, probs=c(0.025, 0.5, 0.975)))
  month_ind = melt(month_ind)

  colnames(month_ind) = c('quant', 'class', 'month', 'value')

  month_ind$class = classes[month_ind$class]

  ymin = subset(month_ind, quant == c('2.5%'))$value
  ymax = subset(month_ind, quant == c('97.5%'))$value
  y = subset(month_ind, quant == c('50%'))$value
  limits = data.frame(subset(month_ind, quant == c('2.5%'))[,1:3], ymin=ymin, ymax=ymax, y=y)
  # limits = aes(ymin=ymin, ymax=ymax)

  ggplot() + geom_point(data=subset(month_ind, quant == c('50%')), aes(x=factor(month), y=value, colour=factor(class)), size=3) +
    geom_pointrange(data=limits, aes(x=factor(month), ymin=ymin, y=y, ymax=ymax, colour=factor(class)))

  #ggsave(paste0('figures/month_ind_', suff, '.pdf'))

}

# only works when there are individual month effects
plot_month_shared <- function(month_shared, suff){
  # month_ind = post_m2b$month_ind
  month_shared = apply(month_shared, c(2), function(x) quantile(x, probs=c(0.025, 0.5, 0.975)))
  month_shared = melt(month_shared)

  colnames(month_shared) = c('quant', 'month', 'value')

  ymin = subset(month_shared, quant == c('2.5%'))$value
  ymax = subset(month_shared, quant == c('97.5%'))$value
  y = subset(month_shared, quant == c('50%'))$value
  limits = data.frame(subset(month_shared, quant == c('2.5%'))[,1:3], ymin=ymin, ymax=ymax, y=y)
  # limits = aes(ymin=ymin, ymax=ymax)

  ggplot() + geom_point(data=subset(month_shared, quant == c('50%')), aes(x=factor(month), y=value), size=3) +
    geom_pointrange(data=limits, aes(x=factor(month), ymin=ymin, y=y, ymax=ymax)) +
    ggtitle('Month shared')

  #ggsave(paste0('figures/month_shared_', suff, '.pdf'))

}

# # only works when there are individual month effects
# plot_time_shared <- function(time_shared, suff){
#   # month_ind = post_m2b$month_ind
#   time_shared = apply(time_shared, c(2), function(x) quantile(x, probs=c(0.025, 0.5, 0.975)))
#   time_shared = melt(time_shared)
#
#   colnames(time_shared) = c('quant', 'time', 'value')
#
#   ymin = subset(time_shared, quant == c('2.5%'))$value
#   ymax = subset(time_shared, quant == c('97.5%'))$value
#   y = subset(time_shared, quant == c('50%'))$value
#   limits = data.frame(subset(time_shared, quant == c('2.5%'))[,1:3], ymin=ymin, ymax=ymax, y=y)
#   # limits = aes(ymin=ymin, ymax=ymax)
#
#   ggplot() + geom_point(data=subset(time_shared, quant == c('50%')), aes(x=factor(time), y=value), size=3) +
#     geom_pointrange(data=limits, aes(x=factor(time), ymin=ymin, y=y, ymax=ymax)) +
#     ggtitle('Time shared')
#
#   #ggsave(paste0('figures/time_shared_', suff, '.pdf'))
#
# }

# only works when there are individual month effects
plot_time_shared <- function(post, suff){
  time_shared = post$time_all
  time_shared = apply(time_shared, c(2), function(x) quantile(x, probs=c(0.025, 0.5, 0.975)))
  time_shared = melt(time_shared)

  colnames(time_shared) = c('quant', 'time', 'value')

  ymin = subset(time_shared, quant == c('2.5%'))$value
  ymax = subset(time_shared, quant == c('97.5%'))$value
  y = subset(time_shared, quant == c('50%'))$value
  limits = data.frame(subset(time_shared, quant == c('2.5%'))[,1:3], ymin=ymin, ymax=ymax, y=y)
  # limits = aes(ymin=ymin, ymax=ymax)

  ggplot() + geom_point(data=subset(time_shared, quant == c('50%')), aes(x=factor(time), y=value), size=3) +
    geom_pointrange(data=limits, aes(x=factor(time), ymin=ymin, y=y, ymax=ymax)) +
    ggtitle('Time shared')

  #ggsave(paste0('figures/time_shared_', suff, '.pdf'))

}

# only works when there are individual month effects
plot_time_individual <- function(post, suff){
  time_ind = post$time_ind
  time_ind = apply(time_ind, c(2,3), function(x) quantile(x, probs=c(0.025, 0.5, 0.975)))
  time_ind = melt(time_ind)

  colnames(time_ind) = c('quant', 'class', 'time', 'value')

  ymin = subset(time_ind, quant == c('2.5%'))$value
  ymax = subset(time_ind, quant == c('97.5%'))$value
  y = subset(time_ind, quant == c('50%'))$value
  limits = data.frame(subset(time_ind, quant == c('2.5%'))[,1:3], ymin=ymin, ymax=ymax, y=y)
  # limits = aes(ymin=ymin, ymax=ymax)

  ggplot() + geom_point(data=subset(time_ind, quant == c('50%')), aes(x=factor(time), y=value), size=3) +
    geom_pointrange(data=limits, aes(x=factor(time), ymin=ymin, y=y, ymax=ymax)) +
    ggtitle('Time ind')

  #ggsave(paste0('figures/time_shared_', suff, '.pdf'))

}

plot_alphas <- function(alpha_ind, alpha_all, suff){

  alpha_ind = apply(alpha_ind, c(2), function(x) quantile(x, probs=c(0.025, 0.5, 0.975)))
  alpha_ind = melt(alpha_ind)

  colnames(alpha_ind) = c('quant', 'class', 'value')

  alpha_ind$class = classes[alpha_ind$class]

  alpha_all = quantile(alpha_all, probs=c(0.025, 0.5, 0.975))
  alpha_all = melt(alpha_all)

  alpha_all = data.frame(quant=rownames(alpha_all), class=rep('all'), value=alpha_all)

  alpha = rbind(alpha_ind, alpha_all)

  ymin = subset(alpha, quant == c('2.5%'))$value
  ymax = subset(alpha, quant == c('97.5%'))$value
  y = subset(alpha, quant == c('50%'))$value
  limits = data.frame(subset(alpha, quant == c('2.5%'))[,1:3], ymin=ymin, ymax=ymax, y=y)
  # limits = aes(ymin=ymin, ymax=ymax)

  ggplot() + geom_point(data=subset(alpha, quant == c('50%')), aes(x=class, y=value), size=3) +
    geom_pointrange(data=limits, aes(x=class, ymin=ymin, y=y, ymax=ymax)) +
    ggtitle('Constants')

  #ggsave(paste0('figures/alpha_', suff, '.pdf'))
}

plot_time_slopes <- function(time_slope_ind, time_slope_all, suff){

  time_slope_ind = apply(time_slope_ind, c(2), function(x) quantile(x, probs=c(0.025, 0.5, 0.975)))
  time_slope_ind = melt(time_slope_ind)

  colnames(time_slope_ind) = c('quant', 'class', 'value')

  time_slope_ind$class = classes[time_slope_ind$class]

  time_slope_all = quantile(time_slope_all, probs=c(0.025, 0.5, 0.975))
  time_slope_all = melt(time_slope_all)

  time_slope_all = data.frame(quant=rownames(time_slope_all), class=rep('all'), value=time_slope_all)

  alpha = rbind(time_slope_ind, time_slope_all)

  ymin = subset(alpha, quant == c('2.5%'))$value
  ymax = subset(alpha, quant == c('97.5%'))$value
  y = subset(alpha, quant == c('50%'))$value
  limits = data.frame(subset(alpha, quant == c('2.5%'))[,1:3], ymin=ymin, ymax=ymax, y=y)
  # limits = aes(ymin=ymin, ymax=ymax)

  ggplot() + geom_point(data=subset(alpha, quant == c('50%')), aes(x=class, y=value), size=3) +
    geom_pointrange(data=limits, aes(x=class, ymin=ymin, y=y, ymax=ymax))  +
    ggtitle('Time slope')

  #ggsave(paste0('figures/time_slopes_', suff, '.pdf'))
}

plot_preds <- function(all, post, suff){

  dat = rbind(data.frame(date=date, value=colMeans(post[['theta_tt']]), class=rep('Tenure Track'), type='pred'),
              data.frame(date=date, value=colMeans(post[['theta_pd']]), class=rep('Postdoctoral'), type='pred'),
              data.frame(date=date, value=colMeans(post[['theta_gr']]), class=rep('Graduate'), type='pred'),
              data.frame(date=date, value=all$y_tt/all$N_tt, class=rep('Tenure Track'), type='data'),
              data.frame(date=date, value=all$y_pd/all$N_pd, class=rep('Postdoctoral'), type='data'),
              data.frame(date=date, value=all$y_gr/all$N_gr, class=rep('Graduate'), type='data'))

  ggplot() + geom_line(data=dat, aes(x=date, y=value, colour=type)) + facet_grid(class~.) +
    ggtitle('Interdisciplinary jobs by class')

  #ggsave(paste0('figures/preds_', suff, '.pdf'))
}

########################################################################################################################################
## run all the model 2s
########################################################################################################################################

fit_m2 <- stan(file    = 'model2.stan',
                data    = all,
                iter    = 200,
                chains  = 1,
                control = list(max_treedepth=12))
post_m2   <- extract(fit_m2)

fit_m2a <- stan(file    = 'model2a.stan',
                data    = all,
                iter    = 200,
                chains  = 1,
                control = list(max_treedepth=12))
post_m2a   <- extract(fit_m2a)

fit_m2b <- stan(file    = 'model2b.stan',
                data    = all,
                iter    = 200,
                chains  = 1,
                control = list(max_treedepth=12))
post_m2b   <- extract(fit_m2b)

fit_m2c <- stan(file    = 'model2c.stan',
                data    = all,
                iter    = 200,
                chains  = 1,
                control = list(max_treedepth=12))
post_m2c   <- extract(fit_m2c)

########################################################################################################################################
## plot parameters estimates
########################################################################################################################################

plot_month_ind(post_m2$month_ind, '2')
plot_month_ind(post_m2a$month_ind, '2a')
plot_month_ind(post_m2b$month_ind, '2b')

# plot_month_shared(post_m2$month_all, '2')
# plot_month_shared(post_m2a$month_all, '2a')
# plot_month_shared(post_m2b$month_all, '2b')
# plot_month_shared(post_m2c$month_all, '2c')

plot_alphas(post_m2$alpha_ind, post_m2$alpha_all, '2')
plot_alphas(post_m2a$alpha_ind, post_m2a$alpha_all, '2a')
plot_alphas(post_m2b$alpha_ind, post_m2b$alpha_all, '2b')
plot_alphas(post_m2c$alpha_ind, post_m2c$alpha_all, '2c')

plot_time_slopes(post_m2$time_slope_ind, post_m2$time_slope_all, '2')
plot_time_slopes(post_m2a$time_slope_ind, post_m2a$time_slope_all, '2a')
plot_time_slopes(post_m2b$time_slope_ind, post_m2b$time_slope_all, '2b')
plot_time_slopes(post_m2c$time_slope_ind, post_m2c$time_slope_all, '2c')

plot_time_shared(post_m2$time_shared, '2')

########################################################################################################################################
## run all the model 4s
########################################################################################################################################

fit_m4 <- stan(file    = 'model4.stan',
               data    = all,
               iter    = 200,
               chains  = 1,
               control = list(max_treedepth=12))
post_m4   <- extract(fit_m4)

fit_m4a <- stan(file    = 'model4a.stan',
                data    = all,
                iter    = 200,
                chains  = 1,
                control = list(max_treedepth=12))
post_m4a   <- extract(fit_m4a)

fit_m4b <- stan(file    = 'model4b.stan',
                data    = all,
                iter    = 200,
                chains  = 1,
                control = list(max_treedepth=12))
post_m4b   <- extract(fit_m4b)

fit_m4c <- stan(file    = 'model4c.stan',
                data    = all,
                iter    = 200,
                chains  = 1,
                control = list(max_treedepth=12))
post_m4c   <- extract(fit_m4c)

########################################################################################################################################
## plot parameters estimates
########################################################################################################################################

pdf(file=paste0('figures/model_4.pdf'))
plot_month_ind(post_m4$month_ind, '4')
plot_alphas(post_m4$alpha_ind, post_m4$alpha_all, '4')
plot_time_slopes(post_m4$time_slope_ind, post_m4$time_slope_all, '4')
plot_preds(all, post_m4, '4')
plot_time_shared(post_m4, '4')
dev.off()

pdf(file=paste0('figures/model_4a.pdf'))
plot_month_ind(post_m4a$month_ind, '4a')
plot_alphas(post_m4a$alpha_ind, post_m4a$alpha_all, '4a')
plot_time_slopes(post_m4a$time_slope_ind, post_m4a$time_slope_all, '4a')
plot_preds(all, post_m4a, '4a')
plot_time_individual(post_m4a, '4a')
dev.off()

pdf(file=paste0('figures/model_4b.pdf'))
plot_month_ind(post_m4b$month_ind, '4b')
plot_alphas(post_m4b$alpha_ind, post_m4b$alpha_all, '4b')
plot_time_slopes(post_m4b$time_slope_ind, post_m4b$time_slope_all, '4b')
plot_preds(all, post_m4b, '4b')
dev.off()

pdf(file=paste0('figures/model_4c.pdf'))
plot_alphas(post_m4c$alpha_ind, post_m4c$alpha_all, '4c')
plot_time_slopes(post_m4c$time_slope_ind, post_m4c$time_slope_all, '4c')
plot_preds(all, post_m4c, '4c')
dev.off()


library(magrittr)
#
# add all arguments
#
TestAdd <- function(...){
  sum(...)
}

# countrycode <- function(sourcevar, origin, destination, warn = TRUE, nomatch = NA, custom_dict = NULL, custom_match = NULL, origin_regex = FALSE){
# countrycode::countrycode(sourcevar, origin, destination, warn, nomatch, custom_dict, custom_match, origin_regex)
# }

iso.expand <- function(code){
  maps::iso.expand(code)
}

graph.plot <- function(data, label=NULL){
  # link the graphics to the calling cell, so it won't get erased
  # when another cell draws a plot
  BERT.graphics.device(cell=T);

  # flatten the data and make sure it's numeric
  data = as.numeric( unlist( data ));

  # draw the plot
  plot(data, pch=21, bg="pink", col="red", main=label );
  lines( lowess( data ));

  # we're done with the graphics device, so shut it off for now
  dev.off();

  # this is a convenient return value for the calling cell
  T;
}

kernel_smooth <- function(object, startyear, startmonth, endyear, endmonth, frequency, kernel_type, bandwidth){
  object <- as.data.frame(object) # convert from list to df
  object[object == ''] <- NA # NULL values to NAs
  object <- zoo::na.locf(object) # last non-missing value carried forward
  ts_object <- ts(object, start = c(startyear, startmonth), end = c(endyear, endmonth), frequency)
  return(ksmooth(time(ts_object), ts_object, kernel_type, bandwidth, x.points = time(ts_object))$y)
}

StatsGini <- function(x, w = rep(1, length(x))){
  # x and w are vectors
  # w can be left blank when calling the fn (i.e. no weighting)
  # Examples:
  # x <- c(3, 1, 7, 2, 5)
  # w <- c(1, 2, 3, 4, 5)
  # StatsGini(x, w) should yield 0.2983050847
  # StatsGini(c(0.25, 0.75), c(1, 1)) should yield 0.25
  n <- length(x)
  wxsum <- sum(w * x)
  wsum <- sum(w)
  sxw <- order(x, w) # Ascending order sort
  sx <- w[sxw] * x[sxw]
  sw <- w[sxw]
  pxi <- vector(mode = "numeric", length = n)
  pci <- vector(mode = "numeric", length = n)
  pxi <- cumsum(sx) / wxsum
  pci <- cumsum(sw) / wsum
  G <- 0.0
  for (i in 2:n){
    G <- G - (pci[i] * pxi[i - 1] - pxi[i] * pci[i - 1] )
  }
  return(G)
}

getFX <- function(currency_1, currency_2){
  url <- paste0('https://www.freeforexapi.com/api/live?pairs=', currency_1, currency_2)
  rate <- rjson::fromJSON(readLines(url))$rates[[1]][[1]]
  return(rate)
}

interpolate <- function(x, y, xout){
  approx(x, y, n = length(x))$y[which(x %in% xout)]
}


##' Estimate population size per health zone in Katanga
##'
##' @return data frame with estimated population size ('population') and population size less than 5 years old ('l5pop') per year and per health zone
##' @importFrom dplyr group_by summarise ungroup mutate if_else right_join if_else filter select arrange case_when
##' @author Sebastian Funk
##' @param under_5_multiplier factor population size is multiplied by to estimate population size under 5
estimate_population_sizes <- function(under_5_multiplier=0.169)
{
  populations <- katanga_2015_mvc %>%
    select(-year) %>%
    group_by(health_zone, phase, health_area, village) %>%
    summarise(population=unique(round(population)),
              targetpop=unique(round(targetpop)),
              vaccinated=sum(vaccinated),
              survey_coverage=unique(survey_coverage),
              min_age=min(min_age),
              max_age=max(max_age)) %>%
    ungroup() %>%
    mutate(pop_factor=case_when(
             .$max_age == 5 ~ 1 / under_5_multiplier,
             .$max_age == 10 ~ 1 / .33,
             TRUE ~ 1 / .46)) %>%
    mutate(population=if_else(!is.na(survey_coverage),
                              round(vaccinated / survey_coverage * pop_factor),
                              population),
           population=if_else(is.na(population),
                              round(targetpop * pop_factor),
                              population)) %>%
    group_by(health_zone) %>%
    summarise(population=sum(unique(population)), vaccinated=sum(vaccinated)) %>%
    ungroup() %>%
    right_join(katanga_mcv_admin %>%
               filter(!is.na(population)) %>%
               group_by(health_zone) %>%
               filter(year==min(max(year), 2015)) %>%
               select(province, health_zone, adm_population=population)) %>%
    mutate(population=if_else(is.na(population), adm_population, population)) %>%
    mutate(l5pop=population * under_5_multiplier) %>% ## estimated population under 5
    select(province, health_zone, population, l5pop) %>%
    arrange(health_zone)

  return(populations)
}


#!/usr/bin/env Rscript
#
# Run Fisher's exact test to compare the allele frequencies in two
# pools.
#
# fishers_exact_pools.r <input1> <input2>
#
# Writes to stdout.
#

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

cargs = commandArgs(trailingOnly=TRUE)
infile_1 = cargs[1]
infile_2 = cargs[2]

dat_1 = read.csv(infile_1, sep='\t', header=TRUE, as.is=TRUE)
dat_2 = read.csv(infile_2, sep='\t', header=TRUE, as.is=TRUE)

for(i in 1:nrow(dat_1)) {
    d1 = dat_1[i, ]
    d2 = dat_2[i, ]
    if(d1[,'chrom'] != d2[,'chrom'])
        stop(paste('files do not match on line', i))
    if(d1[,'pos'] != d2[,'pos'])
        stop(paste('files do not match on line', i))
    if(d1[,'alleles'] != d2[,'alleles'])
        stop(paste('files do not match on line', i))

    n1 = d1[, 'N']
    n2 = d2[, 'N']

    if(n1 == 0 || n2 == 0) {

        # If there isn't any coverage
        p = NaN
        fixed = NA

    } else {

        # Counts of alleles
        f1 = as.numeric(unlist(strsplit(d1[, 'freqs'], ','))) * n1
        f2 = as.numeric(unlist(strsplit(d2[, 'freqs'], ','))) * n2

        if(length(f1) == 1 || length(f2) == 1) {

            # If there isn't any variation (happens with P/A variants)
            p = NaN
            fixed = NA

        } else {

            # Look for fixed differences
            fixed = 0
            if(any(f1 == n1) && any(f2 == n2) && f2[f1 == n1] == 0)
                fixed = 1

            # Fisher's exact test
            res = fisher.test(rbind(f1, f2), alternative='two.sided')
            p = res$p.value
        }
    }

    cat(d1[, 'chrom'], '\t', d1[, 'pos'], '\t', p, '\t',
        fixed, '\n', sep='', file=stdout())
}


# Method
pow <- function(x, y)
{
   x <- as.numeric(x)
   y <- as.integer(y)
   prod(rep(x, y))
}
#Operator
"%pow%" <- function(x,y) pow(x,y)

executeTask <- function(i) {

	return(pow(2017+i, 12)  + (19.88+i) %pow% 12)
}
r =1

for(i in 0:2000000000) {
	r = executeTask(i)
}


# to install hastaLaVista package use the following:
# devtools::install_github("jwist/hastaLaVista")
# the simply load the library
library(hastaLaVista)

# we use the MetaboMate package for normalization
# and for multivariate analysis
# to install it use:
# devtools::install_github("kimsche/MetaboMate")
library(MetaboMate)
library(car)

# load demo dataset
data("bariatricRat")
X <- bariatricRat$X
ppm <- bariatricRat$ppm
metadata <- bariatricRat$metadata

# normalisation of data
Xn=pqn(X)
matspec(ppm, Xn, shift=c(7,8))

# preparation of the dataset to create the data.json file
ID <- metadata$Sample.Label
group <- metadata$Class
metadata <- data.frame(metadata)
x <- matrix(Xn, dim(X)[1], dim(X)[2])
x_axis <- as.numeric( ppm )
color = sapply(group, function(x) getColor2(as.character(x)))

d = list()
c <- data.frame(ID = ID,
                group = group,
                color = color,
                "_highlight" = seq_along(group) - 1,
                dataMatrix = I(matrix( c(rbind(repRow(x_axis, nrow(x)), x)), nrow(x), ncol(x)*2)),
                metadata = I(metadata),
                check.names = FALSE
)

# do not modify variableName, the view is expecting it!
d <- appendData(data = d, variableName = "data", variable = c, type = "table")

# performing multivariate analysis
smod=opls(Xn, group)
plotscores(smod, an=list(Class=group), cv.scores = F)
plotload(smod, Xn, ppm, title='oPLS loadings')

chart12 <- data.frame("x" = smod@t_pred,
                      "y" = smod@t_orth,
                      "highlight" = seq_along(group) - 1,
                      "info"= ID,
                      "group" = as.numeric( group ),
                      "color" = color
)

plot(smod@t_pred, smod@t_orth)

# do not modify variableName, the view is expecting it!
d <- appendData( data = d, variableName = "score12", variable = chart12, type = "score")

d[['scores']] <- smod@t_pred
d[['loadings']] <- cov(smod@t_pred, x)
d[['loadingsColor']] <- abs(cor(smod@t_pred, x))

# calculating ellipses
ellipse <- dataEllipse(as.numeric(smod@t_pred), as.numeric(smod@t_orth), levels=0.80)

ellipseChart <- data.frame("x" = ellipse[,1],
                           "y" = ellipse[,2],
                           "color" = rep('black', length(ellipse[,1])))

# do not modify variableName, the view is expecting it!
d <- appendData( data = d, variableName = "ellipse", variable = ellipseChart, type = "color")

v2 <- new("visualization")
v2@data <- "rat_bariatric_metaboscope.data.json"
v2@view <- "metaboscope_1_0.view.json"
push(v2, type="data", d)
visualize(v2)


library(Romp)

m <- 100
n <- 10

x <- matrix(rnorm(m*n), m, n)
vec <- rnorm(m)

R <- sweep(x, STATS=vec, FUN="-", MARGIN=1)
C <- c_sweep(x, vec)
F77 <- f77_sweep(x, vec)
F90 <- f90_sweep(x, vec)
Rcpp <- rcpp_sweep(x, vec)

stopifnot(all.equal(R, C))
stopifnot(all.equal(R, F77))
stopifnot(all.equal(R, F90))
stopifnot(all.equal(R, Rcpp))


df <- read.delim ("sample/nuc.wig_around_anno_halfwid1000winsize25step10.txt")

png("sample/nuc.wig_around_anno_halfwid1000winsize25step10.png")
plot (df$relative_pos, df$smt_mean, col="black", ylim=c(-1,0.35), main="Nucleosome distribution around TSS", ylab="Nucleosome occupancy (z-score)", xlab="Distance from TSS (bp)", type="l", lwd=2)
lines (df$relative_pos, df$CI95.00percent_U, col="black", lty=2)
lines (df$relative_pos, df$CI95.00percent_L, col="black", lty=2)
abline (v = 0, h = 0, lty=2)
dev.off()


load("test_rmc.RData")

dates <- as.Date(dimnames(results)[[6]])
datesiso <- as.POSIXlt(dates)
month <- datesiso$mon + 1 # 1 = January, 2 = Feburary
dow <- datesiso$wday # 0 = Sunday, 1 = Monday
year <- datesiso$year + 1900
datei <- (dow == 1) & (month > 3) & (month < 10) & (year > 1992)
results2 <- results[ , , , , , datei]
dates2 <- dates[datei]
nd <- sum(datei)
print(nd)
print(dates2)

delimiter <- '\t'

fn <- file('table.txt',
           open = 'at' # append text mode
           )

cat(paste('date',
          'basin',
          'MyLakeParameters',
          'LAKETEMP',
          'LAKETHERMCLINEDEPTH',
          'LAKESECCHIDEPTH',
          'LAKETP',
          'LAKEPIP',
          'LAKEPOP',
          'LAKEDIP',
          'LAKEDOP',
          'irradiance',
          sep = delimiter
          ),
    file = fn)
cat('\n', file = fn) # , append = TRUE)

for (bi in 1:(dim(results)[1])) {
   for (pi in 1:(dim(results)[2])) {
        out <- data.frame(matrix(NA, nrow = nd, ncol = 12))
        out[ , 1] <- dates2
        out[ , 2] <- bi
        out[ , 3] <- pi
        out[ , 4:12] <- round(t(results2[bi, pi, , ]), digits = 2)
        out[ , 12] <- round(out[ , 12])
        write.table(out, file = fn,
                    # append = TRUE,
                    quote = FALSE,
                    sep = delimiter,
                    row.names = FALSE, col.names = FALSE
                    )
      }
}

close(fn)


library(tidyverse)
library(np)

getSmoothedProbability = function(d) {
  smooth = (npudens(tdat=ordered(d$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(d$response),edat=ordered(c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15)))$dens+0.0000001)
  return (smooth/sum(smooth))
}

theme_set(theme_bw(18))
source("helpers.r")

###########################################
# OLD write data for mh to do prior inference on
load("../data/r.RData")

spreaded = r[,c("workerid","Item","response","responsetype")] %>% spread(responsetype, response)
head(spreaded)
write.table(spreaded[,c("workerid","Item","best_guess","confidence","ci_low","ci_high")],file="/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/bayesian_model_comparison/priors/data/priors_fourstep.txt",row.names=F,col.names=T,quote=F,sep=",")
###########################################

r1 = read.csv("../data/sinking_marbles1.csv", header=T)
r1$workerid = r1$workerid + 60

r2 = read.csv("../data/sinking_marbles2.csv", header=T)
r = rbind(r1,r2)
nrow(r) # 7200 data points

r$trial = r$slide_number_in_experiment - 2
r = r[,c("assignmentid","workerid", "rt", "cause", "effect","language","gender.1","age","gender", "response", "object","num_objects","trial","enjoyment","asses","comments","Answer.time_in_minutes","responsetype")]
r$Item = as.factor(paste(r$effect,r$object))
table(r$Item)/4

# figure out if people understood the task
spr = r %>%
  select(responsetype,response,Item,workerid) %>%
  spread(responsetype,response)

nrow(spr)
head(spr)
spr$interval = spr$ci_high - spr$ci_low
summary(spr)
# are there cases where people reversed low and high ci value?
spr[spr$interval < 0,]
# exclude these 10 trials, and also exclude subject 49 who reversed on 7 trials
r = droplevels(subset(r, workerid != 49))
r = droplevels(subset(r, workerid != 110 | Item != "dissolved oreos"))
r = droplevels(subset(r, workerid != 72 | Item != "melted pencils"))
r = droplevels(subset(r, workerid != 43 | Item != "popped eggs"))
nrow(r) # 7128 cases left

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

spr = r %>%
  select(responsetype,response,Item,workerid) %>%
  spread(responsetype,response)

nrow(spr)
head(spr)
spr$interval = spr$ci_high - spr$ci_low
summary(spr)

ggplot(spr, aes(x=interval,y=confidence)) +
  geom_point() +
  geom_smooth() #+
  #facet_wrap(~Item,scale="free")

# get smoothed priors for model
smoothed = r %>%
  filter(responsetype == "best_guess") %>%
  select(Item,response) %>%
  group_by(Item) %>%
  nest() %>%
  mutate(SmoothedProportion = map(data,getSmoothedProbability)) %>%
  select(-data) %>%
  unnest() %>%
  mutate(State = rep(c(0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15),length(unique(Item))))

ggplot(smoothed, aes(x=State,y=SmoothedProportion)) +
  geom_point() +
  geom_line() +
  facet_wrap(~Item)

smoothed_spread = smoothed %>%
  spread(State,SmoothedProportion)
write.csv(smoothed_spread,file="../data/priors_numbertask4step_smoothed.csv",row.names=F,quote=F)
write.csv(smoothed_spread,file="../../../../bayesian_model_comparison/data/priors_numbertask4step_smoothed.csv",row.names=F,quote=F)

# get empirical unsmoothed priors
bg = r %>% filter(responsetype == "best_guess")
priors = as.data.frame(prop.table(table(bg$Item,bg$response),mar=c(1)))
colnames(priors) = c("Item","State","EmpiricalProportion4Step")
priors = priors %>%
  mutate(State = as.numeric(as.character(State))) %>%
  left_join(smoothed,by=c("Item","State"))
head(priors)

gpriors = priors %>%
  gather(Type,Proportion,-Item,-State)

ggplot(gpriors,aes(State,y=Proportion,color=Type)) +
  geom_point() +
  geom_line() +
  facet_wrap(~Item)
ggsave(file="../graphs/empirical-smoothed.pdf",width=17,height=13)

# load the smoothed one-step number task priors and binned histogram priors and plot alongside 4step
onestep = read.csv("../../../../bayesian_model_comparison/data/priors_numbertask_smoothed.csv") %>%
  gather(State,Proportion,-Item) %>%
  mutate(State=as.numeric(as.character(gsub("X","",State))),Type = "OneStepNumberTaskProportion")

binned = read.csv("../../../../bayesian_model_comparison/data/priors_binnedhistogram_smoothed.csv") %>%
  gather(State,Proportion,-Item) %>%
  mutate(State=as.numeric(as.character(gsub("X","",State))),Type = "BinnedHistogramProportion")

allpriors = gpriors %>%
  bind_rows(onestep) %>%
  bind_rows(binned)

ggplot(allpriors,aes(State,y=Proportion,color=Type)) +
  geom_point() +
  geom_line() +
  facet_wrap(~Item)
ggsave(file="../graphs/allpriors.pdf",width=17,height=14)

# best_guesses = droplevels(subset(r, responsetype == "best_guess"))
# smoothed_dist15 = ddply(best_guesses, .(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))
# smoothed_dist15$SmoothedProportion = format(round(smoothed_dist15$SmoothedProportion,7), scientific=F)
# casted = dcast(smoothed_dist15, Item ~ State, value.var="SmoothedProportion")
# head(casted)
# write.table(casted,file="data/smoothed_15marbles_priors_withnames.txt",row.names=F,quote=F,sep="\t")
# write.table(casted,file="../../../models/wonky_world/fourstep_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/fourstep_15marbles_priors.txt",row.names=F,quote=F,sep="\t")
#
#
# head(smoothed_dist15)
# summary(smoothed_dist15)
# sum(smoothed_dist15[smoothed_dist15$Item == "ate the seeds birds",]$SmoothedProportion)
#
# expectations = ddply(r, .(Item), 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))
# expectations$expectation_corr = expectations$expectation/expectations$densitysum
# head(expectations)
#
# mean(expectations$expectation_corr)
# median(expectations$expectation_corr)
#
# ggplot(expectations, aes(x=expectation_corr)) +
#   geom_histogram() +
#   scale_x_continuous()
#
# head(expectations)
# write.table(expectations[,c("Item","expectation_corr")],row.names=F,sep="\t",quote=F,file="data/expectations.txt")
# ordered = expectations[order(expectations[,c("expectation_corr")]),c("Item","expectation_corr")]
# write.table(ordered[,c("Item","expectation_corr")],row.names=F,sep="\t",quote=F,file="data/ordered_expectations.txt")
# t = table(r$Item)
# t
#
# priors = as.data.frame(prop.table(table(best_guesses$Item,best_guesses$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)

## add smoothed single-step number task priors to data.frame
priorprobs = read.csv(file="../../../26_sinking-marbles-prior15_replication/results/data/priors_numbertask_smoothed.csv") %>%
  gather(State,OriginalPriorProbability,-Item) %>%
  mutate(State=gsub("X","",State))

# add original number task prior probabilities
r = r %>%
  left_join(priorprobs,by=c("Item","State"))

## add slider priors to data.frame
spriorprobs = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/23_sinking-marbles-prior-sliders-exactly/results/data/aggregated_priors.csv",sep="\t", header=T, quote="")
head(spriorprobs)
nrow(spriorprobs)
row.names(spriorprobs) = paste(spriorprobs$slider_id,spriorprobs$Item)

priors$SliderPrior = spriorprobs[paste(priors$State,as.character(priors$Item), sep=" "),]$normresponse
priors$SliderPriorYMin = spriorprobs[paste(priors$State,as.character(priors$Item), sep=" "),]$YMin
priors$SliderPriorYMax = spriorprobs[paste(priors$State,as.character(priors$Item), sep=" "),]$YMax
head(priors)
summary(priors)

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

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

ggplot(aes(x=gender.1), data=r) +
  geom_histogram()

ggplot(aes(x=rt), data=r) +
  geom_histogram() +
  scale_x_continuous(limits=c(0,50000))

ggplot(aes(x=age), data=r) +
  geom_histogram()

ggplot(aes(x=age,fill=gender.1), data=r) +
  geom_histogram()

ggplot(aes(x=enjoyment), data=r) +
  geom_histogram()

ggplot(aes(x=asses), data=r) +
  geom_histogram()

ggplot(aes(x=Answer.time_in_minutes), data=r) +
  geom_histogram()

ggplot(aes(x=age,y=Answer.time_in_minutes,color=gender.1), data=unique(r[,c("assignmentid","age","Answer.time_in_minutes","gender.1")])) +
  geom_point() +

  geom_smooth()

unique(r$comments)


#!/usr/bin/env r
#
# A faster lm() replacement based on Armadillo
#
# This improves on the previous version using GNU GSL
#
# Copyright (C) 2010 Dirk Eddelbuettel and Romain Francois
#
# This file is part of Rcpp.
#
# Rcpp is free software: you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# Rcpp is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with Rcpp.  If not, see <http://www.gnu.org/licenses/>.

source("lmArmadillo.R")

checkLmArmadillo <- function(y, X) {
    fun <- lmArmadillo()
    res <- fun(y, X)
    fit <- lm(y ~ X - 1)
    rc <- all.equal( as.numeric(res[[1]]), as.numeric(coef(fit))) &
          all.equal( as.numeric(res[[2]]), as.numeric(coef(summary(fit))[,2]))
    invisible(rc)
}

timeLmArmadillo <- function(y, X, N) {
    fun <- lmArmadillo();
    meantime <- mean(replicate(N, system.time(fun(y, X))["elapsed"]), trim=0.05)
}

set.seed(42)
n <- 5000
k <- 9
X <- cbind( rep(1,n), matrix(rnorm(n*k), ncol=k) )
truecoef <- 1:(k+1)
y <- as.numeric(X %*% truecoef + rnorm(n))

N <- 100

stopifnot(checkLmArmadillo(y, X))
mt <- timeLmArmadillo(y, X, N)
cat("Armadillo: Running", N, "simulations yields (trimmed) mean time", mt, "\n")


modelMatrix = function(x,
  interactions = FALSE, intercept = FALSE){
	#' Create a sparse design matrix from data frame
	#'
	#' \code{modelMatrix} takes in a data.frame and encodes it as a sparse model.Matrix object.
	#' Factors use treatment ("one-hot") encoding, creating indicator variables from categorical
	#' and binary variables.
    #' Note that names of categorical variables will change slightly
	#'	(n-1 unique values appended to name)
	#'
	#' @param x  A data.frame with finite, non-missing elements.
	#' @param interactions Logical; if \code{TRUE} then all interactions included.
	#' @param intercept Logcal; if \code{TRUE} then include a leading column of 1's.
	if(is.null(x))return(NULL) #Dealing w/ empty data
	#if (sum(sapply(x, is.finite)) != 0){
	#	stop('Creating model matrix requires all input elements be finite')}

	#Set R to use 1-hot encoding
	options(contrasts = rep("contr.treatment", 2))
    model_formula = as.formula( ~.) #All first order Effects
    if (interactions){model_formula = as.formula( ~(.)^2)} #1st order and interactions
   mat = model.matrix(model_formula, data = data.frame(x))

    if (!intercept){
		#Remove intercept column, making sure names are preserved
		n_vec = colnames(mat)
		mat = data.frame(mat[ ,-1])
		colnames(mat) = n_vec[-1]
	}
    #Drop any empty levels
	n_vec = colnames(mat)
	nonempty_indices = apply(abs(mat),2, sum) != 0
	mat = data.frame(mat[ ,nonempty_indices])
	p = length(mat)
	colnames(mat) = n_vec[nonempty_indices]
	n_cols = length(colnames(mat))

	#Export as Matrix
	mat = Matrix(sapply(mat, as.numeric))
   return( mat)
}


#研究t_for问题
#对不同占空比下的数据进行排列整理
#一张大图，对应一张小图，小图嵌套在大图中

#设定工作目录
setwd("D:/data")
library(xlsx)

#读取数据
k1<-read.xlsx("t_for.xls", sheetName = "0.2", header = TRUE)
k2<-read.xlsx("t_for.xls", sheetName = "0.3", header = TRUE)
k3<-read.xlsx("t_for.xls", sheetName = "0.4", header = TRUE)
k4<-read.xlsx("t_for.xls", sheetName = "0.5", header = TRUE)

#pdf保存
pdf("t_for_0.2.pdf")

#设定空间位置
par(fig=c(0,1,0,1), new = F)

##################################画图--占空比k为0.2#######################
plot(k1$fv, k1$X1.5, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Formation time t_for (ms)", main = "Formation time in duty = 0.2", cex.lab = 1.2, cex.main = 1.5, xlim = c(0, 1050), ylim = c(0.2, 40))

#model1 = loess(k1$X1.5 ~ k1$fv, span = 0.8 , degree = 2)
lines(k1$fv, k1$X1.5,  col="#458B74", pch=21, lwd=2.5, type="b", lty=2)

#model2 = loess(k1$X27 ~ k1$fv, span = 0.8, degree = 2)
lines(k1$fv, k1$X27, col="#FF00FF", pch=22, lwd=2.5, type="b", lty=2)

#model3 = loess(k1$X54 ~ k1$fv, span = 0.8, degree = 2)
lines(k1$fv, k1$X54, col="#EE0000", pch=23, lwd=2.5, type="b", lty=2)

#model4 = loess(k1$X180 ~ k1$fv, span = 0.8, degree =2)
lines(k1$fv, k1$X180, col="#27408B", pch=24, lwd=2.5, type="b", lty=2)

legend("topleft", c("1.5nl/min", "27nl/min", "54nl/min", "180nl/min"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, inset = .03, bty = "n")

###############画小图########
par(fig = c(0.3,0.98,0.15,0.98), new  = TRUE)

plot(k1$fv, k1$X1.5, xaxs = "i", col = 0, xlab = "0 ~ 250 Hz", ylab = "t_for (ms)", main = "", cex.lab = 1.2, cex.main = 1.5, xlim = c(0, 250), ylim = c(0.2, 40))

#model1 = loess(k1$X1.5 ~ k1$fv, span = 0.8 , degree = 2)
lines(k1$fv, k1$X1.5,  col="#458B74", lwd=2.5, type="o", lty=2)

#model2 = loess(k1$X27 ~ k1$fv, span = 0.8, degree = 2)
lines(k1$fv, k1$X27, col="#FF00FF", lwd=2.5, type="o", lty=2)

#model3 = loess(k1$X54 ~ k1$fv, span = 0.8, degree = 2)
lines(k1$fv, k1$X54, col="#EE0000", lwd=2.5, type="o", lty=2)

#model4 = loess(k1$X180 ~ k1$fv, span = 0.8, degree =2)
lines(k1$fv, k1$X180, col="#27408B", lwd=2.5, type="o", lty=2)

#legend("topleft", c("1.5nl/min", "27nl/min", "54nl/min", "180nl/min"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, bty = "n", inset = .03)

#画小小图
par(fig = c(0.45,0.95,0.35,0.95), new  = TRUE)

plot(k1$fv, k1$X1.5, xaxs = "i", col = 0, xlab = "0 ~ 125 Hz", ylab = "t_for (ms)", main = "", cex.lab = 1.2, cex.main = 1.5, xlim = c(0, 125), ylim = c(0.2, 38))

#model1 = loess(k1$X1.5 ~ k1$fv, span = 1.6 , degree = 2)
lines(k1$fv, k1$X1.5, col="#458B74", lwd=2, type="l")

#model2 = loess(k1$X27 ~ k1$fv, span = 1.6, degree = 2)
lines(k1$fv,  k1$X27, col="#FF00FF", lwd=2, type="l")

#model3 = loess(k1$X54 ~ k1$fv, span = 1.6, degree = 2)
lines(k1$fv, k1$X54, col="#EE0000", lwd=2, type="l")

#model4 = loess(k1$X180 ~ k1$fv, span = 1.6, degree =2)
lines(k1$fv, k1$X180, col="#27408B", lwd=2, type="l")

#legend("topleft", c("1.5nl/min", "27nl/min", "54nl/min", "180nl/min"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.2, bty = "n", inset = .03)

dev.off()


  cumsum.jae = function( x) {
    nv = length(x)
    for (i in 2:nv)  x[i] = sum(x[i-1], x[i], na.rm=T)
    x[x==0] = NA
    return(x)
  }


# Plot parameters of these models
#
#   This file allows you to plot all the
#
#
#
#
#
# CC, 5th March 2019 - Boston University, Boston, MA

rm(list=ls())
require(ggplot2)
require(gridExtra)

source("chartr-HelperFunctions.r")

dataDir = "caseStudy1/"
resultsDir = 'caseStudy1_Fits/'
subjnam = "Subj1"
modelToPlot = "cDDMSvSt"
VERBOSE = TRUE;

load(paste(dataDir,subjnam,sep=""))
N = sum(dat$n)

allValidModels = returnListOfModels()
modelList = unname(allValidModels$modelNames)
modelOutput=list()

# load each model's output and store in modelOutput
nreps = 5;
allRuns = letters[1:nreps];
tempReObj = seq(1,length(allRuns))

cat(sprintf("\n%15s: ", modelToPlot))

for(m in seq(1,length(allRuns)))
{
  fnam = allRuns[m];
  fileName = paste(resultsDir,subjnam,"-",modelToPlot,"-",fnam,sep="") ;
  if(file.exists(fileName))
  {
    load(fileName)
    if(m==1)
    {
      parFrame = data.frame(matrix(0L, nrow = nreps, ncol = length(out$pars)+1));
      colnames(parFrame) = c(names(out$pars),"fit");
      rownames(parFrame) = allRuns;
    }
    parFrame[fnam,] = c(out$pars, out$reobj);
    # Finish selecting
  }
  else
  {
    print(paste("Model:",model,'-',fnam, " not found",sep=""))
  }
}

# Now plot all the parameters associated with the five runs
nParameters = length(out$pars);
nCols = 5;
nRows = ceiling(nParameters/nCols)
par(mfrow=c(nRows, nCols))
parnames = colnames(parFrame)

plots = list();
for(m in seq(1,nParameters))
{
  S = data.frame(data = parFrame[,parnames[m]], runs=seq(1,5));
  plots[[m]] = ggplot(S, aes(runs,data), stat="identity") + xlab('') + ylab('') +
    geom_col(alpha=0.6)  + coord_flip() + theme_minimal()+ ggtitle(parnames[m]) + theme(panel.grid.minor = element_blank(), panel.grid.major.y = element_blank()) +
  theme(axis.line.x = element_line(colour = "gray"),axis.ticks.x = element_line("gray", size=.25), axis.ticks.length = unit(.25,"cm")) + theme(text = element_text(size=14));

}

do.call("grid.arrange", c(plots, ncol=nCols))


 DGESVX Example Program Results

 Solution(s)
             1          2
 1      1.0000     3.0000
 2     -1.0000     2.0000
 3      3.0000     4.0000
 4     -5.0000     1.0000

 Backward errors (machine-dependent)
       6.8E-17    9.1E-17

 Estimated forward error bounds (machine-dependent)
       2.4E-14    3.6E-14

 A has been row scaled as diag(R)*A

 Reciprocal condition number estimate of scaled matrix
       1.8E-02

 Estimate of reciprocal pivot growth factor
       7.4E-01


kasitsiTabel <-c( 0, 1, 3, 6, 10, 15, 21, 28, 36, 45, 55, 66, 78, 91, 105, 120, 136, 153, 171, 190, 210, 231, 253, 276, 300, 325, 351, 378, 406, 435, 465, 496, 528, 561, 595, 630, 666, 703, 741, 780, 820, 861, 903, 946, 990, 1035, 1081, 1128, 1176, 1225)
pihta <- c(0, 0, 2, 3, 9, 12, 21, 26, 30, 35, 41, 46, 54, 59, 67, 74, 82, 89, 97, 106, 116, 125, 133, 144, 154, 163, 173, 184, 196, 207, 219, 230, 242, 255, 267, 280, 292, 305, 319, 332, 346, 361, 375, 390, 404, 419, 435, 450, 466, 481)

#X11.options(type="nbcairo")
plot(kasitsiTabel, type="o", col="blue", ylim=c(0, 1300), xlab = "N", ylab="K")
lines(pihta, type="o", pch=22, lty=2, col="red")

leg <- c(expression("k"[0]), expression("k"[1]))
cols <- c("blue", "red")
legend(0, 1300, leg, cex = 1, cols, pch=22, lty=1:2)


# Data Wrangling in R
# 4.5 Dates and Times in R

# Load the tidyverse
library(tidyverse)
library(lubridate)

# Read the dataset
### CHANGE THIS URL!!!
weather <- read_csv("https://s3.amazonaws.com/msba-70200/mexicanweather.csv")
weather <- read_csv("http://594442.youcanlearnit.net//mexicanweather.csv")

# Let's look at what we have
weather

# We can use lubridate functions to extract elements of the date
weather$year <- year(weather$date)
weather$month <- month(weather$date)
weather$day <- day(weather$date)
weather

# We can also extract some derived values such as the weekday
wday("2018-04-01")

# or day of the year
yday("2018-04-01")

# We can also use lubridate to create date values out of different strings

mdy("04/01/2018")
mdy("04/01/18")
dmy("04/01/18")
ymd("2018-04-01")

# And we can include times

ymd_hms("2018-04-01 08:00:00")

# Let's force that to eastern time

ymd_hms("2018-04-01 08:00:00", tz='EST')


# 3. faza:
# VIZUALIZACIJA PODATKOV

tabela = read_csv(
  "podatki/tabela.csv",
  locale = locale(encoding = "Windows-1250"),
  col_types = cols(
    .default = col_guess(),
    regija = col_factor()
  )
) %>% dplyr::select(-1)

################################################################################
# Dodajanje novih spremenljivk
#-------------------------------------------------------------------------------

tabela1 <- tabela %>% mutate(st.poskodovanih.na.10000.preb = stevilo.poskodovanih / prebivalci * 10000,
                             st.nesrec.na.10000.preb = stevilo.nesrec / prebivalci * 10000,
                             st.nesrec.na.1000.vozil = stevilo.nesrec / stevilo.vozil * 1000)

tabela1 <- tabela1 %>%
  group_by(regija) %>%
  mutate(
    indeks.rasti.nesrec = stevilo.nesrec - lag(stevilo.nesrec),
    indeks.rasti.poskodovanih = stevilo.poskodovanih - lag(stevilo.poskodovanih)
  )

################################################################################
# Analiza prvega in zadnjega opazovanega leta; število nesreč

prvo.leto <- min(tabela1$leto)
zadnje.leto <- max(tabela$leto)

tabela1.graf1 <- tabela1 %>% filter(leto == prvo.leto)
tabela1.graf2 <- tabela1 %>% filter(leto == zadnje.leto)
#-------------------------------------------------------------------------------

# Graf števila nesreč na 10.000 prebivalcev v letu 2007

graf.nesrece.2007 <- ggplot(tabela1.graf1, mapping = aes(x = reorder(regija, -st.nesrec.na.10000.preb), y = st.nesrec.na.10000.preb)) +
  geom_bar(stat = "identity") +
  xlab("Regija") + ylab("Število nesreč na 10.000 prebivalcev") +
  ggtitle("Nesreče leta 2007") +
  theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
  tabela1.graf1 %>%
  filter(regija == "SLOVENIJA") %>%
  geom_bar(
    mapping = aes(x = regija, y = st.nesrec.na.10000.preb),
    stat = "identity",
    fill = "#FF6666"
  )

#-------------------------------------------------------------------------------

# Graf števila nesreč na 10.000 prebivalcev v letu 2020

graf.nesrece.2020 <- ggplot(tabela1.graf2, mapping = aes(x = reorder(regija, -st.nesrec.na.10000.preb), y = st.nesrec.na.10000.preb)) +
  geom_bar(stat = "identity") +
  xlab("Regija") + ylab("Število nesreč na 10.000 prebivalcev") +
  ggtitle("Nesreče leta 2020") +
  theme(axis.text.x = element_text(angle = 45, vjust = 0.5)) +
  tabela1.graf2 %>%
  filter(regija == "SLOVENIJA") %>%
  geom_bar(
    mapping = aes(x = regija, y = st.nesrec.na.10000.preb),
    stat = "identity",
    fill = "#FF6666"
  )
#-------------------------------------------------------------------------------

# Graf poškodovanih po letih, ločeno po regijah (brez Slovenije)

graf.poskodovani <- tabela1 %>% filter(regija != "SLOVENIJA") %>%
  ggplot(
    mapping = aes(x = leto, y = st.poskodovanih.na.10000.preb, color = regija)
  ) +
  geom_line() +
  theme(
    axis.text.x = element_text(angle = 45, vjust = 0.5),
    legend.position = "bottom"
  ) +
  xlab("Leto") + ylab("Število") +
  ggtitle("Poškodovani na 10.000 prebivalcev")
#-------------------------------------------------------------------------------

# Grafi po regijah za število nesreč na 1.000 vozil

graf.nesrece.vozila <- ggplot(tabela1) +
  aes(x = leto, y = st.nesrec.na.1000.vozil) +
  geom_col() +
  facet_wrap(. ~ regija)
#-------------------------------------------------------------------------------

# Graf nesrec na vozilo v odvisnosti od nesrec na prebivalca, za regiji mojega doma in regijo fakultete

graf.nesrece.preb.vozila <- ggplot(tabela1 %>% filter(regija %in% c("Osrednjeslovenska", "Jugovzhodna Slovenija", "Posavska"))) +
  aes(x = st.nesrec.na.1000.vozil, y = st.nesrec.na.10000.preb, color = leto, shape = regija) +
  geom_point() +
  xlab("Nesreče na 1.000 vozil") + ylab("Nesreče na 10.000 prebivalcev") +
  ggtitle("Nesreče na vozilo v primerjavi \n z nesrečami na prebivalca treh regij")
#-------------------------------------------------------------------------------

# Indeks rasti nesreč za Osrednjeslovensko regijo

graf.indeks1 <- ggplot(tabela1 %>% filter(regija == "Osrednjeslovenska") %>% dplyr::select(leto, indeks.rasti.nesrec)) +
  aes(x = leto, y = indeks.rasti.nesrec) +
  geom_line() +
  xlab("Leto") + ylab("Indeks") +
  ggtitle("Indeks rasti nesreč za Osrednjeslovensko") +
  theme_light()

# Indeks rasti nesreč za Slovenijo

graf.indeks2 <- ggplot(tabela1 %>% filter(regija == "SLOVENIJA") %>% dplyr::select(leto, indeks.rasti.nesrec)) +
  aes(x = leto, y = indeks.rasti.nesrec) +
  geom_line() +
  xlab("Leto") + ylab("Indeks") +
  ggtitle("Indeks rasti nesreč za Slovenijo") +
  theme_minimal()
#-------------------------------------------------------------------------------

# Graf kvantilov za število nesreč

graf.kvantili.nesrece <- ggplot(tabela1 %>% mutate(leto = as.character(leto))) + # Dodala mutate, ker leto ni 'character'
  aes(x = leto, y = stevilo.nesrec) +
  geom_boxplot(outlier.shape=8) +
  xlab("Število nesreč") + ylab("Leto") +
  ggtitle("Graf kvantilov za število \n nesreč za vsa leta")
#-------------------------------------------------------------------------------

# Graf kvantilov za število poškodovanih

graf.kvantili.poskodovani <- ggplot(tabela1 %>% mutate(leto = as.character(leto))) + # Dodala mutate, ker leto ni 'character'
  aes(x = leto, y = stevilo.poskodovanih) +
  geom_boxplot(notch=TRUE) +
  xlab("Število poškodovanih") + ylab("Leto") +
  ggtitle("Graf kvantilov za število \n poškodovanih za vsa leta")
#-------------------------------------------------------------------------------

# Graf števila nesreč po letih, barvno ločeno po regijah

graf.nesrece.skupaj <- tabela1 %>%
  group_by(leto) %>%
  filter(regija != "SLOVENIJA") %>%
  ggplot(
    mapping = aes(x = leto, y = stevilo.nesrec, fill = reorder(regija, prebivalci))
  ) +
  geom_bar(
    stat = "identity",
    position = position_fill()
  ) + labs(fill="Regija") +
  xlab("Leto") + ylab("Število nesreč") +
  ggtitle("Delež nesreč po regijah")

################################################################################
# ZEMLJEVIDI
#-------------------------------------------------------------------------------

# Uvoz zemljevida

source("lib/uvozi.zemljevid.r")

Slovenija <- uvozi.zemljevid("http://biogeo.ucdavis.edu/data/gadm2.8/shp/SVN_adm_shp.zip",
                             "SVN_adm1", encoding="UTF-8") %>% fortify()
colnames(Slovenija)[12]<-'regija'  #preimenujemo stolpec
Slovenija$regija <- gsub('Notranjsko-kraška', 'Primorsko-notranjska', Slovenija$regija)
Slovenija$regija <- gsub('Spodnjeposavska', 'Posavska', Slovenija$regija)
#-------------------------------------------------------------------------------

# Prostorska vizualizacija podatkov o prometnih nesrečah
## Zemljevid nesreč po slovenskih statističnih regijah, leto 2020

tabela.za.zemljevid <- filter(tabela1, leto==2020) %>% dplyr::select(regija, leto, stevilo.nesrec)

zemljevid.nesrec1 <- ggplot() +
  geom_polygon(data = right_join(tabela.za.zemljevid, Slovenija, by = "regija"),
               aes(x = long, y = lat, group = group, fill = stevilo.nesrec))+
  ggtitle("Število nesreč po regijah \n za leto 2020") +
  theme(axis.title=element_blank(), axis.text=element_blank(),
        axis.ticks=element_blank(), panel.background = element_blank(),
        plot.title = element_text(hjust = 0.5)) +
  scale_fill_gradient(low = '#FCDADA', high='#970303') +
  labs(fill="Število po regijah") +
  geom_path(data = right_join(tabela.za.zemljevid, Slovenija,
                              by = "regija"), aes(x = long, y = lat,
                                                             group = group),
            color = "white", size = 0.1)

#-------------------------------------------------------------------------------

##Zemljevid nesreč po slovenskih statističnih regijah, leto 2007

tabela.za.zemljevid1 <- filter(tabela1, leto==2007) %>% dplyr::select(regija, leto, st.nesrec.na.10000.preb)

zemljevid.nesrec2 <- ggplot() +
  geom_polygon(data = right_join(tabela.za.zemljevid1, Slovenija, by = "regija"),
               aes(x = long, y = lat, group = group, fill = st.nesrec.na.10000.preb))+
  ggtitle("Število nesreč po regijah \n za leto 2007") +
  theme(axis.title=element_blank(), axis.text=element_blank(),
        axis.ticks=element_blank(), panel.background = element_blank(),
        plot.title = element_text(hjust = 0.5)) +
  scale_fill_gradient(low = 'lightpink1', high='indianred4') +
  labs(fill="Število po regijah") +
  geom_path(data = right_join(tabela.za.zemljevid1, Slovenija,
                              by = "regija"), aes(x = long, y = lat,
                                                  group = group),
            color = "white", size = 0.1)
#-------------------------------------------------------------------------------

##Zemljevid poškodovanih po slovenskih statističnih regijah, leto 2010

tabela.za.zemljevid2 <- filter(tabela1, leto==2010) %>% dplyr::select(regija, leto, st.poskodovanih.na.10000.preb)

zemljevid.poskodovanih <- ggplot() +
  geom_polygon(data = right_join(tabela.za.zemljevid2, Slovenija, by = "regija"),
               aes(x = long, y = lat, group = group, fill = st.poskodovanih.na.10000.preb))+
  ggtitle("Število poškodovanih po regijah \n za leto 2010") +
  theme(axis.title=element_blank(), axis.text=element_blank(),
        axis.ticks=element_blank(), panel.background = element_blank(),
        plot.title = element_text(hjust = 0.5)) +
  scale_fill_gradient(low = 'lightblue2', high='navyblue') +
  labs(fill="Število po regijah") +
  geom_path(data = right_join(tabela.za.zemljevid2, Slovenija,
                              by = "regija"), aes(x = long, y = lat,
                                                  group = group),
            color = "white", size = 0.1)

#-------------------------------------------------------------------------------

##Zemljevid indeksa prometnih nesreč po slovenskih statističnih regijah, leto 2019

tabela.za.zemljevid3 <- filter(tabela1, leto==2019) %>% dplyr::select(regija, leto, indeks.rasti.nesrec)

zemljevid.indeksa.nesrec <- ggplot() +
  geom_polygon(data = right_join(tabela.za.zemljevid3, Slovenija, by = "regija"),
               aes(x = long, y = lat, group = group, fill = indeks.rasti.nesrec))+
  ggtitle("Indeks nesreč po regijah \n za leto 2019") +
  theme(axis.title=element_blank(), axis.text=element_blank(),
        axis.ticks=element_blank(), panel.background = element_blank(),
        plot.title = element_text(hjust = 0.5)) +
  scale_fill_gradient(low = 'skyblue2', high='maroon4') +
  labs(fill="Indeks") +
  geom_path(data = right_join(tabela.za.zemljevid3, Slovenija,
                              by = "regija"), aes(x = long, y = lat,
                                                  group = group),
            color = "white", size = 0.1)


# Databricks notebook source
# MAGIC %md
# MAGIC

# MAGIC

# MAGIC
# MAGIC
# MAGIC # Analysis — USA Performance
# MAGIC
# MAGIC At the risk of being an "ugly American," I want to use the acquired data to explore how the US has performed at the Olympics.

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

library(SparkR)

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

medals <- read.df(path=paste0("dbfs:/olympics/medals"), source="delta", mode="overwrite")
medal_table <- read.df(path=paste0("dbfs:/olympics/medal_table"), source="delta", mode="overwrite")
display(medals)

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

# MAGIC %md
# MAGIC ### How Has the US Finished in the Medal Standings Over the Years?

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

df <- medal_table |>
        groupBy("Year", "Season", "Country") |>
        sum("Gold", "Total", "Weighted")

df <- df |> rename(Gold = df$`sum(Gold)`, Total = df$`sum(Total)`, Weighted = df$`sum(Weighted)`)
df <- df |> arrange(df$Year, df$Season, desc(df$Weighted), df$Country)

ws <- orderBy(windowPartitionBy("Year", "Season"), desc(df$Gold))
df <- df |> withColumn("Gold_Rank", over(rank(), ws))

ws <- orderBy(windowPartitionBy("Year", "Season"), desc(df$Total))
df <- df |> withColumn("Total_Rank", over(rank(), ws))

ws <- orderBy(windowPartitionBy("Year", "Season"), desc(df$Weighted))
df <- df |> withColumn("Weighted_Rank", over(rank(), ws))

first <- df |> filter(df$Weighted_Rank == 1) |> groupBy("Year", "Season") |> agg(Winner = min(df$Country))
usa_df <- join(alias(df, "df"), first, df$Year == first$Year & df$Season == first$Season, joinType="left_outer") |>
            selectExpr("df.*",  "Winner") |>
            filter(df$Country == "USA") |>
            orderBy("Year", "Season")

display(usa_df)

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

# DBTITLE 1,In Which Editions Was US the Most Dominant?
# We will define "dominant" as the percentage of available medals won

totals_df <- df |> groupBy("Year", "Season") |> agg(Total_Gold = sum(df$Gold), Total_Total = sum(df$Total), Total_Weighted = sum(df$Weighted))

x <- join(alias(df, "df"), alias(totals_df, "t"), df$Year == totals_df$Year & df$Season == totals_df$Season, joinType="outer") |>
        selectExpr("df.Year", "df.Season", "df.Country", "df.Gold / t.Total_Gold AS Gold_Perc", "df.Gold_Rank", "df.Total / t.Total_Total AS Total_Perc", "df.Total_Rank", "df.Weighted / t.Total_Weighted AS Weighted_Perc", "df.Weighted_Rank") |>
        filter("Country = 'USA'")

x <- x |> arrange(desc(x$Weighted_Perc))

display(x)

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

# DBTITLE 1,In Which Sports Has US Won the Most Medals?
x <- medal_table |>
        filter("Country = 'USA'") |>
        groupBy("Season", "DisciplineID", "Discipline") |>
        agg(Gold = sum(medal_table$Gold), Total = sum(medal_table$Total), Weighted = sum(medal_table$Weighted))
x <- x |> arrange(desc(x$Total))
display(x)

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

# DBTITLE 1,In Which Sports is US the Most Dominant?
totals_df <- medal_table |>
                groupBy("Season", "DisciplineID", "Discipline") |>
                agg(Total_Gold = sum(medal_table$Gold), Total_Total = sum(medal_table$Total), Total_Weighted = sum(medal_table$Weighted))

x <- medal_table |>
        filter("Country = 'USA'") |>
        groupBy("Season", "DisciplineID", "Discipline") |>
        agg(Gold = sum(medal_table$Gold), Total = sum(medal_table$Total), Weighted = sum(medal_table$Weighted))

x <- join(alias(x, "x"), alias(totals_df, "t"), x$Season == totals_df$Season & x$DisciplineID == totals_df$DisciplineID, joinType="outer") |>
       fillna(0) |>
       selectExpr("t.Season", "t.DisciplineID", "t.Discipline", "Gold / Total_Gold AS Gold_Perc", "Total / Total_Total AS Total_Perc", "Weighted / Total_Weighted AS Weighted_Perc")

x <- x |> arrange(desc(x$Total_Perc))

display(x)

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

# MAGIC %md
# MAGIC ### Questions
# MAGIC  - Performance of men vs women
# MAGIC  - Which sports do women excel in vs men?
# MAGIC  - Longest medal streaks
# MAGIC  - Longest medal draughts
# MAGIC  - Which events has US won largest percentage of medals?
# MAGIC  - What sports did US once dominate but no longer does (or vice versa)?
# MAGIC  - Which sports is US worst in?


# load libraries
library("raster")
library("rgdal")

#### Compute 95 quantiles on SIMULATION

fs <- list.files("./res/stacks",full.names=TRUE)

res_rate <- list()
res_prop <- list()

for(i in 1:length(fs)){

  cat("Computing",i,"/",length(fs),":",fs[i],"\n")

  # load file
  st_land <- readRDS(fs[i])

  # Transform T and M to 1
  st_land[st_land==0] <- NA
  st_land[st_land==1] <- 0 # B
  st_land[st_land==4] <- 0 # R
  st_land[st_land==2] <- 1 # T
  st_land[st_land==3] <- 1 # M

  # convert land as data.frame
  land_df <- as.data.frame(st_land,xy=T)
  land_df$y <- (land_df$y - min(land_df$y)) / 1000 # convert in km relative to the grid

  # get 95e percentile of T+M distrib for each year
  # Compute on the entire grid
  quan <- sapply(3:ncol(land_df),function(x){
    quantile(land_df[which(land_df[,x]==1),'y'],probs=c(.95))
  })

  # format rate output
  quan_df <- as.data.frame(t(c(fs[i],quan)))
  names(quan_df)[-1] <- names(land_df)[3:ncol(land_df)]
  names(quan_df)[1] <- "filename"

  ls_prop <- list()

  # compute prop on rasterStack
  for(l in 1:nlayers(st_land)){
    temp_land <- as.matrix(st_land[[l]])
    temp_land[is.na(temp_land)] <- 1
    prop <- apply(temp_land,1,sum)/ncol(temp_land)
    lat <- seq(0,(length(prop)-1)*res(st_land)[1],res(st_land)[1])/1000
    ls_prop[[l]] <- data.frame(filename=fs[i],year=names(st_land[[l]]),lat=rev(lat),prop=prop)
  }

  # Assign res_rate and res_prop
  res_prop[[i]] <- do.call(rbind,ls_prop)
  res_rate[[i]] <- quan_df

}

# Reshape for saving as RDS
df_prop <- do.call(rbind,res_prop)
df_prop$filename <- as.character(df_prop$filename)
df_prop$year <- as.character(df_prop$year)
df_prop$year <- as.numeric(stringr::str_replace_all(df_prop$year,"X",""))

# Extract model type and res
df_prop$model <- unlist(lapply(strsplit(df_prop$filename,"[-.]"),function(x) return(x[3])))
df_prop$res <- unlist(lapply(strsplit(df_prop$filename,"[-.]"),function(x) return(x[4])))

# SAVE PROP data.frame
saveRDS(df_prop,file='./res/df_prop_simus.rds')

# Reshape for saving as RDS
df_rate <- reshape2::melt(do.call(rbind,res_rate),id.vars=c('filename'))
names(df_rate)[2:3] <- c("year","perc_95")
df_rate$perc_95 <- as.numeric(df_rate$perc_95)
df_rate$year <- as.numeric(stringr::str_replace_all(df_rate$year,"X",""))
df_rate$filename <- as.character(df_rate$filename)

# Extract model type and res
df_rate$model <- unlist(lapply(strsplit(df_rate$filename,"[-.]"),function(x) return(x[3])))
df_rate$res <- unlist(lapply(strsplit(df_rate$filename,"[-.]"),function(x) return(x[4])))

# SAVE RATE data.frame
saveRDS(df_rate,file='./res/df_rate_simus.rds')

##################
#### Compute 95 quantiles on SOLVED model

fs <- list.files('./data/futStatesGrid/analytic/stacks',full.names=TRUE)

res_rate <- list()
res_prop <- list()

for(i in 1:length(fs)){
  land <- readRDS(fs[i])

  which.max2 <- function(x, ...){
    max_idx <- which.max(x)   # Get the max
    ifelse(length(max_idx)==0,return(NA),return(max_idx))
  }

  # get higher prob
  land_state <- calc(land,which.max2)
  land_state[land_state==2] <- 0 # B
  land_state[land_state==1] <- 1 # T
  land_state[land_state==3] <- 1 # M

  # convert land as data.frame
  land_df <- as.data.frame(land_state,xy=T)
  land_df$y <- (land_df$y - min(land_df$y)) / 1000 # convert in km relative to the grid
  land_df$x <- (land_df$x + abs(min(land_df$x))) / 1000

  # get 95e percentile of T+M distrib for each year
  # Compute on the entire grid
  quan <- sapply(0:max(land_df$x),function(pos){
    data <- subset(land_df, x == pos & layer == 1)
    return(quantile(data[,'y'],probs=c(.95)))
  })

  # format rate output
  md <- unlist(strsplit(fs[i],"[-.]"))
  res_rate[[i]] <- data.frame(filename=fs[i],year=md[5],perc_95=quan,model="analytic",res=1000)

  # compute prop along x
  prop <- aggregate(layer ~ y,data=land_df,FUN=mean)
  names(prop) <- c('lat','prop')
  res_prop[[i]] <- data.frame(filename=fs[i],year=md[5],prop,model="analytic",res=1000)

}

df_prop <- do.call(rbind,res_prop)
df_rate <- do.call(rbind,res_rate)

# reshape df_rate to save
df_rate$model <- as.character(df_rate$model)
df_rate$filename <- as.character(df_rate$filename)
df_rate$year <- as.numeric(as.character(df_rate$year))

# reshape df_prop to save
df_prop$model <- as.character(df_prop$model)
df_prop$filename <- as.character(df_prop$filename)
df_prop$year <- as.numeric(as.character(df_prop$year))

# SAVE RATE AND PROP as data.frame
saveRDS(df_rate,file='./res/df_rate_analytic.rds')
saveRDS(df_prop,file='./res/df_prop_analytic.rds')


library('missForest')

## Transformando espacos brancos em NA
dm_inputdf[dm_inputdf==""] <- NA

## Aplicando imputacao
imp <- missForest(dm_inputdf, maxiter = 2, ntree = 30)

## pegando dados imputados
dm_scoreddf <- imp$ximp
dm_scoreddf$BAD <- as.numeric(dm_scoreddf$BAD) - 1

## Output BAD
print("/nInput")
head(dm_inputdf$BAD)

## Data frame output
print("/nScored")
head(dm_scoreddf$BAD)

## Data frame print
print("/nDataFrame")
head(dm_scoreddf)


#' Dot plot
#'
#' In a dot plot, the width of a dot corresponds to the bin width
#' (or maximum width, depending on the binning algorithm), and dots are
#' stacked, with each dot representing one observation.
#'
#' There are two basic approaches: \emph{dot-density} and \emph{histodot}.
#' With dot-density binning, the bin positions are determined by the data and
#' `binwidth`, which is the maximum width of each bin. See Wilkinson
#' (1999) for details on the dot-density binning algorithm. With histodot
#' binning, the bins have fixed positions and fixed widths, much like a
#' histogram.
#'
#' When binning along the x axis and stacking along the y axis, the numbers on
#' y axis are not meaningful, due to technical limitations of ggplot2. You can
#' hide the y axis, as in one of the examples, or manually scale it
#' to match the number of dots.
#'
#' @eval rd_aesthetics("geom", "dotplot")
#' @section Computed variables:
#' \describe{
#'   \item{x}{center of each bin, if binaxis is "x"}
#'   \item{y}{center of each bin, if binaxis is "x"}
#'   \item{binwidth}{max width of each bin if method is "dotdensity";
#'     width of each bin if method is "histodot"}
#'   \item{count}{number of points in bin}
#'   \item{ncount}{count, scaled to maximum of 1}
#'   \item{density}{density of points in bin, scaled to integrate to 1,
#'     if method is "histodot"}
#'   \item{ndensity}{density, scaled to maximum of 1, if method is "histodot"}
#' }
#'
#' @inheritParams layer
#' @inheritParams geom_point
#' @param stackdir which direction to stack the dots. "up" (default),
#'   "down", "center", "centerwhole" (centered, but with dots aligned)
#' @param stackratio how close to stack the dots. Default is 1, where dots
#'   just touch. Use smaller values for closer, overlapping dots.
#' @param dotsize The diameter of the dots relative to `binwidth`, default 1.
#' @param stackgroups should dots be stacked across groups? This has the effect
#'   that `position = "stack"` should have, but can't (because this geom has
#'   some odd properties).
#' @param binaxis The axis to bin along, "x" (default) or "y"
#' @param method "dotdensity" (default) for dot-density binning, or
#'   "histodot" for fixed bin widths (like stat_bin)
#' @param binwidth When `method` is "dotdensity", this specifies maximum bin
#'   width. When `method` is "histodot", this specifies bin width.
#'   Defaults to 1/30 of the range of the data
#' @param binpositions When `method` is "dotdensity", "bygroup" (default)
#'   determines positions of the bins for each group separately. "all" determines
#'   positions of the bins with all the data taken together; this is used for
#'   aligning dot stacks across multiple groups.
#' @param origin When `method` is "histodot", origin of first bin
#' @param right When `method` is "histodot", should intervals be closed
#'   on the right (a, b], or not [a, b)
#' @param width When `binaxis` is "y", the spacing of the dot stacks
#'   for dodging.
#' @param drop If TRUE, remove all bins with zero counts
#' @export
#' @references Wilkinson, L. (1999) Dot plots. The American Statistician,
#'    53(3), 276-281.
#' @examples
#' ggplot(mtcars, aes(x = mpg)) +
#'   geom_dotplot()
#'
#' ggplot(mtcars, aes(x = mpg)) +
#'   geom_dotplot(binwidth = 1.5)
#'
#' # Use fixed-width bins
#' ggplot(mtcars, aes(x = mpg)) +
#'   geom_dotplot(method="histodot", binwidth = 1.5)
#'
#' # Some other stacking methods
#' ggplot(mtcars, aes(x = mpg)) +
#'   geom_dotplot(binwidth = 1.5, stackdir = "center")
#'
#' ggplot(mtcars, aes(x = mpg)) +
#'   geom_dotplot(binwidth = 1.5, stackdir = "centerwhole")
#'
#' # y axis isn't really meaningful, so hide it
#' ggplot(mtcars, aes(x = mpg)) + geom_dotplot(binwidth = 1.5) +
#'   scale_y_continuous(NULL, breaks = NULL)
#'
#' # Overlap dots vertically
#' ggplot(mtcars, aes(x = mpg)) +
#'   geom_dotplot(binwidth = 1.5, stackratio = .7)
#'
#' # Expand dot diameter
#' ggplot(mtcars, aes(x = mpg)) +
#'   geom_dotplot(binwidth = 1.5, dotsize = 1.25)
#'
#' # Change dot fill colour, stroke width
#' ggplot(mtcars, aes(x = mpg)) +
#'   geom_dotplot(binwidth = 1.5, fill = "white", stroke = 2)
#'
#' \donttest{
#' # Examples with stacking along y axis instead of x
#' ggplot(mtcars, aes(x = 1, y = mpg)) +
#'   geom_dotplot(binaxis = "y", stackdir = "center")
#'
#' ggplot(mtcars, aes(x = factor(cyl), y = mpg)) +
#'   geom_dotplot(binaxis = "y", stackdir = "center")
#'
#' ggplot(mtcars, aes(x = factor(cyl), y = mpg)) +
#'   geom_dotplot(binaxis = "y", stackdir = "centerwhole")
#'
#' ggplot(mtcars, aes(x = factor(vs), fill = factor(cyl), y = mpg)) +
#'   geom_dotplot(binaxis = "y", stackdir = "center", position = "dodge")
#'
#' # binpositions="all" ensures that the bins are aligned between groups
#' ggplot(mtcars, aes(x = factor(am), y = mpg)) +
#'   geom_dotplot(binaxis = "y", stackdir = "center", binpositions="all")
#'
#' # Stacking multiple groups, with different fill
#' ggplot(mtcars, aes(x = mpg, fill = factor(cyl))) +
#'   geom_dotplot(stackgroups = TRUE, binwidth = 1, binpositions = "all")
#'
#' ggplot(mtcars, aes(x = mpg, fill = factor(cyl))) +
#'   geom_dotplot(stackgroups = TRUE, binwidth = 1, method = "histodot")
#'
#' ggplot(mtcars, aes(x = 1, y = mpg, fill = factor(cyl))) +
#'   geom_dotplot(binaxis = "y", stackgroups = TRUE, binwidth = 1, method = "histodot")
#' }
geom_dotplot <- function(mapping = NULL, data = NULL,
                         position = "identity",
                         ...,
                         binwidth = NULL,
                         binaxis = "x",
                         method = "dotdensity",
                         binpositions = "bygroup",
                         stackdir = "up",
                         stackratio = 1,
                         dotsize = 1,
                         stackgroups = FALSE,
                         origin = NULL,
                         right = TRUE,
                         width = 0.9,
                         drop = FALSE,
                         na.rm = FALSE,
                         show.legend = NA,
                         inherit.aes = TRUE) {
  # If identical(position, "stack") or position is position_stack(), tell them
  # to use stackgroups=TRUE instead. Need to use identical() instead of ==,
  # because == will fail if object is position_stack() or position_dodge()
  if (!is.null(position) &&
      (identical(position, "stack") || (inherits(position, "PositionStack"))))
    message("position=\"stack\" doesn't work properly with geom_dotplot. Use stackgroups=TRUE instead.")

  if (stackgroups && method == "dotdensity" && binpositions == "bygroup")
    message('geom_dotplot called with stackgroups=TRUE and method="dotdensity". You probably want to set binpositions="all"')

  layer(
    data = data,
    mapping = mapping,
    stat = StatBindot,
    geom = GeomDotplot,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    # Need to make sure that the binaxis goes to both the stat and the geom
    params = list(
      binaxis = binaxis,
      binwidth = binwidth,
      binpositions = binpositions,
      method = method,
      origin = origin,
      right = right,
      width = width,
      drop = drop,
      stackdir = stackdir,
      stackratio = stackratio,
      dotsize = dotsize,
      stackgroups = stackgroups,
      na.rm = na.rm,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
GeomDotplot <- ggproto("GeomDotplot", Geom,
  required_aes = c("x", "y"),
  non_missing_aes = c("size", "shape"),

  default_aes = aes(colour = "black", fill = "black", alpha = NA, stroke = 1, linetype = "solid"),

  setup_data = function(data, params) {
    data$width <- data$width %||%
      params$width %||% (resolution(data$x, FALSE) * 0.9)

    # Set up the stacking function and range
    if (is.null(params$stackdir) || params$stackdir == "up") {
      stackdots <- function(a)  a - .5
      stackaxismin <- 0
      stackaxismax <- 1
    } else if (params$stackdir == "down") {
      stackdots <- function(a) -a + .5
      stackaxismin <- -1
      stackaxismax <- 0
    } else if (params$stackdir == "center") {
      stackdots <- function(a)  a - 1 - max(a - 1) / 2
      stackaxismin <- -.5
      stackaxismax <- .5
    } else if (params$stackdir == "centerwhole") {
      stackdots <- function(a)  a - 1 - floor(max(a - 1) / 2)
      stackaxismin <- -.5
      stackaxismax <- .5
    }

    # Fill the bins: at a given x (or y), if count=3, make 3 entries at that x
    data <- data[rep(1:nrow(data), data$count), ]

    # Next part will set the position of each dot within each stack
    # If stackgroups=TRUE, split only on x (or y) and panel; if not stacking, also split by group
    plyvars <- params$binaxis %||% "x"
    plyvars <- c(plyvars, "PANEL")
    if (is.null(params$stackgroups) || !params$stackgroups)
      plyvars <- c(plyvars, "group")

    # Within each x, or x+group, set countidx=1,2,3, and set stackpos according to stack function
    data <- dapply(data, plyvars, function(xx) {
            xx$countidx <- 1:nrow(xx)
            xx$stackpos <- stackdots(xx$countidx)
            xx
          })

    # Set the bounding boxes for the dots
    if (is.null(params$binaxis) || params$binaxis == "x") {
      # ymin, ymax, xmin, and xmax define the bounding rectangle for each stack
      # Can't do bounding box per dot, because y position isn't real.
      # After position code is rewritten, each dot should have its own bounding box.
      data$xmin <- data$x - data$binwidth / 2
      data$xmax <- data$x + data$binwidth / 2
      data$ymin <- stackaxismin
      data$ymax <- stackaxismax
      data$y    <- 0

    } else if (params$binaxis == "y") {
      # ymin, ymax, xmin, and xmax define the bounding rectangle for each stack
      # Can't do bounding box per dot, because x position isn't real.
      # xmin and xmax aren't really the x bounds, because of the odd way the grob
      # works. They're just set to the standard x +- width/2 so that dot clusters
      # can be dodged like other geoms.
      # After position code is rewritten, each dot should have its own bounding box.
      data <- dapply(data, c("group", "PANEL"), transform,
            ymin = min(y) - binwidth[1] / 2,
            ymax = max(y) + binwidth[1] / 2)

      data$xmin <- data$x + data$width * stackaxismin
      data$xmax <- data$x + data$width * stackaxismax
      # Unlike with y above, don't change x because it will cause problems with dodging
    }
    data
  },

  draw_group = function(data, panel_params, coord, na.rm = FALSE,
                        binaxis = "x", stackdir = "up", stackratio = 1,
                        dotsize = 1, stackgroups = FALSE) {
    if (!coord$is_linear()) {
      warn("geom_dotplot does not work properly with non-linear coordinates.")
    }

    tdata <- coord$transform(data, panel_params)

    # Swap axes if using coord_flip
    if (inherits(coord, "CoordFlip"))
      binaxis <- ifelse(binaxis == "x", "y", "x")

    if (binaxis == "x") {
      stackaxis = "y"
      dotdianpc <- dotsize * tdata$binwidth[1] / (max(panel_params$x.range) - min(panel_params$x.range))

    } else if (binaxis == "y") {
      stackaxis = "x"
      dotdianpc <- dotsize * tdata$binwidth[1] / (max(panel_params$y.range) - min(panel_params$y.range))
    }

    ggname("geom_dotplot",
      dotstackGrob(stackaxis = stackaxis, x = tdata$x, y = tdata$y, dotdia = dotdianpc,
                  stackposition = tdata$stackpos, stackratio = stackratio,
                  default.units = "npc",
                  gp = gpar(col = alpha(tdata$colour, tdata$alpha),
                            fill = alpha(tdata$fill, tdata$alpha),
                            lwd = tdata$stroke, lty = tdata$linetype))
    )
  },

  draw_key = draw_key_dotplot
)


#Maintaining symmetry, I want to try a bigger intercept for the gamma
#function PLUS probabilistic one-sided breaking (same gamma as lobby4).

#gamma: 1.25 + cn^.2
#cn = .00166
#tn = (8*(1 + .00156^.1)-5)/(68-8*(1 + .00156^.1)) = 0.12592

tn = (8*(1.25 + .00166^.2)-5)/(68-8*(1.25 + .00166^.2))

a=.2
tns=tn
ta_vector = seq(0,.1259,.001)
#tad = NROW(ta)
c_vector=seq(0,.005,.00005)
#tac = NROW(c)
#[ta,c]=meshgrid(ta,c);

#add e to gamma
e1=.25
e2=.25

param <- expand.grid("ta" = ta_vector, "c" = c_vector)

l <- function(ta,c) {
  lhs <- (8*(1.25 + (c)^a)-5)*(tn-ta) + (4*(1.25 + (c)^a)-34)*(tn^2-ta^2)-3*(tns-ta)+9*(tns^2-ta^2)
  up <- (8*(1.25 + (c)^a +e1)-5)*(tn-ta) + (4*(1.25 + (c)^a +e1)-34)*(tn^2-ta^2)-3*(tns-ta)+9*(tns^2-ta^2)
  low <- (8*(1.25 + (c)^a -e2)-5)*(tn-ta) + (4*(1.25 + (c)^a -e2)-34)*(tn^2-ta^2)-3*(tns-ta)+9*(tns^2-ta^2)
  spread <- up - low
  b <- up/spread

    out <- list("tariff"=ta, "effort"=c, "value"=lhs, "spread"=spread, "b"=b)
}

for j=1:tad
    if lhs(1,j)< 0
        b(1,j) = 0;
        else
        b(1,j) = 1;
     end;
     for i=2:101
        if up(i,j) < 0
        b(i,j) = 0;
        elseif low(i,j) > 0
        b(i,j) = 1;
      end
    end
end

# Use "Map" to evaluate the "h" function at each pair of parameter values
res <- Map(l, ta = param$ta, c = param$c)
soln <- lapply(seq_along(res), function(x) res[[x]]$value)
soln <- do.call("rbind", soln)

#lobby's profits
l = b;
l2 = 4/49*((1+tn).^2);
l3 = l.*l2;
l4 = 4/49*((1+ta).^2);
l5 = l3 + (1-l).*l4 - c;
[M,I] = max(l5,[],1);
opt_C = (I -1)/20000;
%plot(TA,opt_C);

TA = [0:.001:.125];

for j=1:tad
  B(j) = b(I(j),j);
end

#exec utility with ga=1 and tn=tns
E=B;
E2 = 21/49*(2-2*tn^2);
E3 = E*E2;
E4 = 21/49.*(2-2*TA.^2);
E5 = (1-E).*E4;
E6 = E3 + (1-E).*E4 ;
%plot(TA,E6);

[M2,I2] = max(E6); #I2 gives E's choice of tau^a (63 ==> .062)
ta_star = (I2 - 1)/1000
c_star = I(I2) %c_star indicates what contributions the lobby chooses
e_welfare = E6(I2)
c_star_ = (c_star -1)/20000
b_star = b(c_star,I2) %break probability
gamma = 1.25 + (c_star_).^a

%e =[.00:.01:.25];
%t =[.113 .111 .109 .107 .105 .104 .104 .104 .105 .106 .107 .108 .109 .111 .096 .096 .091 .09 .086 .087 .083 .081 .08 .08 .078 .078];
%plot(e,t);


d <- function(distance, selection){
  eval(parse(text = paste("as.matrix(distance)[",
                          selection, "]")))
}

`d<-` <- function(distance, selection, value){
  eval(parse(text = paste("as.matrix(distance)[",
                          selection, "] <- value")))
  as.dist(distance)
}

f <- function (i, j, dist_obj) {
  if (!inherits(dist_obj, "dist")) stop("please provide a 'dist' object")
  n <- attr(dist_obj, "Size")
  valid <- (i >= 1) & (j >= 1) & (i > j) & (i <= n) & (j <= n)
  k <- (2 * n - j) * (j - 1) / 2 + (i - j)
  k[!valid] <- NA_real_
  k
}

SliceExtract_dist <- function (dist_obj, k) {
  if (length(k) > 1) stop("The function is not 'vectorized'!")
  n <- attr(dist_obj, "Size")
  if (k < 1 || k > n) stop("k out of bound!")
  ##
  i <- 1:(k - 1)
  j <- rep.int(k, k - 1)
  v1 <- dist_obj[f(j, i, dist_obj)]
  ##
  i <- (k + 1):n
  j <- rep.int(k, n - k)
  v2 <- dist_obj[f(i, j, dist_obj)]
  ##
  c(v1, 0, v2)
}

randomName <- function(n = 1) {
  a <- do.call(paste0, replicate(5, sample(LETTERS, n, TRUE), FALSE))
  paste0(a, sprintf("%04d", sample(9999, n, TRUE)), sample(LETTERS, n, TRUE))
}

# ----------------------------------------------------------------------------
# |
# | Utilitary function to create a path.
# |
# ----------------------------------------------------------------------------
createPath <- function (strPath = "") {

  if (!file.exists(strPath) && strPath != ""){
    dir.create(file.path(strPath), recursive = TRUE)
  }

  strPath
}

saveNewExecution <- function(executionStatus) {
  currentExecution <- read.csv(here("R/results", executionStatus$Tecnique, executionStatus$IdExecution, "/execution_status.csv"), header = TRUE, stringsAsFactors = FALSE, sep=";")

  allExecutions <- tryCatch(
    {
      allExecutions <- read.csv(here("R/results", "execution_status.csv"), header = TRUE, stringsAsFactors = FALSE, sep=";", fileEncoding="UTF-8-BOM")
      allExecutions <- rbind(allExecutions, currentExecution)
      allExecutions
    },
    error = function(err) {
      allExecutions <- data.frame()
      allExecutions <- rbind(allExecutions, currentExecution)
      allExecutions
    }
  )

  write_excel_csv2(allExecutions, here("R/results", "execution_status.csv", sep=""));
}


library(ggplot2)

ggplot(mpg, aes(displ, hwy, colour = class)) +
    geom_point()