library(lme4)
library(lmerTest)
library(tidyverse)
library(texreg)
library(gridExtra)
library(r2glmm)

load('data/cleanedDataWithLags.RData')

dat <- dat%>%
  group_by(StudyId)%>%
  mutate_at(vars(BirthYear,ends_with('_R'),Site,age),~if(any(!is.na(.))) na.omit(.)[1] else NA)%>%
  mutate(cd4_100=cd4/100,cd4_100_lag=cd4_lag/100,
    depDist=(Date-dep_total_lastObs)/1000,
    adDist=(Date-adhere_lastObs)/1000,
    cd4Dist=(Date-cd4_lastObs)/1000,
    qolDist=(Date-qol1_5_total_lastObs)/1000,
    Race_R=as.factor(Race_R),
    logDepLag=log(dep_total_lag+1)
  )%>%
  ungroup()%>%
  filter(is.na(cd4_lag)|cd4_lag<3000,is.na(cd4)|cd4<3000)%>%  ## these are extreme outliers
  droplevels()

## dat2 <- dat%>%mutate(logDepLag=logDepLag-mean(logDepLag,na.rm=TRUE),
##   adhere_lag=adhere_lag-mean(adhere_lag,na.rm=TRUE),
##   cd4_100_lag=cd4_100_lag-mean(cd4_100_lag,na.rm=TRUE))

## load('fittedModels/AdDepModels.RData')
## load('fittedModels/cd4AdDepModels.RData')
## load('fittedModels/qolAdDepCd4LinearModels.RData')

### refit models for report
## first standardize main study variables: logDepLag, adhere,cd4,qol

#dat <- dat[-c(which.max(datS$cd4),which.min(datS$cd4)),]

datS <- dat%>%
  mutate(logDepLag=logDepLag/sd(logDepLag,na.rm=TRUE))
for(vv in c('adhere','cd4','qol1_5_total')){
  SD <- sd(dat[[vv]],na.rm=TRUE)
  datS[[vv]] <- datS[[vv]]/SD
  datS[[paste0(vv,'_lag')]] <-   datS[[paste0(vv,'_lag')]]/SD
}

mods <- list(
  Adhere = lmer(adhere~logDepLag+depDist+adDist+adhere_lag+(adDist+depDist|StudyId),data=dat),
  CD4 = lmer(cd4~logDepLag+depDist+adhere_lag+adDist+cd4_lag+cd4Dist+(depDist+adDist+cd4Dist|StudyId),data=dat),
  QOL = lmer(qol1_5_total~logDepLag+depDist+adhere_lag+adDist+cd4_lag+cd4Dist+qol1_5_total_lag+qolDist+(cd4Dist+adDist|StudyId),data=dat)
    )

modsS <- map(mods,update,data=datS)

### adjust mods$cd4 for heteroskedasticity in adherence?
mf <- model.frame(modsS$CD4)
adVal <- sort(unique(mf$adhere_lag))
for(i in 2:5){
    val <- adVal[i]
    mf[[paste0('ad',i)]] <- ifelse(mf$adhere_lag==val,seq(nrow(mf)),0)
}

cd4Mod <- update(modsS$CD4,.~.+(1|ad2)+(1|ad3)+(1|ad4)+(1|ad5),data=mf)

save(cd4Mod,file='fittedModels/cd4hetero.RData')

save(mods,modsS,file='fittedModels/modsForPub.RData')

### table 1
pn <- function(x) formatC(x,digits=1,format='f')
cap <- function(x) paste0(toupper(substr(x,1,1)),substr(x,2,nchar(x)))
tab1dat <-
  dat%>%
  filter(StudyId%in%model.frame(mods$Adhere)$StudyId)%>%
  mutate(Race_R=as.character(Race_R))%>%
      group_by(StudyId)%>%
        summarize(Age=mean(age,na.rm=TRUE),
                  Gender=na.omit(PresentSex_R)[1],
                  Race=ifelse(all(is.na(Hispanic_R))|na.omit(Hispanic_R)[1]=='no',na.omit(Race_R)[1],'Latino'),
                  Adherence=mean(adhere,na.rm=TRUE),
                  CD4=mean(cd4,na.rm=TRUE),
                  Depression=mean(dep_total,na.rm=TRUE),
                  `Log(Depression)`=mean(log(dep_total+1),na.rm=TRUE),
                  QOL=mean(qol1_5_total,na.rm=TRUE),
                  A1C=mean(a1c,na.rm=TRUE)
                  )%>%
          select(-StudyId)

tab1 <- map_dfr(
  names(tab1dat),
  function(nn) {
    x <- tab1dat[[nn]]
    if(is.numeric(x))
      return(
        tibble(
          Variable=nn,
          Report='Mean (SD)',
          Value=paste0(pn(mean(x,na.rm=TRUE)),' (',pn(sd(x,na.rm=TRUE)),')')
          )
        )
    map_dfr(
      unique(na.omit(x)),
      ~tibble(
        Variable=ifelse(.==unique(na.omit(x))[1],nn,''),
        Report='N (%)',
        Value=paste0(cap(.),': ',prettyNum(sum(x==.,na.rm=TRUE),','),' (',
                            pn(mean(x==.,na.rm=TRUE)*100),'%)'))
      )
  }
  )

write.csv(tab1,'table1.csv',row.names=FALSE)

coefNames <- c(
    logDepLag="log(Dep.) (Lagged)",
    depDist="Dep. Meas. Gap",
    adDist="Adhere Meas. Gap",
    adhere_lag="Adherence (Lagged)",
    cd4_lag="CD4 (Lagged)",
    cd4Dist="CD4 Meas. Gap",
    qol1_5_total_lag="QOL (Lagged)",
    qolDist="QOL Meas. Gap"
    )

makeTrObj <- function(mod){
  tr <- extract(mod)
  tr@gof <- tr@gof[tr@gof.names%in%c("AIC","BIC","Log Likelihood","Num. obs.","Num. groups: StudyId")]
  tr@gof.decimal <- tr@gof.decimal[tr@gof.names%in%c("AIC","BIC","Log Likelihood","Num. obs.","Num. groups: StudyId")]
  tr@gof.names <- tr@gof.names[tr@gof.names%in%c("AIC","BIC","Log Likelihood","Num. obs.","Num. groups: StudyId")]
  tr@gof <- c(tr@gof,r2beta(mod,partial=FALSE)[1,'Rsq'])
  tr@gof.decimal <- c(tr@gof.decimal,TRUE)
  tr@gof.names <- c(tr@gof.names,'R2')

  tr@coef.names <- ifelse(tr@coef.names%in% names(coefNames),
                          coefNames[tr@coef.names],
                          tr@coef.names
                          )
  tr
}

modCoefs <- map(modsS,makeTrObj)

screenreg(modCoefs)

modTable <- htmlreg(modCoefs,file='coefTables/forPub.doc',doctype=TRUE,html.tag=TRUE,head.tag=TRUE,body.tag=TRUE,
                    reorder.coef=c(1,2,5,6,8,3,4,7,9))

### plots
predRange <- list()

pr <- function(mod,nd,iv){
    iv <- sym(iv)
     nd%>%arrange(!! iv)%>%select(names(fixef(mod))[-1])%>%slice(1,n())%>%as.matrix()%>%cbind(c(1,1),.)%*%fixef(mod)
}
### adherence vs depression
nd <- within(model.frame(mods$Adhere),{depDist=0;adhere_lag=mean(dat$adhere_lag,na.rm=TRUE);adDist=0})
ppp <- predict(mods$Adhere,nd)

datPoint <- model.frame(mods$Adhere)%>%
    mutate(adhere=ppp+resid(mods$Adhere),
           dep_total_lag=exp(logDepLag))

datAv <- datPoint%>%
    group_by(dep_total_lag)%>%summarize(n=n(),avg.adhere=mean(adhere,na.rm=TRUE))

predRange$ad <- pr(mods$Adhere,nd,"logDepLag")
## ggplot(datPoint,aes(dep_total_lag+1,adhere))+
##     geom_jitter(alpha=0.1)+
ggplot(datAv,aes(dep_total_lag+1,avg.adhere,size=n))+
    geom_point(show.legend=FALSE)+
            geom_smooth(method='lm',show.legend=FALSE,color='grey',se=FALSE,fullrange=TRUE)+
                scale_size(range=c(.5,5))+
                    ylim(1,5)+
                        scale_x_continuous(trans='log',breaks=c(1:8,10,15,20,28),minor_breaks=NULL)+
                            xlab('Depression+1 (lagged)')+ylab('Avg. Adherence (Adjusted)')
ggsave('plots/forPub/adhereVsDepressionAdj.png',width=3,height=3)

### cd4 vs adherence and depression
nd1 <- within(model.frame(mods$CD4),{logDepLag=mean(logDepLag,na.rm=TRUE);depDist=0;adDist=0;cd4_lag=mean(cd4_lag,na.rm=TRUE);cd4Dist=0})
ppp1 <- predict(mods$CD4,nd1)
predRange$cd4$ad <- pr(mods$CD4,nd1,"adhere_lag")
nd2 <- within(model.frame(mods$CD4),{adhere_lag=mean(dat$adhere_lag,na.rm=TRUE);depDist=0;adDist=0;cd4_lag=mean(cd4_lag,na.rm=TRUE);cd4Dist=0})
ppp2 <- predict(mods$CD4,nd2)
predRange$cd4$dep <- pr(mods$CD4,nd2,"logDepLag")

pdat <-
    model.frame(mods$CD4)%>%
  select(cd4,'vs. Adherence (lagged)'=adhere_lag,'vs. Depression (lagged)'=logDepLag)%>%
  gather("iv","value",-cd4)%>%
  mutate(
      width=.4*(log(exp(value)+1)-value),
      jitter=value+map_dbl(1:n(), ~if(iv[.]=='vs. Adherence (lagged)') runif(1,-.4,.4) else runif(1,-width[.],width[.])),
      bpVal=value,#as.factor(value),
      cd4=(ifelse(iv=='vs. Adherence (lagged)',ppp1+resid(mods$CD4),ppp2)+resid(mods$CD4)))#%>%

p <- ggplot(pdat,aes(jitter,cd4))+
  geom_point(alpha=0.2)+
  geom_smooth(aes(value,cd4),method='lm',color='grey',se=FALSE,fullrange=TRUE)+
  facet_wrap(~iv,scale="free_x")+
  labs(x=NULL,y='CD4 Count (Adjusted)')+
  scale_x_continuous(
      breaks=function(x) if(max(x)>4) 1:5 else log(c(1:8,10,15,20,28)),
      labels=function(x) if(max(x)>4) 1:5 else c(1:8,10,15,20,28)
      )+
ylim(0,max(c(ppp1,ppp2)+resid(mods$CD4)))

ggsave('plots/forPub/cd4VsadhereAndDepressionAdj.png',plot=p,width=6,height=3)

### QOL vs cd4, adherence and depression
preds <-     c('cd4_lag','adhere_lag','logDepLag')%>%setNames(.,.)
ndQOL <- map(preds,
             function(x)
                 model.frame(mods$QOL)%>%
                     mutate_at(vars(ends_with('lag'),-!! sym(x)),mean,na.rm=TRUE)%>%
                         mutate_at(vars(ends_with('Dist')),~0)
             )
predRange$qol <- map(preds,~pr(mods$QOL,ndQOL[[.]],.))
ppp <- map_dfc(preds,~predict(mods$QOL,newdata=nd$QOL[[.]]))

   ## pivot_longer(cols=everything(),names_to="iv",values_to="qol")%>%
   ## arrange(iv)

p <- model.frame(mods$QOL)%>%
    ## mutate(
    ##     cd4_lag=as.numeric(as.character(cut(cd4_lag,seq(0,3000,50),labels=seq(0,2950,50)+25))),
    ## )%>%
    select(qol=qol1_5_total,cd4_lag,adhere_lag,logDepLag)%>%
    gather("iv","value",-qol)%>%
    mutate(
      #width=.4*(log(exp(value)+1)-value),
      #jitter=value+map_dbl(1:n(), ~if(iv[.]=='adhere_lag') runif(1,-.4,.4) else if(iv[.]=='logDepLag') runif(1,-width[.],width[.]) else 0),
      bpVal=value,#as.factor(value),
      qol=ifelse(iv=='cd4_lag',ppp[['cd4_lag']]+resid(mods$QOL),
          ifelse(iv=='adhere_lag',ppp[['adhere_lag']]+resid(mods$QOL),
                 ppp[['logDepLag']]+resid(mods$QOL))
                 )-10
    )%>%
    group_by(iv,value)%>%
    summarize(n=n(),avg.qol=mean(qol,na.rm=TRUE))%>%
    ungroup()%>%
        mutate(iv=c(cd4_lag='vs. CD4 Count (lagged)',adhere_lag='vs. Adherence (lagged)',logDepLag='vs. Depression (lagged)')[iv])%>%
  ggplot(aes(value,avg.qol))+
  geom_point(aes(size=n),show.legend=FALSE)+
  geom_smooth(aes(value,avg.qol,weight=n),method=lm,color='grey',se=FALSE,fullrange=TRUE)+#,formula=y~poly(x,2))+
  #geom_segment(mapping=aes(x=xstart,y=ystart,xend=xend,yend=yend),color='grey',inherit.aes=FALSE)+
      facet_wrap(~iv,scales="free_x",ncol=2)+
  labs(x=NULL,y='Avg. QOL (adjusted)')+
        scale_x_continuous(
      breaks=function(x) if(max(x,na.rm=TRUE)>100)  seq(0,2500,500) else if(max(x,na.rm=TRUE)>4) 1:5 else log(c(1:8,10,15,20,28)),
      labels=function(x) if(max(x,na.rm=TRUE)>100)  seq(0,2500,500) else if(max(x,na.rm=TRUE)>4) 1:5 else c(1:8,10,15,20,28),
      minor_breaks=function(x) if(max(x,na.rm=TRUE)<5) log(1:28) else NULL)+
  scale_size(range=c(.5,5))+
  ylim(0,5)

ggsave('plots/forPub/qolVscd4adhereAndDepressionAdj.png',width=6,height=6)

save(predRange,file='fittedModels/predRanges.RData')

#####################
### mods w covariates, for appendix
####################
modsAdj <- map(modsS,~update(.,.~.+age+Site+PresentSex_R+Hispanic_R+Race_R))

modsAdjCoef <- map(modsAdj,makeTrObj)

screenreg(modsAdjCoef)

appendixTable <- htmlreg(modsAdjCoef,file='coefTables/appendix.doc',doctype=TRUE,html.tag=TRUE,head.tag=TRUE,body.tag=TRUE,
                         reorder.coef=c(1,2,5,18,21,3,4,19,22,6,20 ,7:17)
                         )


## clear
rm(list = ls());

## functions
eval.GENERAL    <- function(TP, FP, FN) {

  P <- ifelse(TP+FP>0, TP/(TP+FP), 0)
  R <- ifelse(TP+FN>0, TP/(TP+FN), 0)

  eval_score <- ifelse(P+R>0, (2*P*R)/(P+R), 0)

  return(eval_score)
}

eval.I  <- function(TPj, FPj, FNj, TPe, FPe, FNe) {

  Pj <- ifelse(TPj+FPj>0, TPj/(TPj+FPj), 0)
  Rj <- ifelse(TPj+FNj>0, TPj/(TPj+FNj), 0)

  Pe <- ifelse(TPe+FPe>0, TPe/(TPe+FPe), 0)
  Re <- ifelse(TPe+FNe>0, TPe/(TPe+FNe), 0)

  Fj <- ifelse(Pj+Rj>0, (2*Pj*Rj)/(Pj+Rj), 0)
  Fe <- ifelse(Pe+Re>0, (2*Pe*Re)/(Pe+Re), 0)

  eval_1_score <- ifelse(Fj+Fe>0, (2*Fj*Fe)/(Fj+Fe), 0)

  return(eval_1_score)
}

eval.II  <- function(TPj, FPj, FNj, TPe, FPe, FNe) {

  TP <- TPj + TPe
  FP <- FPj + FPe
  FN <- FNj + FNe

  P <- ifelse(TP+FP>0, TP/(TP+FP), 0)
  R <- ifelse(TP+FN>0, TP/(TP+FN), 0)

  eval_2_score <- ifelse(P+R>0, (2*P*R)/(P+R), 0)

  return(eval_2_score)
}

count.lines.csv <- function(file_path) {
  return(length(readLines(file_path)))
}

param.values <- function(file_path) {
  dir_names <- unlist(strsplit(file_path, "/"))
  # assume .csv was in the folder whose name carries the parameters (1 means one directory above)
  detection_dir_name <- dir_names[length(dir_names)-1]
  detection_dir_name_parts <- unlist(strsplit(detection_dir_name, "_"))
  legend <- detection_dir_name_parts[1]
  legend_names <- unlist(strsplit(legend, "[.]"))
  tag <- legend_names[2:length(legend_names)]
  vals <- (detection_dir_name_parts[2:length(detection_dir_name_parts)])
  out <- data.frame()
  out <- rbind(out, vals)
  names(out) <- tag
  return(out)
}

this.dir <- dirname(parent.frame(2)$ofile) # get current dir
out_dir <- file.path(this.dir, "summary") # output directory for the script
dir.create(out_dir, showWarnings = FALSE)

cat("reading folders... ")

t1 <- proc.time()[1]

list = list.dirs(this.dir);  # will recursively list all the directories (with the detections inside)
if (length(list)<=0) stop("no folders with detections found");

pamameter_records       <- list.files(list, pattern="eval.csv", full.names=T)

##
parameter_group_size    <- as.numeric(lapply(pamameter_records, count.lines.csv)) - 1 # first line is the legend, don't count it

##
params1 <- do.call("rbind", lapply(pamameter_records, param.values)) # extract parameters
param<-params1[rep(seq_len(nrow(params1)), parameter_group_size), ] # replicate with respect to the amount of lines in csv
remove(params1)

##
det<-do.call("rbind", lapply(pamameter_records, read.csv, header = TRUE, strip.white=TRUE))

# crop those that you don't need
drops <- c();#c("P_BIF","R_BIF","TP_BIF","FP_BIF","FN_BIF","P_CRS","R_CRS","TP_CRS","FP_CRS","FN_CRS")
det <- det[,!(names(det) %in% drops)]

t2 <- proc.time()[1] - t1
cat("DONE! elapsed ", t2, " seconds.\n")

# evaluation (det contains evaluation already)
# cat("evaluation... \n")
# eI <- eval.I(det$TP_JUN, det$FP_JUN, det$FN_JUN, det$TP_END, det$FP_END, det$FN_END)
# eII <- eval.II(det$TP_JUN, det$FP_JUN, det$FN_JUN, det$TP_END, det$FP_END, det$FN_END)
# eJUN <- eval.GENERAL(det$TP_JUN, det$FP_JUN, det$FN_JUN)
# eEND <- eval.GENERAL(det$TP_END, det$FP_END, det$FN_END)
# eval<-data.frame(eI=eI, eII=eII, eJUN=eJUN, eEND=eEND)

# save
cat("saving... \n")
save(det, file=file.path(out_dir, "det.RData"))
# save(eval, file=file.path(out_dir, "eval.RData"))
save(param, file=file.path(out_dir, "param.RData"))

cat("FINISHED")


library(zoo)
library(sandwich)
library(MASS)
library(quadprog)
library(tseries)
library(strucchange)
library(fracdiff)
library(forecast)
library(iterators)
library(codetools)
library(foreach)
library(bfast)
library(mailR)
library(parallel)

args <- commandArgs(trailingOnly = TRUE)

tile <- args[2]
filename <- paste0(args[1], args[2])
num_cores <- strtoi(args[3])
cluster <- makeCluster(num_cores)
clusterExport(cluster, "bfast")
clusterExport(cluster, "%dopar%")

datafile <- paste0(filename, "_ndvi_fill.csv")
inidata<-read.table(datafile, header=FALSE, sep = ",", dec = ".") #use only with small files; modify if no labels are in the input
mdata<-as.matrix(inidata)
tpdata<-mdata
vmax<-dim(mdata)
vmax[1]
vmax[2]
clusterExport(cluster, varlist=c("tile","tpdata","vmax"))
parLapply(cluster, 1:vmax[1], function(count){
	poly_id<-tpdata[count,1]  #highlighted number identifies field that will used to ID pixel
	ndvi<-tpdata[count,2:vmax[2]]  #highlighted number identifies first column with NDVI data
	plot(ndvi)
	tsdata<-ts(ndvi,frequency=23,start=c(2001,1))
	dim(tsdata)<-NULL
	rdist<-23/length(tsdata)
	fits<-bfast(tsdata,h=rdist,season="harmonic",max.iter=1, hpc = "foreach")
	plot(fits)
	fits2<-fits$Time
	ts_trend_break_time<-t(fits2[1])
	fits3<-fits$Magnitude
	ts_trend_break_magnitude<-t(fits3[1])
	fits4<-fits$output
	fits4a<-fits4[[1]]$Vt.bp
	fits4adata<-as.matrix(fits4a)
	fits4amax<-dim(fits4adata)
	ts_trend_nbbreak<-t(fits4amax[1])
	results1<-ts_trend_break_time
	aLine<-t(c(poly_id,results1))
	write.table(aLine, file=paste0("Results/", tile, "_trend_breaks_time.txt"), append=TRUE,quote=FALSE,sep=",", eol="\n",na="NA", dec=".",row.names=FALSE,col.names=FALSE,qmethod=c("escape","double"))
	results2<-ts_trend_break_magnitude
	aLine<-t(c(poly_id,results2))
	write.table(aLine,file=paste0("Results/", tile, "_trend_breaks_magnitude.txt"), append=TRUE,quote=FALSE, sep=",",eol="\n", na="NA", dec=".",row.names=FALSE,col.names=FALSE,qmethod=c("escape","double"))
	results3<-ts_trend_nbbreak
	aLine<-t(c(poly_id,results3))
	write.table(aLine,file=paste0("Results/", tile, "_trend_nbbreaks.txt"),append=TRUE,quote=FALSE,sep=",", eol="\n",na="NA", de=".", ,row.names=FALSE,col.names=FALSE,qmethod=c("escape","double"))
	fits4b<-fits4[[1]]$Tt
	results4<-fits4b
	aLine<-t(c(poly_id,results4))
	write.table(aLine,file=paste0("Results/", tile, "_trend_bfast.txt"),append=TRUE,quote=FALSE, sep=",",eol="\n",na="NA",dec=".", row.names=FALSE,col.names=FALSE,qmethod=c("escape","double"))
	fits4c<-fits4[[1]]$Wt.bp
	fits4cdata<-as.matrix(fits4c)
	fits4cmax<-dim(fits4cdata)
	ts_season_nbbreak<-t(fits4cmax[1])
	results5<-ts_season_nbbreak
	aLine<-t(c(poly_id,results5))
	write.table(aLine,file=paste0("Results/", tile, "_season_nbbreaks.txt"),append=TRUE,quote=FALSE, sep=",",eol="\n", na="NA", de=".", row.names=FALSE,col.names=FALSE,qmethod=c("escape","double"))
	ts_season_breaks_time<-t(fits4cdata)
	results6<- ts_season_breaks_time
	aLine<- t(c(poly_id,results6))
	write.table(aLine,file=paste0("Results/", tile, "_season_breaks_time.txt"),append=TRUE,quote=FALSE,sep=",", eol="\n",na="NA", de=".",row.names=FALSE,col.names=FALSE,qmethod=c("escape","double"))
	fits4d<-fits4[[1]]$St
	results7<-fits4d
	aLine<-t(c(poly_id,results7))
	write.table(aLine,file=paste0("Results/", tile, "_season_bfast.txt"),append=TRUE,quote=FALSE,sep=",",eol="\n",na="NA",dec=".",row.names=FALSE,col.names=FALSE,qmethod=c("escape","double"))
	rm(list=ls())
})


#!/data/binaries/R-3.1.0/bin/Rscript
#
# This file is part of peakAnalysis,
# http://github.com/alexjgriffith/alpha-score/,
# and is Copyright (C) University of Ottawa, 2015. It is Licensed under
# the three-clause BSD License; see LICENSE.txt.
# Author : Alexander Griffith
# Contact: griffitaj@gmail.com
#
#
######################################################################
######################################################################

loadProject<-function(projectDirectory,files,relative=TRUE){
    tempDir<-getwd()
    args <- commandArgs(trailingOnly = F)
    scriptDir<-dirname(sub("--file=","",args[grep("--file",args)]))
    setwd(scriptDir)
    for(file in files){
        source(paste(projectDirectory,file,sep=""),chdir=TRUE)}
    setwd(tempDir)}

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

library('getopt')
loadProject("../src/r/","pcaAnalysis.r")
spec = matrix(c(
    'fileLocation','i', 1,"character",
    'catagories','c', 1,"character",
    'cols','b', 1,"character",
    'print','p',0,"logic"
    ),byrow=TRUE,ncol=4)
args=getopt(spec)
if(is.null(args$print)){prints=FALSE}else{prints=TRUE}
rootFile<-args$fileLocation
catFile<-args$catagories
column<-as.numeric(strsplit(args$cols,",")[[1]])

values<-loadData(rootFile)
cats<-t(read.table(catFile))
data<-values$data
normData<-standPCAPrep(data,"colQn")
pcs<-prcomp(t(normData))
if(prints==TRUE){
    X11()
    print(args$print)
    plotPCs(pcs,column,normData,cats)
    locator(1)}
if(prints==FALSE){
    print("FALSE")
    write.table(pcs$rotation[,column],stdout(),col.names=FALSE,row.names=FALSE,quote=FALSE,sep="\t")}


### Thompson functions

# function for calculating mid-range values -------------------------
pxt.recording=function(pci,pxt){pci+(1-pci)*pxt}
pxt.survey=function(eps, pi, pr, pxt){(1-eps*pi*pr)*pxt}

px.mid = function()
{

  PXt = NULL
  PXt.min = NULL
  PXt.max = NULL
  sd=NULL
  PX0 = 1 # species is extant at year 0 P(X0)=1

  # first year t=1
  rec = recordings[recordings[,1]==years[1],]
  pci.mid = (rec[,2] + rec[,3]) / 2
  pci.min=rec[,2]
  pci.max=rec[,3]

  PXt[1]=pxt.recording(pci.mid, PX0)
  PXt.min[1]=pxt.recording(pci.min, PX0)
  PXt.max[1]=pxt.recording(pci.max, PX0)

  n=10000 #number of samples
  pxt.sam=rep(PX0,n)
  stdev=(rec[,3] - rec[,2])/4
  pci.sam = rnorm(n,pci.mid,stdev )
  pxt.sam = pxt.recording(pci.sam, pxt.sam)

  sd[1]=sd(pxt.sam)

  # t = 8

  for (t in 2:length(years)) {

    #calculating rj
    if (rec.year[t,2]) #if recording
    {

      rec = recordings[recordings[,1]==years[t],]

      #get mid point estimate
      pci.mid = (rec[,2] + rec[,3]) / 2

      pci.min=rec[,2]
      pci.max=rec[,3]

      PXt[t]=pxt.recording(pci.mid, PXt[t-1])

      PXt.min[t]=pxt.recording(pci.min, PXt.min[t-1])
      PXt.max[t]=pxt.recording(pci.max, PXt.max[t-1])

      #sample to get min and max bounds
      stdev=(rec[,3] - rec[,2])/4
      pci.sam = rnorm(n,pci.mid,stdev )
      pxt.sam = pxt.recording(pci.sam, pxt.sam)
      sd[t]=sd(pxt.sam)

    }  else #if survey
    {
      sur=surveys[surveys[,1]==years[t],]
      eps.mid = (sur[,2] + sur[,3]) / 2
      pi.mid = (sur[,4] + sur[,5]) / 2
      pr.mid = (sur[,6] + sur[,7]) / 2

      eps.min = sur[,2]
      pi.min = sur[,4]
      pr.min = sur[,6]

      eps.max = sur[,3]
      pi.max = sur[,5]
      pr.max = sur[,7]

      PXt[t]=pxt.survey(eps.mid, pi.mid, pr.mid, PXt[t-1])
      PXt.min[t] = pxt.survey(eps.max, pi.max, pr.max, PXt.min[t - 1])
      PXt.max[t] = pxt.survey(eps.min, pi.min, pr.min, PXt.max[t - 1])

      eps.sam = rnorm(n,eps.mid,(sur[,3] - sur[,2]) / 4)
      pi.sam = rnorm(n,pi.mid,(sur[,5] - sur[,4]) / 4)
      pr.sam = rnorm(n,pi.mid,(sur[,7] - sur[,6]) / 4)
      pxt.sam = pxt.survey(eps.sam, pi.sam, pr.sam, pxt.sam)
      sd[t]=sd(pxt.sam)
    }

  }
  # print(cbind(PXt-3*sd,PXt,PXt+3*sd))
  return (cbind(PXt-3*sd,PXt,PXt+3*sd, PXt.min, PXt.max))

}


# File: qpf.r
# Description:
#    Functions to perfrom QPE from radar data
# Load input/output data
load("input.1316.ae.RData")
load("../workspace/output.1316.RData")
rseed = 1234543
# Load library
require(caret)
require(kernlab)
require(parallel)
# Set up multi-core
library(doParallel)
cluster <- makeCluster(detectCores() - 2) # convention to leave 1 core for OS
registerDoParallel(cluster)
# Collect results
results.glm <- data.frame(NULL)
results.svm <- data.frame(NULL)
ys <- NULL
mod.glm <- NULL
mod.svm <- NULL
# Run through each station
nstation <- length(y.1316)
for(i in 1:nstation){
  #
  print(paste("Creating IO data for",names(y.1316)[i]))
  # Combine IO
  tmp <- data.frame('date'=c(y.1316[[i]]$date[2:nrow(y.1316[[i]])],NA),'y'=c(y.1316[[i]]$t1hr[2:nrow(y.1316[[i]])],NA))
  tmp <- tmp[
  iodata <- merge(tmp, input.1316, by.x="date", by.y=0)
  # Clean up NA and move date to row.names
  print("Cleaning up data...")
  row.names(iodata) <- iodata$date
  iodata <- iodata[,-1]
  iodata <- iodata[complete.cases(iodata),]
  #iodata <- iodata[1:1000,]
  print(paste("    Number of valid records:", nrow(iodata)))
  # Setup train-control
  print("Creating folds for cross validation...")
  set.seed(rseed)
  cvOut <- createFolds(iodata$y, k=10)
  cvIn <- cvOut
  for(i in 1:10){
    cvIn[[i]] <- (1:length(iodata$y))[-cvOut[[i]]]
  }
  trctrl <- trainControl("cv", index=cvIn, indexOut=cvOut, allowParallel=T, savePred=F)
  # Fit model
  print("Training and cross validating...")
  # GLM
  fit.glm <- train(log(y+1)~., data=iodata, method="glm", preProcess="scale", trControl=trctrl)
  rec <- fit.glm$results
  yhat.glm <- fit.glm$finalModel$fitted.values
  rec$RMSE.insample <- RMSE(exp(yhat.glm)-1, iodata$y)
  rec$CORR.log <- cor(yhat.glm, log(iodata$y+1))
  rec$CORR.mm <- cor(exp(yhat.glm)-1, iodata$y)
  print("GLM")
  print(rec)
  results.glm <- rbind(results.glm, rec)
  #coef.glm <- c(coef.glm, list(coef(summary(fit.glm))))
  # SVM
  fit.svmr <- train(log(y+1)~., data=iodata, method="svmRadial", preProcess="scale", trControl=trctrl)
  rec <- fit.svmr$results[1,]
  yhat.svm <- fit.svmr$finalModel@fitted
  rec$RMSE.insample <- RMSE(exp(yhat.svm)-1, iodata$y)
  rec$CORR.log <- cor(yhat.svm, log(iodata$y+1))
  rec$CORR.mm <- cor(exp(yhat.svm)-1, iodata$y)
  print("SVR")
  print(rec)
  results.svm <- rbind(results.svm, rec)
  # Collection predictions
  #y <- data.frame(NULL)
  y <- data.frame(iodata$y)
  y$y.glm <- yhat.glm
  y$y.svm <- yhat.svm
  ys <- c(ys, list(y))
  # Save model
  mod.glm <- c(mod.glm, list(fit.glm$finalModel))
  mod.svm <- c(mod.svm, list(fit.svmr$finalModel))
}
#names(coef.glm) <- names(y.1316)
names(ys) <- names(y.1316)
names(mod.glm) <- names(y.1316)
names(mod.svm) <- names(y.1316)
# Clean up
rm(i, iodata, cvOut, cvIn, trctrl, fit.glm, fit.svmr)
# Stop parallel
stopCluster(cluster)
registerDoSEQ()
# Save
save(results.glm, results.svm, ys, file="qpf1hr1316.ae.RData")
#save(mod.glm, file="qpf1hr1316.mod.glm.RData")
#save(mod.svm, file="qpf1hr1316.mod.svm.RData")


library(data.table)
setwd("~/Dropbox/liverpool/retail_typology/data/jsa")

# jsa <- fread("jsa_feb17_feb16.csv")
jsa <- fread("jsa_15_17.csv")
# there are NAs where number of applicants where <2 and were suppressed, replace with 1
jsa[, (2:21) := lapply(.SD, function(x) ifelse(is.na(x), 1, x)), .SDcols = 2:21]
# calculate mean unemployed for the period 2015 to 2017 per lsoa
mean_jsa <- jsa[, .(mean_jsa = rowMeans(.SD)), by = "V1"]
setnames(mean_jsa, "V1", "lsoa11")

pop_probs_sc <- fread("~/Dropbox/liverpool/retail_typology/data/pop_est/pop_dz15_probs.csv")
pop_probs_sc <- pop_probs_sc[total_pop != 0, ]
pop_probs_ew <- fread("~/Dropbox/liverpool/retail_typology/data/pop_est/pop_lsoa15_probs.csv")

pop_probs <- rbindlist(list(pop_probs_sc, pop_probs_ew))

# sanity check
all(pop_probs$lsoa11 %in% mean_jsa$lsoa11) # T
pop_probs[mean_jsa, mean_jsa := i.mean_jsa, on = "lsoa11"]
# pop_probs[, weight := weighted_pop / total_pop]
mean_weighted_jsa <- pop_probs[, .(mean_jsa = weighted.mean(mean_jsa, mean_huff_prob)), by = "cluster_id"]
fwrite(mean_weighted_jsa, "~/Dropbox/liverpool/retail_typology/analysis/indicators/mean_weighted_jsa.csv")


crosses<- function(g, pii.beta = -0.7, tolerance = 0.000001){
  n1 <- c()
  n2 <- c()
  table <- c()

  # get the distance vectors
  e.dist <- edge.distance(g)
  e.dist <- matrix(as.integer(e.dist), nrow=nrow(e.dist)) # convert to an integer matrix
  max.distance <- max(e.dist)
  edgevalence <- E(g)$valence
  vec <- valenceEdgeCounts(e.dist, edgevalence, max.distance)

  max.degree <- max(degree(g, mode='total'))
  for(i in 1:(vcount(g)-1)){
    for(j in (i+1):vcount(g)){
      if(i != j){
        beta.vec1 <- overlaps(vec, pii.beta, max.degree, i, j)

        if(length(beta.vec1) > 0) {
          cat('i: ', i, 'j: ', j, '\n')
        }
        o <- numeric(length(beta.vec1))
        ## Because pii.x has beta in it, we use an initial value of beta to start and get an estimate
        ## of the beta overlap. Then we use the values of the estimated beta overlaps to calculate
        ## the positions again.
        if(length(beta.vec1) > 0) {
           # output vector
          for(k in 1:length(beta.vec1)) {
            prev.beta <- pii.beta
            curr.beta <- mean(c(prev.beta, beta.vec1[k])) # find a mid-point between
            while(abs(curr.beta - prev.beta) > tolerance) {
              prev.beta <- curr.beta
              (beta.vec <- overlaps(vec, curr.beta, max.degree, i, j))
              if(length(beta.vec) > 1) {
                curr.beta <- mean(c(prev.beta, beta.vec[k]))
              }
              if(is.na(curr.beta)){
                break
              }
            }
            o[k] <- curr.beta
          }
        }

#         xx <- polyroot((vec$pos[,i] - vec$neg[,i]) - (vec$pos[,j] - vec$neg[,j]))
         length.table <- length(table)
#         table <- c(table, Re(xx[round(Im(xx), digits = 12) == 0]))
#         table <- table[table < -0.5 & table > -0.9]
         table <- c(table, o)
        #while(curr.beta-prev.beta > tolerance){
          #prev.beta <- curr.beta
          #curr.beta <- polyroot((vec$pos[,i] - vec$neg[,i]) - (vec$pos[,j] - vec$neg[,j]))
        #}
         length.curr.table <- length(table)
         if(length.table != length.curr.table){
           n1 <- c(n1, rep(i, (length.curr.table - length.table)))
           n2 <- c(n2, rep(j, (length.curr.table - length.table)))
         }
      }
    }
  }
  na.omit(data_frame("n1" = n1, "n2" = n2, "beta" = table,
             "graphid" = ifelse(is.null(get.graph.attribute(g, "graphid")), "", get.graph.attribute(g, "graphid"))))
}

overlaps <- function(vec, beta, max.degree, i, j){
  pii.x <- (log(2) - log(abs(beta))) / log(max.degree)
  xx <- polyroot((vec$pos[,i] ^ pii.x - vec$neg[,i] ^ pii.x) - (vec$pos[,j]^pii.x - vec$neg[,j]^pii.x))
  Re(xx[which(Re(xx) < 0)[1]])
  #tt <- Re(xx[round(Im(xx), digits = 12) == 0])
  #tt[tt <= -0.5 & tt >= -0.9]
  #Re(xx)[1]
}


library(ggplot2)
library(tidyr)
library(dplyr)
library(cowplot)
library(readr)
library(ggbeeswarm)
theme_set(theme_bw())
options(stringsAsFactors=F)

library(argparser)
p <- arg_parser("ddOWL mutatation allele phasing and plotting tools, v0.1 - Nils Koelling")
p <- add_argument(p, "FAMILIES", help="families file")
p <- add_argument(p, "SNPS", help="snps mask")
p <- add_argument(p, "--prefix", help="filename prefix")

phred2p = function(x) 10^(-x/10)
p2phred = function(x) -log10(x)*10

xx = c(0.0005, 0.003, 0.9, 1)
stopifnot(all.equal(phred2p(p2phred(xx)), xx))

alleles = c('paternal', 'maternal')

phred2pcorrect = function(x) 1-phred2p(x)

joint_snp_prop = function(snp_call_qualities, snp_call_types, expected_call) {
    other_call = alleles[alleles != expected_call]

    prod(c(
        phred2pcorrect(snp_call_qualities[snp_call_types == expected_call]),
        1-phred2pcorrect(snp_call_qualities[snp_call_types == other_call])
    ))
}

calc_read_p = function(expected_mutation_allele, mutation_call_type, mutation_call_quality, snp_call_qualities, snp_call_types) {
    expected_wt_allele = alleles[alleles != expected_mutation_allele]

    r = (
        #assuming the mutation call is correct
        (1-phred2p(mutation_call_quality)) *
        ifelse(
            mutation_call_type == 'wild-type',
            joint_snp_prop(snp_call_qualities, snp_call_types, expected_wt_allele),
            joint_snp_prop(snp_call_qualities, snp_call_types, expected_mutation_allele)
        )
        +
        #... or assuming the mutation call is wrong
        (phred2p(mutation_call_quality)) *
        ifelse(
            mutation_call_type == 'wild-type',
            joint_snp_prop(snp_call_qualities, snp_call_types, expected_mutation_allele),
            joint_snp_prop(snp_call_qualities, snp_call_types, expected_wt_allele)
        )
    )

#     if(length(r) > 1) {
#         str(list(expected_mutation_allele, mutation_call_type, mutation_call_quality, snp_call_qualities, snp_call_types, r))
#         stop()
#     }

    r
}

calc_read_likelihoods = function(reads) {
    reads %>%
            filter(!is.na(mutation_call_type) & mutation_call_type %in% c('wild-type', 'mutation')) %>%
            filter(!is.na(snp_call_type) & snp_call_type %in% c('paternal', 'maternal')) %>%
            group_by(FamilyID, sample, read, mutation_call_type, mutation_call_quality) %>%
            summarise(
                n_snps = n(),
                n_paternal = sum(snp_call_type == 'paternal'),
                n_maternal = sum(snp_call_type == 'maternal'),
                p_if_mut_mat = calc_read_p('maternal', mutation_call_type[1], mutation_call_quality[1], snp_call_quality, snp_call_type),
                p_if_mut_pat = calc_read_p('paternal', mutation_call_type[1], mutation_call_quality[1], snp_call_quality, snp_call_type),
                bf = p_if_mut_mat / p_if_mut_pat,
                logbf = log(p_if_mut_mat) - log(p_if_mut_pat),
                type = ifelse(p_if_mut_mat > 0.5, 'mat', ifelse(p_if_mut_pat > 0.5, 'pat', 'other'))
            )
}

main = function(argv) {
    if(missing(argv)) {
        argv = commandArgs(trailingOnly = TRUE)
    }

    args <- parse_args(p, argv)

    if(is.na(args$prefix)) {
        args$prefix = args$FAMILIES
    }

    families = read_csv(args$FAMILIES) %>%
        rename(sample = BC) %>%
        mutate(rel_sam = sprintf('%s (%s)', relationship, sample))

    snps = families %>%
        distinct(FamilyID) %>%
        rowwise %>%
        do({
            fam = .$FamilyID

            read_tsv(sprintf(args$SNPS, fam), col_types = cols(
                POS = col_integer(),
                ID = col_character(),
                REF = col_character(),
                ALT = col_character()
            )) %>%
            rename(CHROM = `#CHROM`) %>%
            mutate(
                snp_name = sprintf('%s_%d', CHROM, POS),
                snp_name_or_id = ifelse(!is.na(ID), ID, name),
                FamilyID = fam
            )
        }) %>%
        distinct(FamilyID, snp_name, .keep_all=TRUE)

    is = read_csv(sprintf('%s.informative_snps.csv', args$prefix)) %>%
        mutate(multi = grepl(',', paternal) | grepl(',', maternal))
    rmc = read_csv(sprintf('%s.read_mutation_calls.csv', args$prefix)) %>%
        inner_join(families, by=c('FamilyID', 'sample'))
    rsc = read_csv(sprintf('%s.read_snp_calls.csv', args$prefix)) %>%
        inner_join(families, by=c('FamilyID', 'sample'))
    rc = rsc
    #shuffle:
    #rmc = rmc %>% group_by(sample) %>% mutate(read = sample(read)) %>% ungroup

    fn = sprintf('%s.phasing.pdf', args$prefix)
    pdf(fn)
    for(family in unique(rmc$FamilyID)) {
        cat(family, ':\n')
        my_is = is %>% filter(FamilyID == family)
        my_rmc = rmc %>% filter(FamilyID == family)
        my_rsc = rsc %>% filter(FamilyID == family)
        my_rc = rc %>% filter(FamilyID == family)

        proband_rsc = rsc %>% filter(relationship == 'proband')
        proband_rc = proband_rsc %>%
            filter(snp_name %in% my_is$name[!my_is$multi]) %>% #FIXME: remove this
            select(FamilyID, sample, read, snp_name, snp_call_type, snp_call_quality) %>%
            left_join(rmc %>% select(FamilyID, sample, read, mutation_call_type, mutation_call_quality), by = c('FamilyID', 'sample', 'read'))
        print(table(proband_rc$mutation_call_type, proband_rc$snp_call_type))

        by_read = proband_rc %>%
            filter(!is.na(mutation_call_type)) %>%
            filter(!is.na(snp_call_type)) %>%
            group_by(FamilyID, sample, read, mutation_call_type, mutation_call_quality) %>% summarise(
                snps = list(snp_name),
                snp_calls = list(snp_call_type),
                snp_qualities = list(snp_call_quality),
                inconsistent = length(unique(snp_call_type)) != 1,
                n_snps = n(),
                n_paternal = sum(snp_call_type == 'paternal'),
                n_maternal = sum(snp_call_type == 'maternal'),
                q_paternal = sum(snp_call_quality[snp_call_type == 'paternal']),
                q_maternal = sum(snp_call_quality[snp_call_type == 'maternal']),
            )

        cat('Calculating foreground...\n')
        read_likelihood = calc_read_likelihoods(proband_rc)
        print(read_likelihood %>% head)

        cat('Reads with p(X) > 0.5:')
        print(table(read_likelihood$type))

        median_logbf = median(read_likelihood$logbf)
        cat('Median logBF for maternal > paternal: ', median_logbf, '\n')
        total_logbf = sum(read_likelihood$logbf)
        cat('Overall logBF for maternal > paternal: ', total_logbf, '\n')

        cat('Wilcoxon test of p(Mat) over p(Pat):\n')
        print(wilcox.test(read_likelihood$p_if_mut_mat, read_likelihood$p_if_mut_pat, paired = T))
        binom = binom.test(x = sum(read_likelihood$p_if_mut_mat > read_likelihood$p_if_mut_pat), n = nrow(read_likelihood))
        cat('Sign test of p(Mat) over p(Pat):\n')
        print(binom.test(x = sum(read_likelihood$p_if_mut_mat > read_likelihood$p_if_mut_pat), n = nrow(read_likelihood)))

        cat('Calculating background...\n')
        read_likelihood_bg = sapply(1:100, function(i) {
            cat(i, ' ')
            #note the  %>% mutate(read = sample(read)
            background_rc = proband_rsc %>%
                filter(snp_name %in% my_is$name[!my_is$multi]) %>% #FIXME: remove this
                select(FamilyID, sample, read, snp_name, snp_call_type, snp_call_quality) %>%
                left_join(rmc %>% select(FamilyID, sample, read, mutation_call_type, mutation_call_quality) %>% mutate(read = sample(read)), by = c('FamilyID', 'sample', 'read'))

            background_likelihood = calc_read_likelihoods(background_rc)

            c(
                bg_median_logbf = median(background_likelihood$logbf),
                bg_total_logbf = sum(background_likelihood$logbf),
                bg_p_wilcox = wilcox.test(background_likelihood$p_if_mut_mat, background_likelihood$p_if_mut_pat, paired = T)$p.value,
                bg_p_binom = binom.test(x = sum(background_likelihood$p_if_mut_mat > background_likelihood$p_if_mut_pat), n = nrow(background_likelihood))$p.value
            )
        }) %>%
        t %>%
        data.frame

        cat('.\n')

        cat('Emperical p: Median logBF for maternal > paternal: ', sum(abs(median_logbf) > abs(read_likelihood_bg$bg_median_logbf)) / (nrow(read_likelihood_bg)+1), '\n')
        cat('Emperical p: Overall logBF for maternal > paternal: ', sum(abs(total_logbf) > abs(read_likelihood_bg$bg_total_logbf)) / (nrow(read_likelihood_bg)+1), '\n')
        cat('Emperical p: Sign test of p(Mat) over p(Pat): ', sum(binom$p.value > read_likelihood_bg$bg_p_binom) / (nrow(read_likelihood_bg)+1), '\n')

        print(
            ggplot(my_rmc, aes(factor(1), fill=rel_sam)) + geom_bar(position = 'dodge') + coord_flip()
            + ggtitle(family, 'mutation site reads')
        )

        print(
            ggplot(my_rmc, aes(ifelse(is.na(mutation_call_type), 'NA', mutation_call_type), fill=rel_sam)) + geom_bar(position = 'dodge') + coord_flip()
            + xlab('mutation site call')
            + ggtitle(family, 'mutation site calls')
        )

        print(
            ggplot(my_rmc, aes(rel_sam, mutation_call_quality, fill=ifelse(is.na(mutation_call_type), 'NA', mutation_call_type))) + geom_violin(position = 'dodge') + scale_fill_discrete(name='')
            + ggtitle(family, 'mutation site call quality')
        )

        print(
            ggplot(my_rsc, aes(snp_name, fill=rel_sam)) + geom_bar(position = 'dodge') + coord_flip()
            + ggtitle(family, 'snp read count')
        )

        print(
            ggplot(my_rsc, aes(snp_name, fill=snp_call_type)) + geom_bar(position = 'dodge') + coord_flip() + facet_grid(~rel_sam)
            + ggtitle(family, 'snp calls')
        )

        print(
            ggplot(rsc, aes(snp_name, snp_call_quality, fill=snp_call_type)) + geom_violin(position = 'dodge') + scale_fill_discrete(name='')
             + coord_flip() + facet_grid(~rel_sam)
             + ggtitle(family, 'snp call quality')
        )

        print(
            ggplot(by_read, aes(n_snps)) + geom_bar() + facet_grid(~mutation_call_type) + ggtitle(family, 'n snps by mutation type')
        )

        print(
            ggplot(by_read, aes(inconsistent)) + geom_bar() + facet_grid(~mutation_call_type) + ggtitle(family, 'snp consistency by mutation type')
        )

        print(
            ggplot(by_read, aes(n_paternal, n_maternal, color = mutation_call_type))
            + geom_jitter()
            + geom_abline()
            + ggtitle(family, 'Number of SNP alleles by mutation allele')
        )

        print(
            ggplot(read_likelihood, aes(logbf)) +
            geom_histogram()
            + ggtitle(family, 'Per-read logBF for maternal > paternal')
        )

        print(
            ggplot(read_likelihood_bg, aes(bg_median_logbf))
            + geom_histogram()
            + geom_vline(xintercept = median_logbf, color = 'red')
            + ggtitle(family, 'foreground vs. background median logbf')
        )

        print(
            ggplot(read_likelihood_bg, aes(bg_total_logbf))
            + geom_histogram()
            + geom_vline(xintercept = total_logbf, color = 'red')
            + ggtitle(family, 'foreground vs. background total logbf')
        )

    }
    dev.off()
    message(fn)
}

if(!interactive()) {
    main()
}


# Environment Setting
library(recommenderlab)
data(Jester5k)

model_data <- Jester5k[rowCounts(Jester5k) < 80]
model_data <- model_data[rowMeans(model_data) >= -5 & rowMeans(model_data) <= 7]
dim(model_data)

# Train and Test Data
set.seed(2020)
which_train <- sample(
    x = c(TRUE, FALSE),
    size = nrow(model_data),
    replace = TRUE,
    prob = c(0.8, 0.2)
)
model_data_train <- model_data[which_train, ]
model_data_test <- model_data[!which_train, ]
dim(model_data_train)
dim(model_data_test)

# Modeling
model_to_evaluate <- "IBCF"
model_parameters <- NULL

model_recommender <- Recommender(
    data = model_data_train,
    method = model_to_evaluate,
    parameter = model_parameters
)
model_recommender
model_details <- getModel(model_recommender)
str(model_details)

# Recommendation
item_to_recommend <- 10

model_prediction <- predict(
    object = model_recommender,
    newdata = model_data_test,
    n = item_to_recommend
)
model_prediction
model_prediction@items[[1]]

recc_user_1 <- model_prediction@items[[1]]
jokes_user_1 <- model_prediction@itemLabels[recc_user_1]
jokes_user_1

# Evaluation using k fold
n_fold <- 4
items_to_keep <- 15 # 추천 시 사용되는 최소 아이템 수
rating_threshold <- 3

eval_sets <- evaluationScheme(
    data = model_data,
    method = "cross-validation",
    k = n_fold,
    given = items_to_keep,
    goodRating = rating_threshold
)
eval_sets

model_to_evaluate <- "IBCF"
model_parameters <- NULL

eval_recommender <- Recommender(
    data = getData(eval_sets, "train"),
    method = model_to_evaluate,
    parameter = model_parameters
)

items_to_recommend <- 10
eval_prediction <- predict(
    object = eval_recommender,
    newdata = getData(eval_sets, "known"),
    n = item_to_recommend,
    type = "ratings"
)

eval_accuracy <- calcPredictionAccuracy(
    x = eval_prediction,
    data = getData(eval_sets, "unknown"),
    byUser = TRUE
)
apply(eval_accuracy, 2, mean)
eval_accuracy <- calcPredictionAccuracy(
    x = eval_prediction,
    data = getData(eval_sets, "unknown"),
    byUser = FALSE
)
eval_accuracy

results <- evaluate(
    x = eval_sets,
    method = model_to_evaluate,
    n = seq(10, 100, 10)
)
columns_to_sum <- c("TP", "FP", "FN", "TN", "precision", "recall")
indices_summed <- Reduce("+", getConfusionMatrix(results))[, columns_to_sum]
indices_summed
plot(results, annotate = TRUE, main = "ROC curve")
plot(results, "prec/rec", annotate = TRUE, main = "Precision-Recall")

# Parameter Tuning
vector_k <- c(5, 10, 20, 30, 40)
model1 <- lapply(
    vector_k,
    function(k, l) {
        list(name = "IBCF", param = list(method = "cosine", k = k))
    }
)
names(model1) <- paste0("IBCF_cos_k", vector_k)
names(model1)

model2 <- lapply(
    vector_k,
    function(k, l) {
        list(name = "IBCF", param = list(method = "pearson", k = k))
    }
)
names(model2) <- paste0("IBCF_pea_k", vector_k)
names(model2)

models <- append(model1, model2)

n_recommendations <- c(1, 5, seq(10, 100, 10))
list_results <- evaluate(
    x = eval_sets,
    method = models,
    n = n_recommendations
)
plot(list_results, annotate = c(1, 2), legend = "topleft")
title("ROC curve")

plot(list_results, "prec/rec", annotate = 1, legend = "bottomright")
title("Precision-Recall")


# Coursera Getting and Cleanind Data course project
# Here are the data for the project: "https://d396qusza40orc.cloudfront.net/getdata%2Fprojectfiles%2FUCI%20HAR%20Dataset.zip"

# Tasks: " You should create one R script called run_analysis.R that does the following:"

# 1) Merges the training and the test sets to create one data set.
# 2) Extracts only the measurements on the mean and standard deviation for each measurement.
# 3) Uses descriptive activity names to name the activities in the data set
# 4) Appropriately labels the data set with descriptive variable names.
# 5) From the data set in step 4, creates a second, independent tidy data set with the average of each variable for each activity and each subject.

# 1) Merges the training and the test sets to create one data set.
#reading in the data of x
dx1 <- read.table("./train/X_train.txt")
dx2 <- read.table("./test/X_test.txt")
#reading in the data of y
dy1 <- read.table("train/y_train.txt")
dy2 <- read.table("test/y_test.txt")
#reading in the data of the subjects
ds1 <- read.table("./train/subject_train.txt")
ds2 <- read.table("./test/subject_test.txt")
#Merging the data sets
dx <- rbind(dx1, dx2)
dy <- rbind(dy1, dy2)
ds <- rbind(ds1, ds2)

dim(dx) #10299   561
dim(dy) #10299     1
dim(ds) #10299     1

#delete temporary data
rm(dx1, dx2, dy1, dy2, ds1, ds2)

# 2) Extracts only the measurements on the mean and standard deviation for each measurement.
#read in the features
features <- read.table("features.txt")
#define the needed features
needed_features <- grep("-mean\\(\\)|-std\\(\\)", features[, 2])
#subsetting
dx <- dx[, needed_features]
# correct var names
names(dx) <- features[needed_features, 2]
# remove "()" from var names
names(dx) <- gsub("\\(\\)", "", features[needed_features, 2])
# remove "-" from var names
names(dx) <- gsub("-", "", names(dx))
# capital m in "mean"
names(dx) <- gsub("mean", "Mean", names(dx))
#capital s in "std"
names(dx) <- gsub("std", "Std", names(dx))

#delete temporary data
rm(needed_features, features)

# 3. Uses descriptive activity names to name the activities in the data set.
#read in the features
activities <- read.table("activity_labels.txt")
# correct names
activities[, 2] = gsub("_", "", tolower(as.character(activities[, 2])))
substr(activities[2, 2], 8, 8) <- toupper(substr(activities[2, 2], 8, 8))
substr(activities[3, 2], 8, 8) <- toupper(substr(activities[3, 2], 8, 8))
#assign names
dy[,1] = activities[dy[,1], 2]
names(dy) <- "activity"

# 4. Appropriately labels the data set with descriptive activity names.

names(ds) <- "subject"
cleaned_data <- cbind(ds, dy, dx)
if(!file.exists("./Cleaned_Data")){dir.create("./Cleaned_Data")}
write.table(cleaned_data, "./Cleaned_Data/merged_cleaned_data.txt")

# 5. Creates a 2nd, independent tidy data set with the average of each variable for each activity and each subject.

Subjects_un = unique(ds)[,1]
Subjects_all = length(unique(ds)[,1])
Activities_all = length(activities[,1])
cols = dim(cleaned_data)[2]
data_averages = cleaned_data[1:(Subjects_all*Activities_all), ]

row = 1
for (s in 1:Subjects_all) {
  for (a in 1:Activities_all) {
    data_averages[row, 1] = Subjects_un[s]
    data_averages[row, 2] = activities[a, 2]
    temp <- cleaned_data[cleaned_data$subject==s & cleaned_data$activity==activities[a, 2], ]
    data_averages[row, 3:cols] <- colMeans(temp[, 3:cols])
    row = row+1
  }
}

#delete temporary data
rm(a, Activities_all, cols, row,s, Subjects_all, Subjects_un, activities, temp, ds, dx, dy)

#write cleaned data
write.table(data_averages, "./Cleaned_Data/data_averages.txt", row.name=FALSE)


#SPAM Example

library(caret); library(kernlab); data(spam)
inTrain <- createDataPartition(y=spam$type,
                               p=0.75, list=FALSE)
training <- spam[inTrain,]
testing <- spam[-inTrain,]
modelFit <- train(type ~.,data=training, method="glm")

args(train.default)

# Train Control
args(trainControl)

#trainControl resampling

#method
#boot = bootstrapping
#boot632 = bootstrapping with adjustment
#cv = cross validation
#repeatedcv = repeated cross validation
#LOOCV = leave one out cross validation
#number
#For boot/cross validation
#Number of subsamples to take
#repeats
#Number of times to repeate subsampling
#If big this can slow things down

#seed example

set.seed(1235)
modelFit2 <- train(type ~.,data=training, method="glm")
modelFit2

#seed example

set.seed(1235)
modelFit3 <- train(type ~.,data=training, method="glm")
modelFit3


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

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

A <- c(393.979,	419.038)
B <- c(366.358, 550.138)
C <- c(601.903, 632.171)
D <- c(705.481, 538.638)
O1 <- c(500.000, 500.000)
O2 <- c(585.023, 548.609)

points <- rbind(A, B, C, D, O1, O2) %>% as.data.frame() %>% rownames_to_column("Name") %>% rename(x = V1, y = V2)
points <- points %>% dplyr::mutate(id = row_number(), FIX_X = FALSE, FIX_Y = FALSE, Point_object = FALSE) %>% dplyr::select(id, Name, x, y, FIX_X, FIX_Y, Point_object)

obs_plan <- data.frame(station = rep(c("A", "A", "A", "B", "B", "B", "C", "C", "C", "D", "D", "D"), 2),
                       obs.point = rep(c("B", "O1", "O2", "A", "O2", "O1", "D", "O2","O1", "C", "O1", "O2"), 2),
                       type = c(rep("p", 12), rep("d", 12)), stringsAsFactors = FALSE)
obs_plan <- obs_plan[-which(obs_plan$obs.point %in% c("A", "B", "C", "D") & obs_plan$type == "d"), ]

points = A_points; obs.plan = A_sim_obs
Hz0 = NA; red = TRUE; sd_Hz = 5; sd_dist = 3; sd_cent_station = 1; sd_cent_target = 1; seed = NULL

sim.survey.net.raw <- sim.obs(points = points, obs.plan = obs_plan)

sim.survey.net <- import_surveynet2D(points = sim.survey.net.raw[[1]], observations = sim.survey.net.raw[[2]])

A <- Amat(survey.net = sim.survey.net, units = "mm")
f <- data.frame(f = fmat(survey.net = sim.survey.net))
P <- data.frame(Wmat(survey.net = sim.survey.net, apriori = 5))

design.snet(survey.net = sim.survey.net, apriori = 1, prob = NA, result.units = list("mm", "cm", "m"), ellipse.scale = 1, axes = c("Easting", "Northing"), teta.unit = list("deg", "rad"), all = FALSE)

survey.net = sim.survey.net; apriori = 1; prob = NA; result.units = list("mm", "cm", "m"); ellipse.scale = 1; axes = c("Easting", "Northing"); teta.unit = list("deg", "rad"); all = FALSE

writexl::write_xlsx(obs1_list, path = "obs11_list.xlsx")

# Zadatak

A_points <- readxl::read_xlsx(path = ("B:/_Bechelor/_Ispiti/Projektovanje/28.6.2019/A_plan.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
A_obs <- readxl::read_xlsx(path = ("B:/_Bechelor/_Ispiti/Projektovanje/28.6.2019/A_plan.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric"))
A.survey.net <- import_surveynet2D(points = A_points, observations = A_obs)

B_points <- readxl::read_xlsx(path = ("B:/_Bechelor/_Ispiti/Projektovanje/28.6.2019/B_plan.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
B_obs <- readxl::read_xlsx(path = ("B:/_Bechelor/_Ispiti/Projektovanje/28.6.2019/B_plan.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric"))
B.survey.net <- import_surveynet2D(points = B_points, observations = B_obs)

A.design <- design.snet(survey.net = A.survey.net, sd.apriori = 1, prob = NA, result.units = "mm", ellipse.scale = 1, teta.unit = list("deg", "rad"), all = TRUE)
B.design <- design.snet(survey.net = B.survey.net, sd.apriori = 1, prob = NA, result.units = "mm", ellipse.scale = 1, teta.unit = list("deg", "rad"), all = TRUE)

A.design$design.matrices
A.design$net.points
B.design$net.points

# Makis

Makis_points <- readxl::read_xlsx(path = ("./Data/Input/With_observations/Makis/Makis_observations.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
Makis_obs <- readxl::read_xlsx(path = ("./Data/Input/With_observations/Makis/Makis_observations.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric"))
Makis.survey.net <- import_surveynet2D(points = Makis_points, observations = Makis_obs)

Makis.design <- design.snet(survey.net = Makis.survey.net, sd.apriori = 6, prob = NA, result.units = "mm", ellipse.scale = 1, axes = c("Easting", "Northing"), teta.unit = list("deg", "rad"), all = TRUE)

A <- Amat(survey.net = Makis.survey.net, units = "mm")
f <- data.frame(f = fmat(survey.net = Makis.survey.net))
P <- data.frame(Wmat(survey.net = Makis.survey.net, sd.apriori = 3))

# AVALA

avala_points <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Avala/Avala_observations.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
avala_obs <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Avala/Avala_observations.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric"))
avala <- import_surveynet2D(points = avala_points, observations = avala_obs)
avala[[2]] <- mutate(avala[[2]], Hz = HzD + HzM/60 + HzS/3600, Vz = VzD + VzM/60 + VzS/3600, HD = SD*sin(Vz*pi/180)) %>%
  dplyr::filter(to %in% c("S1","S2","S3","S4","S5","S6")) %>% dplyr::filter(from != "S7")

ggplot(data = avala[[1]]) + geom_sf() + ggrepel::geom_label_repel(
  data = avala[[1]],
  aes(label = Name, geometry = geometry),
  stat = "sf_coordinates",
  min.segment.length = 0,
  colour = "magenta",
  segment.colour = "magenta"
) + theme_bw()

# Brana

brana_points <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Brana/Brana.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
brana_obs <- readxl::read_xlsx(path = here::here("Data/Input/With_observations/Brana/Brana.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric"))
brana <- import_surveynet2D(points = brana_points, observations = brana_obs)

brana.adjust <- adjust.snet(survey.net = brana, result.units = "mm", adjust = FALSE)

brana.adjust$net.points

plot(brana[[1]]$geometry)

# TETO

TETO_points <- readxl::read_xlsx(path = ("D:/R_projects/Surveyer/Data/Input/Without_observations/xlsx/TETO_plan opazanja.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
TETO_obs <- readxl::read_xlsx(path = ("D:/R_projects/Surveyer/Data/Input/Without_observations/xlsx/TETO_plan opazanja.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric"))
TETO.survey.net <- import_surveynet2D(points = TETO_points, observations = TETO_obs, axes = c("Easting", "Northing"))

TETO_sim_obs <- rbind(dplyr::filter(TETO.survey.net$observations, direction), dplyr::filter(TETO.survey.net$observations, direction)) %>%
  dplyr::select(from = station, to = obs.point) %>% sf::st_drop_geometry() %>%
  dplyr::mutate(type = c(rep("p", 50), rep("d", 50)))

TETO.adjust <- adjust.snet(survey.net = TETO.survey.net, adjust = FALSE, result.units = "mm")

writexl::write_xlsx(TETO.adjust$observations %>% select(-geometry), "TETO_obs.xlsx")
writexl::write_xlsx(TETO.adjust$net.points %>% select(-geometry), "TETO_points.xlsx")

#TETO Simulation

sim.survey.net.raw <- sim.obs(points = TETO_points, obs.plan = TETO_sim_obs)

# Zadatak

A_points <- readxl::read_xlsx(path = ("E:/_Bechelor/_Ispiti/Projektovanje/17.9.2019/A_plan.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
A_obs <- readxl::read_xlsx(path = ("E:/_Bechelor/_Ispiti/Projektovanje/17.9.2019/A_plan.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric"))
A.survey.net <- import_surveynet2D(points = A_points, observations = A_obs)

B_points <- readxl::read_xlsx(path = ("E:/_Bechelor/_Ispiti/Projektovanje/17.9.2019/B_plan.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
B_obs <- readxl::read_xlsx(path = ("E:/_Bechelor/_Ispiti/Projektovanje/17.9.2019/B_plan.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric"))
B.survey.net <- import_surveynet2D(points = B_points, observations = B_obs, axes = c("Northing", "Easting"))

plot(A.survey.net[[1]]$geometry)
plot(A.survey.net[[2]]$geometry,add = TRUE)

A.design <- adjust.snet(adjust = FALSE, survey.net = A.survey.net, sd.apriori = 3, prob = NA, result.units = "mm", ellipse.scale = 1, teta.unit = list("deg", "rad"), all = TRUE)
B.design <- adjust.snet(adjust = FALSE,survey.net = B.survey.net, sd.apriori = 3, prob = NA, result.units = "mm", ellipse.scale = 1, teta.unit = list("deg", "rad"), all = TRUE)

#A.design$design.matrices
A.design$net.points
B.design$net.points

# Zadatak 06.02.2020

# Zadatak

A_points <- readxl::read_xlsx(path = ("B:/_Bechelor/_Ispiti/Projektovanje/06.02.2020/A_plan.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
A_obs <- readxl::read_xlsx(path = ("B:/_Bechelor/_Ispiti/Projektovanje/06.02.2020/A_plan.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric"))
A.survey.net <- import_surveynet2D(points = A_points, observations = A_obs)

B_points <- readxl::read_xlsx(path = ("B:/_Bechelor/_Ispiti/Projektovanje/06.02.2020/B_plan.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
B_obs <- readxl::read_xlsx(path = ("B:/_Bechelor/_Ispiti/Projektovanje/06.02.2020/B_plan.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric"))
B.survey.net <- import_surveynet2D(points = B_points, observations = B_obs)

A.design <- adjust.snet(adjust = FALSE, survey.net = A.survey.net, sd.apriori = 3, prob = NA, result.units = "mm", ellipse.scale = 1, teta.unit = list("deg", "rad"), all = TRUE)
B.design <- adjust.snet(adjust = FALSE,survey.net = B.survey.net, sd.apriori = 3, prob = NA, result.units = "mm", ellipse.scale = 1, teta.unit = list("deg", "rad"), all = TRUE)

#A.design$design.matrices
A.design$net.points
B.design$net.points

# Zadatak 06.02.2020 - 2

# Zadatak

A_points <- readxl::read_xlsx(path = ("E:/_Bechelor/_Ispiti/Projektovanje/17.3.2019/A_plan.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
A_obs <- readxl::read_xlsx(path = ("E:/_Bechelor/_Ispiti/Projektovanje/17.3.2019/A_plan.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric"))
A.survey.net <- import_surveynet2D(points = A_points, observations = A_obs)

A.design <- adjust.snet(adjust = FALSE, survey.net = A.survey.net, sd.apriori = 3, prob = NA, result.units = "mm", ellipse.scale = 1, teta.unit = list("deg", "rad"), all = TRUE)

#A.design$design.matrices
A.design$net.points
B.design$net.points

# Simulation
B.survey.net <- dns

B_sim_obs <- rbind(dplyr::filter(B.survey.net[[2]], direction), dplyr::filter(B.survey.net[[2]], distance)) %>%
  dplyr::select(station = from, obs.point = to) %>% sf::st_drop_geometry() %>%
  dplyr::mutate(type = c(rep("p", dim(dplyr::filter(B.survey.net[[2]], direction))[1]), rep("d", dim(dplyr::filter(B.survey.net[[2]], distance))[1])))

coord_sim_res <- matrix(round(rnorm(n = 14, mean = 0, sd = 3)/1000, 3), ncol = 2)

B.survey.net[[1]]$x <- B.survey.net[[1]]$x + coord_sim_res[, 1]
B.survey.net[[1]]$y <- B.survey.net[[1]]$y + coord_sim_res[, 2]

sim.B.net <- sim.obs(points = B.survey.net[[1]], obs.plan = B_sim_obs, sd_Hz = 5, sd_cent_station = 1, sd_dist = 5, sd_cent_target = 1)
sim.B.net <- import_surveynet2D(points = sim.B.net$Points, observations = sim.B.net$Observations)

writexl::write_xlsx(sim.B.net, path = "E:/_Bechelor/_Ispiti/Projektovanje/17.9.2019/simBobs.xlsx")

#Izravnanje
B_points <- readxl::read_xlsx(path = ("E:/_Bechelor/_Ispiti/Projektovanje/17.9.2019/simBobs.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
B_obs <- readxl::read_xlsx(path = ("E:/_Bechelor/_Ispiti/Inzenjerska2/Redovni/17.9.2019/simBobs.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric"))
B.survey.net <- import_surveynet2D(points = B_points, observations = B_obs)

B.net.adjust <- adjust.snet(survey.net = sim.B.net, result.units = "mm", sd.apriori = 3)

# GORICA

# Makis

Gorica_points <- readxl::read_xlsx(path = ("./Data/Input/With_observations/Brana_Gorica/Brana_Gorica_nulta_serija.xlsx"), sheet = "Points")#, col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
Gorica_obs <- readxl::read_xlsx(path = ("./Data/Input/With_observations/Brana_Gorica/Brana_Gorica_nulta_serija.xlsx"), sheet = "Observations")#, col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric"))
Gorica.survey.net <- import_surveynet2D(points = Gorica_points, observations = Gorica_obs)

Gorica.net.adjust <- adjust.snet(survey.net = Gorica.survey.net, result.units = "mm", sd.apriori = 10)

# Simulation IG2

# Zadatak 06.02.2020 - 2

# Zadatak

ig_points <- readxl::read_xlsx(path = ("C:/R_projects/Surveyer/Data/Input/Without_observations/xlsx/zadatak_IG2.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "logical", "logical", "logical"))
ig_obs <- readxl::read_xlsx(path = ("C:/R_projects/Surveyer/Data/Input/Without_observations/xlsx/zadatak_IG2.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric"))
ig.net <- import_surveynet2D(points = ig_points, observations = ig_obs)

A.design <- adjust.snet(adjust = FALSE, survey.net = ig.net, sd.apriori = 3, prob = NA, result.units = "mm", ellipse.scale = 1, teta.unit = list("deg", "rad"), all = TRUE)

#A.design$design.matrices
A.design$net.points
B.design$net.points

ig_sim_obs <- rbind(dplyr::filter(ig.net[[2]], direction), dplyr::filter(ig.net[[2]], distance)) %>%
  dplyr::select(station = from, obs.point = to) %>% sf::st_drop_geometry() %>%
  dplyr::mutate(type = c(rep("p", dim(dplyr::filter(ig.net[[2]], direction))[1]), rep("d", dim(dplyr::filter(ig.net[[2]], distance))[1])))

coord_sim_res <- matrix(round(rnorm(n = 12, mean = 0, sd = 3)/1000, 3), ncol = 2)

ig_points$x <- ig_points$x + coord_sim_res[, 1]
ig_points$y <- ig_points$y + coord_sim_res[, 2]

sim.ig.net <- sim.obs(points = ig_points, obs.plan = ig_sim_obs, sd_Hz = 5, sd_cent_station = 1, sd_dist = 3, sd_cent_target = 1)
sim.B.net <- import_surveynet2D(points = sim.B.net$Points, observations = sim.B.net$Observations)

########### 1D ############################################

dns_points <- readxl::read_xlsx(path = ("D:/R_projects/Surveyer/Data/Input/With_observations/DNS_1D/DNS_1D_nulta.xlsx"), sheet = "Points", col_types = c("numeric", "text", "numeric", "numeric", "numeric", "logical", "logical", "logical", "logical"))
dns_obs <- readxl::read_xlsx(path = ("D:/R_projects/Surveyer/Data/Input/With_observations/DNS_1D/DNS_1D_nulta.xlsx"), sheet = "Observations", col_types = c("text", "text", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric","numeric","numeric", "numeric", "numeric", "numeric", "numeric", "numeric", "numeric"))

file = file_path

#Wmat1D(survey.net = dns, w_model = "n_dh")
#Amat1D(survey.net = dns)
#fmat1D(survey.net = dns, units = "mm")

file_path <- "D:/R_projects/Surveyer/Data/Input/With_observations/DNS_1D/DNS_1D_nulta.xlsx"
file_path <- here::here("Data/Input/With_observations/Brana/Brana.xlsx")
file_path <- here::here("Data/Input/With_observations/Makis/Makis_observations.xlsx")
file_path <- here::here("Data/Input/With_observations/Zadatak 1/Zadatak_1.xlsx")
file_path <- here::here("Data/Input/Without_observations/xlsx/TETO_plan opazanja.xlsx")
dns <- read_surveynet(file = file_path)
survey.net = dns
dim_type = "1D"
result.units = "mm"
prob = 0.99
adjust = FALSE
sd.apriori = 0.2
coord_tolerance = 1e-2
maxiter = 50
teta.unit = list("deg", "rad"); units.dir = "sec"; units.dist = "mm"; use.sd.estimated = TRUE; all = FALSE; ellipse.scale = 1

file_path <- "D:/R_projects/Surveyer/Data/Input/With_observations/DNS_1D/DNS_1D_nulta.xlsx"
file_path <- here::here("Data/Input/With_observations/Brana/Brana.xlsx")
file_path <- here::here("Data/Input/With_observations/Makis/Makis_observations.xlsx")
file_path <- here::here("Data/Input/With_observations/Zadatak 1/Zadatak_1.xlsx")
file_path <- here::here("Data/Input/Without_observations/xlsx/TETO_plan opazanja1.xlsx")
file_path <- here::here("Data/Input/Without_observations/xlsx/zadatak_2862019.xlsx")
file_path <- here::here("Data/Input/Without_observations/xlsx/zadatak_2862019_sim.xlsx")

dns <- read_surveynet(file = file_path)
plot_surveynet(snet = dns, webmap = FALSE, net.1D = FALSE, net.2D = TRUE)
ab <- sim_snetobs(survey.net = dns, red = TRUE)
aa <- list(Points = ab[[1]] %>% st_drop_geometry(), Observations = ab[[2]] %>% st_drop_geometry() %>% dplyr::select(ID:e_air))
aaa <- adjust.snet(adjust = TRUE, survey.net = dns, dim_type = "2D", sd.apriori = 3,  all = FALSE, prob = 0.95)
bb <- adjust.snet(adjust = TRUE, survey.net = ab, dim_type = "2D", sd.apriori = 1,  all = FALSE, prob = 0.99)
writexl::write_xlsx(aa)
aa$Observations %>% st_drop_geometry()

bb %>% .$Observations %>% dplyr::filter(type == "distance") %>% .$v %>% sd()


rdirichlet = function(n, a) {
  l = length(a)
  x = matrix(rgamma(n * l, a), ncol = l, byrow = T)
  s = x %*% rep(1, l)
  x / as.vector(s)
}


#弯月面Meniscus的高度和角度随流量，极间距离，针头直径变化而变化
#针头三种液体，ethanol，acetone， isoproply
#height高度和angle角度，在一张图上，分为上下部分
#三张图，分别对应三种x轴，流量，极间距离，电压
#固定电压数值为2.0kv
#用mtext函数标记其他相关参数信息
#函数名为men_ih & men_ea, men_ih & men_ia，men_ih & men_ia

#设定工作区间
setwd("D:/data")
library(xlsx)

#读取数据
men_ih<-read.xlsx("set_voltage.xls", sheetName="radius_h", header=TRUE)
men_ia<-read.xlsx("set_voltage.xls", sheetName="radius_a", header=TRUE)

#规划figure界面
par(mfrow=c(2,1), mar=c(4,4,2,2), oma=c(2,1,1,1))

#保存pdf
pdf("set_voltage_radius.pdf")

################################画图-高度曲线###########################
plot(men_ih$radius, men_ih$ethanol, col=0, xaxs="i", xlim=c(0.3, 0.85), ylim=c(0.2, 0.6),
xlab="Diameter (mm)", cex.lab=1, ylab="Height of Meniscus (mm)", main="Height with Rn in meniscus")

lines(lowess(men_ih$radius, men_ih$ethanol), col="red", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ih$radius, men_ih$acetone), col="blue", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ih$radius, men_ih$iso), col="darkgreen", pch=21, lwd=2, type="b", lty=2)

legend("topleft", c("ethanol", "acetone", "isoproply"), inset=.02, col=c("red", "blue", "darkgreen"), pch=21, lwd=2, lty=2, cex=0.9)

##############################画图--角度曲线############################
plot(men_ia$radius, men_ia$ethanol, col=0, xaxs="i", xlim=c(0.3, 0.85), ylim=c(50, 140),
xlab="Diameter (mm)", cex.lab=1, ylab="Taylor Angle (°)", main="Angle with Rn in meniscus")

lines(lowess(men_ia$radius, men_ia$ethanol), col="red", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ia$radius, men_ia$acetone), col="blue", pch=21, lwd=2, type="b", lty=2)

lines(lowess(men_ia$radius, men_ia$iso), col="darkgreen", pch=21, lwd=2, type="b", lty=2)

legend("topright", c("ethanol", "acetone", "isoproply"), inset=.02, col=c("red", "blue", "darkgreen"), pch=21, lwd=2, lty=2, cex=0.9)

mtext("Voltage is set at 2.0 kv", 1, line=1, col="black", cex=1.3, font=2, outer=TRUE)

###标注信息

dev.off()


###########################################################
### Class for working with other models beyond regression, including
### reguilarization with elastic net, weakly informative pairs
### nonlinear least squares, splines, GAMs, decision trees, random forests
###########################################################
library(ggplot2)
library(scales)
library(ggthemes)
library(XML)
library(plyr)
library(stringr)
library(reshape2)

# select variables and improve predictions with the elastic net
# useful for high-dimensional data
# load acs data to work with.

acs <- read.table("http://www.jaredlander.com/data/acs_ny.csv", sep = ",", header = TRUE, stringsAsFactors = FALSE)
acs$Income <- with(acs, FamilyIncome >= 150000)
names(acs)[length(acs)] <- "Income" # error in names in data fixed
head(acs)

# load the package for elastic net
library(glmnet)
library(useful)

# Now need to build up two required matrices for elasticnet.
acsX <- build.x(Income ~ NumBedrooms + NumChildren + NumPeople + NumRooms +
                NumUnits + NumVehicles + NumWorkers + OwnRent + YearBuilt +
                ElectricBill + FoodStamp + HeatingFuel + Insurance + Language -1,
                data = acs,
                contrasts = FALSE)
# observe the hogh-dimensionality of the resulting matrix
class(acsX)
dim(acsX)
# now build out Y
acsY <- build.y(Income ~ NumBedrooms + NumChildren + NumPeople + NumRooms +
                NumUnits + NumVehicles + NumWorkers + OwnRent + YearBuilt +
                ElectricBill + FoodStamp + HeatingFuel + Insurance + Language -1,
                data = acs)

# now we need to determine the lambda for the penalty coefficient.
# to get there we use k-fold cross validation
set.seed(2975961)

acsCV1 <- cv.glmnet(acsX, acsY, family="binomial", nfolds = 5)
# this yields lambdas in a vector
acsCV1
# plot them
plot(acsCV1)
# now look at the coefficients of the correlation vars for one particular lambda
coef(acsCV1, s="lambda.1se")
# plot it out
plot(acsCV1$glmnet.fit, xvar = "lambda")
# draw in our lambdas
abline(v = log(c(acsCV1$lambda.min, acsCV1$lambda.1se)), lty = 2)

# This has used the default weighting of L1 and L2 in the elasticnet, which is lasso (1)
# for comparison, let's change the weight to the other extreme, 0, all ridge regression
# usually looking for alpha = [0.7,1.0]
acsCV2 <- cv.glmnet(acsX, acsY, family="binomial", nfolds = 5, alpha = 0)
plot(acsCV2$glmnet.fit, xvar = "lambda")
abline(v = log(c(acsCV2$lambda.min, acsCV2$lambda.1se)), lty = 2)
# here we see that the coefficients never get thrown out but squashed towards 0 to
# minimize the error


kr <- function (A, B, w, byrow = TRUE)
{
    if (byrow) {
    if (nrow(A) != nrow(B))
      stop("Dimensions of the matrices do not match.")
    if (missing(w))
      w <- rep(1, nrow(A))
    if (nrow(A) != length(w))
      stop("Length of the weight does not match with the dimension of the matrices.")
    cola <- ncol(A)
    colb <- ncol(B)
    colab <- cola * colb

    expr <- paste("rbind(", paste(rep("A", colb), collapse = ","),
                             ")", sep = "")
    A <- eval(parse(text = expr))
    A <- matrix(c(A), nrow(B), ncol = colab)
    A <- w * A
    expr2 <- paste("cbind(", paste(rep("B", cola), collapse = ","),
                              ")", sep = "")
    B <- eval(parse(text = expr2))
  }
  else {
    if (ncol(A) != ncol(B))
      stop("Dimensions of the matrices do not match.")
    if (missing(w))
      w <- rep(1, ncol(A))
    if (ncol(A) != length(w))
      stop("Length of the weight does not match with the dimension of the matrices.")
    rowa <- nrow(A)
    rowb <- nrow(B)
    rowab <- rowa * rowb
    A <- matrix(rep(A, each = rowb), rowab, )
    A <- A * matrix(w, nrow(A), ncol(A), byrow = TRUE)
    expr <- paste("rbind(", paste(rep("B", rowa), collapse = ","),
                             ")", sep = "")
    B <- eval(parse(text = expr))
  }
  return(A * B)
}


You can normalize, for example,
the forward transform FFTW.fft(narray, -1, 0, 1)
(FFT regarding the first (dim 0) & second (dim 1) dimensions) by
dividing with (narray.shape[0]*narray.shape[1]). Likewise,
the result of FFTW.fft(narray, -1) (FFT for all dimensions)
can be normalized by narray.length.


#' Processes RT data from our experiments and uses it for testing if the DDM or the UGM
#' are better fits to the data
#' interface script for fitting routines to test Stone vs Stone+UGM model #
#'

# Typically because there is randomness in the optimizer you end up using at least five runs of the model in order
# to be sure your data are correct

rm(list=ls())
library(tictoc);
source("chartr-FitRoutines.r")
source("chartr-HelperFunctions.r")

jobnum=as.numeric(Sys.getenv("SGE_TASK_ID"));

set.seed(jobnum)
fnam = letters[jobnum];

# source the fitting code files

dirs="colgrid"  # directory name of data files to fit
subjs=dir(dirs);
nsubj=length(subjs)

# subject names
# set up fit to data

# Grab a list of subjects
listOfSubjects = subjs;

# Setup some baseline parameters
contp = list(p=0)  # if estcontp==FALSE, give proportion of contaminant responses
maxits = 750  # number of iterations of DEoptim to run
nparticles = 200  # number of particles/chains for DEoptim
nmc =10000  # number of MC samples for simulating the models at each iteration
estcontp=FALSE  # estimate contaminant mixture probability from data. usually set to false

bailouttime=4  # time after which to bail out of diffusion sims, in seconds
maxTimeStep=as.double(length(seq(0,bailouttime,.001)))   # max iterations for fitting routine, then bail out

pred=F  # generate model predictions from fitting routine (only use this once you have estimtated parameters from data using DEoptim)

nreps = 5;
gub=4

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

for(subjId in seq(1,length(listOfSubjects)))
{
  subjnam=listOfSubjects[subjId]
  for(modelId in seq(1,length(modelList)))
  {

    # Clear logs for tic
    tic.clearlog();
    tic("dataLoading", quiet=TRUE);

    # load data set to fit
    load(paste(dirs,"/",subjnam,sep=""))
    model= modelList[modelId]

    saveFileName=paste(dirs,"_Fits/",subjnam,"-",model,"-",fnam,sep="")
    if(!file.exists((saveFileName))){
    cat(paste("\n",dirs,"dataset:",subjnam,", \n model:",model,"\n Filename", fnam,"\n\n",sep=" "))

    # for simple switching in fitting routine
    qps=as.numeric(dimnames(dat$q)[[1]])
    ncohs=1:dim(dat$q)[3]

    # make parameter vector - different scaling for Stone and Stone+UGM
    #    order: drifts (7), eta, upper boundary, Ter
    nstart=1;
    nds=length(ncohs)    # v1 is 0% coherence, will be set to 0 drift in internal function

    actualParams = paramsandlims(model, nds, nstart=nstart)
    fitUGM = unname(actualParams$fitUGM)
    lowers = actualParams$lowers
    uppers = actualParams$uppers
    parnames = actualParams$parnames

    stepsize=ifelse(fitUGM < 0,.001,1)  # time step for diffusion process: .001s (Stone), 1ms (UGM)
    stoch.s=ifelse(fitUGM < 0,.1,100)   # diffusion constant
    timecons=ifelse(fitUGM < 0,0,100)   # time constant for low pass filter
    usign=ifelse(fitUGM < 0,0,1)        # scaling value for linear urgency function (usign=1 is linear with time). EAM needs usign=0, timecons=0

    toc(log=TRUE,quiet=TRUE);

    # cutoff for very slow RTs
    # gub = global upper bound in seconds - no RTs should be slower than this (and none were in data)
    tic("optimization", quiet=TRUE);
    print("Starting optimization ...")
    library(DEoptim)

      tmp=DEoptim(
        fn=obj,
        lower=lowers,
        upper=uppers,
        dat=dat,
        nmc=nmc,
        contp=contp,
        ncohs=ncohs,
        fitUGM=fitUGM,
        gub=gub,
        pred=FALSE,
        qps=qps,
        stepsize=stepsize,
        stoch.s=stoch.s,
        timecons=timecons,
        usign=usign,
        parnames=parnames,
        maxTimeStep=maxTimeStep,
        control=DEoptim.control(itermax=maxits,NP=nparticles,trace=TRUE,
                                parallelType=1,reltol=1e-6,steptol=200,
                                # load objects used for fitting, for parallelType==1
                                parVar=list("dat","lowers","uppers","nmc","contp","ncohs", "fitUGM","pred",
                                            "qps", "stepsize","stoch.s","timecons","usign","parnames","maxTimeStep","maxits","nparticles","gub",
                                            "diffusionC","makeparamlist","contaminantmixresps","qmpouts","getpreds","obj","returnListOfModels")
                                # same again, but for functions
        ));
    cat(paste("\n",dirs,"dataset:",subjnam,", model:",model,fnam,"\n\n",sep=" "))

    toc(log=TRUE,quiet=TRUE);

    tic("objective",quiet=TRUE);

    out=tmp$optim$bestmem
    names(out)=parnames
    print(round(out,4))

    print(round(tmp$optim$bestval,4))
    # re-calculate obj for best fitting parameters, to determine amount of noise
    # in the obj value for the best fit
    mcsforpreds=50000
    reobj=obj(x=tmp$optim$bestmem,dat=dat,nmc=mcsforpreds,
              contp=contp,ncohs=ncohs,fitUGM=fitUGM,gub=gub,pred=FALSE,
              qps=qps,stepsize=stepsize,stoch.s=stoch.s,timecons=timecons,usign=usign,
              parnames=parnames,maxTimeStep=maxTimeStep)
    print(round(reobj,4))

    # Now compute it for each level of quantile. Suspicion is that you go awry for the hardest coherences and you really need to think
    # about what goes on there. Life is not easy there :)
    mcsforpreds=50000
    reobjperpoint=objPerQ(x=tmp$optim$bestmem,dat=dat,nmc=mcsforpreds,
                          contp=contp,ncohs=ncohs,fitUGM=fitUGM,gub=gub,pred=FALSE,
                          qps=qps,stepsize=stepsize,stoch.s=stoch.s,timecons=timecons,usign=usign,
                          parnames=parnames,maxTimeStep=maxTimeStep)
    print(round(reobjperpoint,4))
    toc(log=TRUE,quiet=TRUE);

    # Now get timings etc from the toc log.

    timingLogTxt <- tic.log(format = TRUE);
    timingLogLst <- tic.log(format = FALSE)
    timings <- unlist(lapply(timingLogLst, function(x) x$toc - x$tic))
    rawTimingsTic <- unlist(lapply(timingLogLst, function(x) x$tic))
    rawTimingsToc <- unlist(lapply(timingLogLst, function(x) x$toc))

    out=list(dataset=subjnam,model=model,ndataset=fnam,pars=out,
             obj=-tmp$optim$bestval,reobj=-reobj, reobjperpoint=reobjperpoint,
             lower=lowers, upper=uppers,
             timings = timings, timingLogLst = timingLogLst, timingLogTxt = timingLogTxt,
             rawTimingsTic = rawTimingsTic, rawTimingsToc = rawTimingsToc);

    save(out,file=saveFileName)
    }
    else
    {
      cat(paste("\n",dirs,"dataset:",subjnam,", model:",model,fnam," already exists..skipping",sep=" "))
    }

  }
}


# James Rekow

#  sdDiff is almost never significant (to the level of having a difference in means greater than or
#  equal to one standard deviation), so don't bother with that anymore

#  change sd to a formulation using se, see if that helps at all

se = function(x){

  #  ARGS: x - a numeric vector
  #
  #  RETURNS: stdError - the standard error of x

  stdError = sd(x) / sqrt(length(x))

  return(stdError)

} #  end se function

correctMeans = function(DFListList){
  DFListList = unlist(DFListList, recursive = FALSE)

  correctListMeans = function(DFList) mean(DFList[[1]]$x) < mean(DFList[[2]]$x)
  correctMeanVec = unlist(lapply(DFListList, correctListMeans))
  correctMeanVec = list(correctMeanVec)

  return(correctMeanVec)

} #  end correctMeans function

seDiff = function(DFListList){
  DFListList = unlist(DFListList, recursive = FALSE)

  significantSEDiff = function(DFList){
    over1 = DFList[[1]]$x
    over2 = DFList[[2]]$x
    sigDiff = abs(mean(over1) - mean(over2)) > max(se(over1), se(over2))
    return(sigDiff)
  } #  end significantSDDiff function

  seDiffVec = unlist(lapply(DFListList, significantSEDiff))
  seDiffVec = list(seDiffVec)

  return(seDiffVec)

} #  end seDiff function

tTestDiff = function(DFListList){
  DFListList = unlist(DFListList, recursive = FALSE)

  significanttTestDiff = function(DFList){
    over1 = DFList[[1]]$x
    over2 = DFList[[2]]$x
    sigDiff = t.test(over1, over2)$p.value < 0.05
    return(sigDiff)
  } #  end significantSDDiff function

  tTestDiffVec = unlist(lapply(DFListList, significanttTestDiff))
  tTestDiffVec = list(tTestDiffVec)

  return(tTestDiffVec)

} #  end tTestDiff function

ksTestDiff = function(DFListList){
  DFListList = unlist(DFListList, recursive = FALSE)

  significantksTestDiff = function(DFList){
    over1 = DFList[[1]]$x
    over2 = DFList[[2]]$x
    sigDiff = ks.test(over1, over2)$p.value < 0.05
    return(sigDiff)
  } #  end significantSDDiff function

  ksTestDiffVec = unlist(lapply(DFListList, significantksTestDiff))
  ksTestDiffVec = list(ksTestDiffVec)

  return(ksTestDiffVec)

} #  end DFListList function

intersectArrays = function(arr1, arr2, coordArray){

  intersectArrayVecs = function(coords){

    coords = unlist(coords)

    vec1 = unlist(arr1[coords[1], coords[2], coords[3]])
    vec2 = unlist(arr2[coords[1], coords[2], coords[3]])

    matchVec = vec1 & vec2
    matches = sum(matchVec)

    #  try returning this after initial checks
    #  significant = matches > 9

    return(matches)

  } #  end intersectArrayVecs

  intersectionArray = apply(coordArray, 1:3, intersectArrayVecs)

  return(intersectionArray)

} #  end intersectArrays function

#  Deprecated, but kept to highlight philosophy
# successfulTest = function(DFList){
#   DFList = unlist(DFList, recursive = FALSE)
#   over1 = DFList[[1]]$x
#   over2 = DFList[[2]]$x
#   correct = mean(over2) > mean(over1)
#   significant = t.test(over1, over2)$p.value < 0.05
#   return(correct && significant)
# }


## ---------------------------
##
## Script name: Advent of Code 2021 - Day 1
##
## Purpose of script:
##
## Author: Dr. Matt Forshaw
##
## Date Created: 2021-12-01
##
## Email: mforshaw@turing.ac.uk
##
## ---------------------------
##
## Notes:
##
##
## ---------------------------

library(tidyverse)
library(RcppRoll) # Import RccpRoll for roll_sum

sonar <- read_csv("input.txt",
                  col_names = "depth")

sonar <- read_csv("test_input.txt",
              col_names = "depth")

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

# Part 1
p1 <- sonar %>%
  mutate(increased = depth > lag(depth)) %>%
  group_by(increased) %>% count()

answer1 <- p1 %>% filter(increased == TRUE) %>% pull(n)
answer1
## ---------------------------

# Part 2
p2 <- sonar %>%
  mutate(increased = depth > lag(depth),
         rollsum = roll_sum(depth, 3, align = "right", fill = NA),
         rollsum_increased = rollsum > lag(rollsum)) %>%
  group_by(rollsum_increased) %>% count()

answer2 <- p2 %>%
  filter(rollsum_increased == TRUE) %>% pull(n)
answer2


cat(sapply(readLines(tail(commandArgs(), n=1)), function(s) {
  xs <- strsplit(s, ",")[[1]]
  x <- as.integer(xs[1])
  p1 <- 2^(as.integer(xs[2])-1)
  p2 <- 2^(as.integer(xs[3])-1)
  if ((x %% (p1+p1) >= p1) == (x %% (p2+p2) >= p2)) {
    "true"
  } else {
    "false"
  }
}), sep="\n")


# create data :
sample=paste(rep("sample_",40) , seq(1,40) , sep="")
specie=c(rep("carot" , 10) , rep("cumcumber" , 10) , rep("wheat" , 10) , rep("Potatoe" , 10) )
gene1=c( seq(5,14)+rnorm(10 , 4 , 1) , seq(5,14)+rnorm(10 , 4 , 1) , seq(5,14)+rnorm(10 , 4 , 1) , seq(5,14)+rnorm(10 , 4 , 1) )
gene2=c( seq(5,14)+rnorm(10 , 4 , 1) , seq(5,14)+rnorm(10 , 2 , 0.2) , seq(5,14)+rnorm(10 , 4 , 4) , seq(5,14)+rnorm(10 , 4 , 3) )
data=data.frame(sample,specie,gene1,gene2)

# Make the graph
library(lattice)
png("#35_basic_xyplot.png" , width = 480, height = 480)
xyplot(gene1 ~ gene2 | specie , data=data , pch=20 , cex=3 , col=rgb(0.2,0.4,0.8,0.5) )
dev.off()


# Metoda voditeljev

kapacitete.vrste.obcin.1 <- kapacitete.vrste.obcin[order(kapacitete.vrste.obcin$Leto),]
prenocitve.tipi$Kapaciteta <- kapacitete.vrste.obcin.1$Stevilo
tabela_1 <- prenocitve.tipi %>% rename(Prenocitve = Stevilo)
tabela_1$Prenocitve <- tabela_1$Prenocitve / 1000000
tabela_1$Kapaciteta <- tabela_1$Kapaciteta / 1000

analiza_k <- tabela_1 %>% select(Prenocitve, Kapaciteta) %>% scale()
tabela_k <- kmeans(analiza_k, 3)

tabela_1$Skupina <- tabela_k$cluster

graf_k <- ggplot(tabela_1) +
  aes(x=Kapaciteta, y=Prenocitve, col=as.factor(Skupina)) +
  geom_point() +
  labs(title="Razvrstitev turističnih občin po metodi voditeljev",
       y="Število prenočitev (milijoni)", x="Nastanitvena kapaciteta (tisoči)") +
  theme_few() +
  theme(legend.position="none")

# Regresija

dodatek <- data.frame(Tip=c("Skupaj", "Skupaj","Skupaj"),Leto=c(2021, 2022, 2023),
                      Stevilo=c(0,0, 0))

tabela_2 <- vse.prenocitve %>% filter(vse.prenocitve$Tip == "Skupaj")
tabela_2 <- tabela_2[c(13:33),]
tabela_2$Stevilo <- tabela_2$Stevilo / 1000000

model <- lm(data=tabela_2, Stevilo~Leto)
napoved <- as.data.frame(predict(model, dodatek))

dodatek[c(1,2, 3), 3] <- napoved
tabela_r <- rbind(tabela_2, dodatek)

graf_r <- ggplot(tabela_2, aes(x=Leto, y=Stevilo)) +
  geom_line(color="black") +
  geom_point(color="black") +
  geom_point(data=dodatek, aes(x=Leto, y=Stevilo), color="red", size=3) +
  labs(title="Napoved gibanja števila vseh prenočitev za leta 2021-2023",
       y="Število prenočitev (milijoni)", x="Leto") +
    scale_x_continuous(limits=c(2000, 2023), breaks=seq(2000, 2024, 2)) +
  scale_y_continuous(limits=c(4, 17),
                     breaks=seq(5, 20, 1)) +
  theme_hc() +
  geom_smooth(method=lm, formula=y~x, fullrange=TRUE, color="blue")


# Read previous scripts
# source("R/dm02_pkg.r")

# School grades (descr_grades.r)
#
# Describe school grades

# Read data ---------------------------------------------------------------

# If simulated data
source("R/dm03_sim_data.R")
# fbc <- df_all # If with other colnames
fbc <- df_tot

# Scaled vs non-scaled ----------------------------------------------------

fbc_nonsc <-
  fbc %>%
  select(pid, vars_avera, vars_grade)

fbc_sc <-
  fbc %>%
  mutate_at(c(vars_avera, vars_grade), compose(c, scale) )%>%
  select(pid, vars_avera, vars_grade) %>%
  rename_all(funs(paste0(., "_sc")))

nonsc_sc <-
  fbc_nonsc %>%
  left_join(fbc_sc, by = c("pid" = "pid_sc"))

nonsc_sc %>%
  select(contains("Average")) %>%
  distinct() %>%
  arrange(Average) %>%
  filter(Average %in% c(4:10))

fbc_nonsc %>% summary()
fbc_sc %>% summary()

tab_nonsc_sc <-
  bind_cols(
    nonsc_sc %>%
      select(contains("Literature")) %>%
      distinct() %>%
      arrange(Literature) %>%
      na.omit(),
    nonsc_sc %>%
      select(contains("Mathematics")) %>%
      distinct() %>%
      arrange(Mathematics) %>%
      na.omit(),
    nonsc_sc %>%
      select(contains("Phys_Edu")) %>%
      distinct() %>%
      arrange(Phys_Edu) %>%
      na.omit(),
    nonsc_sc %>%
      select(contains("Handicrafts")) %>%
      distinct() %>%
      arrange(Handicrafts) %>%
      na.omit(),
    nonsc_sc %>%
      select(contains("Arts")) %>%
      distinct() %>%
      arrange(Arts) %>%
      na.omit(),
    nonsc_sc %>%
      select(contains("Music")) %>%
      distinct() %>%
      arrange(Music) %>%
      na.omit()
  ) %>%
  rename(
    original_grade = Literature
  ) %>%
  select(original_grade,  contains("_sc")) %>%
  mutate(
    Average_sc = c(
      # NA,
      nonsc_sc %>%
        select(contains("Average")) %>%
        distinct() %>%
        arrange(Average) %>%
        filter(Average %in% c(4:10)) %>%
        pull(Average_sc)
    )
  )

# openxlsx::write.xlsx(
#   tab_nonsc_sc,
#   paste0(
#     "figures/tab_nonsc_sc_",
#     Sys.Date(),
#     ".xlsx"
#   )
# )

# Summary tables of grades ------------------------------------------------

tab_summary_grade <-
  fbc %>%
  select(fas_dg, vars_avera, vars_grade) %>%
  pivot_longer(-fas_dg,names_to = "subject", values_to = "grade") %>%
  group_by(fas_dg, subject) %>%
  summarise(
    n = n(),
    mean = mean(grade),
    sd = sd(grade),
    min = min(grade),
    q1 = quantile(grade, probs = 0.25),
    median = quantile(grade, probs = 0.5),
    q3 = quantile(grade, probs = 0.75),
    max = max(grade)
  ) %>%
  ungroup()

tab_summary_grade %>%
  filter(fas_dg == "none") %>%
  select(subject, mean, sd)

tab_summary_grade_sc <-
  fbc %>%
  select(fas_dg, vars_avera, vars_grade) %>%
  mutate_at(c(vars_avera, vars_grade), compose(c, scale)) %>%
  pivot_longer(-fas_dg,names_to = "subject", values_to = "grade") %>%
  group_by(fas_dg, subject) %>%
  summarise(
    n = n(),
    mean = mean(grade),
    sd = sd(grade),
    min = min(grade),
    q1 = quantile(grade, probs = 0.25),
    median = quantile(grade, probs = 0.5),
    q3 = quantile(grade, probs = 0.75),
    max = max(grade)
  ) %>%
  ungroup() %>%
  mutate(subject = paste("Scaled", subject))

bind_rows(
  tab_summary_grade,
  tab_summary_grade_sc
)

# openxlsx::write.xlsx(
#   bind_rows(
#     tab_summary_grade,
#     tab_summary_grade_sc
#   ),
#   paste0(
#     "figures/tab_summary_grade_",
#     Sys.Date(),
#     ".xlsx"
#   )
# )

# Charts of grades --------------------------------------------------------

subject_labels <-
  tibble(
    Subject = c(
      "Average"     ,
      "subject_1"  ,
      "subject_2" ,
      "subject_3"    ,
      "subject_4" ,
      "subject_5"        ,
      "subject_6"       ),
    Subject_labels = c(
      "Average",
      "Subject 1",
      "Subject 2",
      "Subject 3",
      "Subject 4",
      "Subject 5",
      "Subject 6"
    )
  )

# For real data
# subject_labels <-
#   tibble(
#     Subject = c(
#       "Average"     ,
#       "Literature"  ,
#       "Mathematics" ,
#       "Phys_Edu"    ,
#       "Handicrafts" ,
#       "Arts"        ,
#       "Music"       ),
#     Subject_labels = c(
#       "Average",
#       "Native language",
#       "Mathematics",
#       "Physical Education",
#       "Handicrafts",
#       "Arts",
#       "Music"
#     )
#   )

fas_dg_labels <-
  tibble(
    fas_dg = c(
      "dg1"     ,
      "dg2"  ,
      "dg3" ,
      "none"       ),
    Diagnosis = c(
      "Diagnosis 1",
      "Diagnosis 2",
      "Diagnosis 3",
      "None"
    )
  )

# For real data
# fas_dg_labels <-
#   tibble(
#     fas_dg = c(
#       "psy"     ,
#       "bipo"  ,
#       "dep" ,
#       "none"       ),
#     Diagnosis = c(
#       "Non-affective psychosis",
#       "Bipolar disorder",
#       "Depression",
#       "None"
#     )
#   )

fill_order <- c("Diagnosis 1",
                "Diagnosis 2",
                "Diagnosis 3",
                "None")

facet_order <- c(
  "Subject 1",
  "Subject 2",
  "Subject 3",
  "Subject 4",
  "Subject 5",
  "Subject 6"
)

# For real data
# fill_order <- c("Non-affective psychosis",
#                 "Bipolar disorder",
#                 "Depression",
#                 "None")
#
# facet_order <- c(
#   "Native language",
#   "Mathematics",
#   "Physical Education",
#   "Handicrafts",
#   "Arts",
#   "Music"
# )

# fbc %>%
#   select(Average) %>%
#   summary()
#
# fbc %>%
#   select(Average) %>%
#   filter(Average <= 5) %>%
#   count() # 11
#
# fbc %>%
#   mutate(Average = cut(Average, breaks = c(4:10))) %>%
#   count(Average) # 11 have 5 or smaller ("(4,5]")

plot_bar_av <-
  fbc %>%
  select(vars_avera, fas_dg) %>%
  mutate(Average = cut(Average, breaks = c(4:10))) %>%
  gather(Subject, Grade, -fas_dg) %>%
  left_join(subject_labels) %>%
  left_join(fas_dg_labels) %>%
  group_by(Subject_labels, Grade, Diagnosis) %>%
  count() %>%
  group_by(Subject_labels, Diagnosis) %>%
  filter(!is.na(Grade)) %>%
  mutate(
    total = sum(n),
    Percent = n/total*100
  ) %>%
  ungroup() %>%
  mutate(Diagnosis = factor(Diagnosis, levels = fill_order)) %>%
  ggplot(aes(x = Grade, y = Percent, fill = Diagnosis)) +
  facet_wrap( ~ Subject_labels, ncol = 2) +
  geom_bar(stat="identity", position = "dodge") +
  scale_x_discrete(labels = c(
    "4-5",
    ">5-6",
    ">6-7",
    ">7-8",
    ">8-9",
    ">9"
  )) +
  theme_minimal()

plot_bar_av
# ggsave("figures/plot_bar_av.pdf", h = 3, w = 6, s = 1.8)

plot_bar_spec <-
  fbc %>%
  select(vars_grade, fas_dg) %>%
  gather(Subject, Grade, -fas_dg) %>%
  left_join(subject_labels) %>%
  left_join(fas_dg_labels) %>%
  group_by(Subject_labels, Grade, Diagnosis) %>%
  count() %>%
  group_by(Subject_labels, Diagnosis) %>%
  filter(!is.na(Grade)) %>%
  mutate(
    total = sum(n),
    Percent = n/total*100
  ) %>%
  ungroup() %>%
  mutate(Diagnosis = factor(Diagnosis, levels = fill_order)) %>%
  mutate(Subject_labels = factor(Subject_labels, levels = facet_order)) %>%
  ggplot(aes(x = Grade, y = Percent, fill = Diagnosis)) +
  facet_wrap( ~ Subject_labels, ncol = 2) +
  geom_bar(stat="identity", position = "dodge") +
  theme_minimal()

plot_bar_spec
# ggsave("figures/plot_bar_spec.pdf", h = 7, w = 6, s = 1.8)

# Correlation -------------------------------------------------------------

# Modifed example: http://padamson.github.io/r/ggally/ggplot2/ggpairs/2016/02/16/multiple-regression-lines-with-ggpairs.html

# Linear
pair_linear <-
  function(data, mapping, ...) {
    p <- ggplot(data = data, mapping = mapping) +
      # geom_jitter(size = 0.5, alpha = 0.05) +
      # geom_smooth(method="gam", formula = y ~ s(x, bs = "tp", k = 5), ...
      # , fill="red", color="red", ...
      # )
      geom_smooth(method=lm, ...
                  # fill="blue", color="blue", ...
      )
    p
  }

# Non-linear
pair_nonlinear <-
  function(data, mapping, ...) {
    p <- ggplot(data = data, mapping = mapping) +
      # geom_jitter(size = 0.5, alpha = 0.05) +
      geom_smooth(method="gam", formula = y ~ s(x, bs = "tp", k = 5), ...
                  # , fill="red", color="red", ...
      )
    # geom_smooth(method=lm, ...
    # fill="blue", color="blue", ...
    # )
    p
  }

cor_plot_data <-
  fbc %>%
  select(fas_dg, vars_avera, vars_grade)  #%>%
  # sample_n(1000) %>% # Sample for quick testing
  # For real data:
  # mutate(
  #   fas_dg = case_when(
  #     fas_dg == "none" ~ "None",
  #     fas_dg == "psy" ~ "Psychosis",
  #     fas_dg == "bipo" ~ "Bipolar",
  #     fas_dg == "dep" ~ "Depression")
  # ) %>%
  # rename(
  #   `Native Language` = Literature,
  #   `Physical Education` = Phys_Edu
  # )

cor_plot2 <-
  cor_plot_data %>%
  GGally::ggpairs(
    # columns = c(2, 3, 7), # few columns for quick testing
    columns = 2:ncol(.),
    mapping = ggplot2::aes(color = fas_dg),
    lower = list(continuous = pair_nonlinear),
    upper = list(continuous = pair_linear),
    diag = list(continuous = wrap("densityDiag", adjust = 10, alpha = 0.4))
  ) +
  theme_minimal()

cor_plot2
# ggsave("figures/cor_plot2.pdf", cor_plot2, h = 7, w = 6, s = 2.75)


data = read.table('table.data', header = TRUE,  sep = '\t',  stringsAsFactors = FALSE)
df = data.frame(data)

colMax <- function(data) sapply(data, min, na.rm = TRUE)
colMin <- function(data) sapply(data, max, na.rm = TRUE)

print("Minimum price and attributes:")
print(colMin(df))

print("Maximum price and attributes:")
print(colMax(df))

Curs 1 - Introduction in Machine Learning/set6.r


library(colonCA)
data(colonCA)

#
# knn function implements the kNN algorithm
# @param k The number of nearest neighbors
# @param dataset The dataset we will work with
# @param dataset.factor The factor values of the dataset, that is, the labels
# @param training The number of training elements
# @return A vector with the correspondant classification
#

knn <- function(k, dataset, dataset.factor, training=50) {

    classification = vector()
    distances <- as.matrix(dist(dataset))
    no.labels = length(levels(dataset.factor))

    indexes = sample(1:nrow(dataset))
    shuffled.dataset <- dataset[indexes,]
    training.dataset <- shuffled.dataset[1:training,]

    for (i in indexes[1:training]) {

        ordered.row <- order(distances[,i])
        k.nearest.neighbors = ordered.row[2:(k+1)]

        # majority voting
        voting = table(colonCA$class[k.nearest.neighbors])
        classification <- append(classification, names(sort(voting))[no.labels])
    }
    result <- list(indexes[1:training], classification)
}

colon.ds <- exprs(colonCA)
colon.ds <- t(colon.ds)
colon.ds <- colon.ds[1:20, 1:8]

# knn(3, iris)
classification <- knn(3, colon.ds, colonCA$class, training=3)