paper<-T                   # output on paper (=TRUE) or screen (=FALSE)
Portrait<-T                 # graphical output orientation

first.year<- 1974                #first year on plot, negative value means value defined by data
last.year<- 2113                #last year on plot

OperatingModel<-F
##########################################################################

cleanup()

if (paper) dev<-"png" else dev<-"screen"
file.name<-'M2summary'
#dev<-"dummy"
 nox<-3; noy<-3;
noxy<-nox*noy

ref<-Read.reference.points()

Init.function()

if (!OperatingModel) dat<-Read.summary.data(read.init.function=F)
if (OperatingModel) {
  dat1<-Read.summary.data(extend=F,read.init.function=F)

  dat<-Read.summary.data(infile="OP_summary.out",read.init.function=F)
  if (SMS.control@no.areas >1) {
    dat$N.bar<-dat$N*(1-exp(-dat$Z))/dat$Z
    dat$DM<-dat$M*dat$N.bar
    dat$DM1<-dat$M2*dat$N.bar
    dat$DM2<-dat$M2*dat$N.bar
    dat$DF<-dat$F*dat$N.bar
    dat$DZ<-dat$Z*dat$N.bar
    dat$Nwest<-dat$N*dat$west
    dat$Cweca<-dat$C*dat$weca

    dat<-aggregate(cbind(DM,DM1,DM2,DF,DZ,N,C,Nwest,Cweca,Yield,CWsum,BIO,SSB)~Species+Year+Quarter+Species.n+Age,sum,na.rm=T,data=dat)
    dat$Z<- -log((dat$N-dat$DZ)/dat$N)
    dat$M<-dat$DM/dat$DZ*dat$Z
    dat$M1<-dat$DM1/dat$DZ*dat$Z
    dat$M2<-dat$DM2/dat$DZ*dat$Z
    dat$F<-dat$DF/dat$DZ*dat$Z

    dat$weca<-dat$Cweca/dat$C
    dat[is.na(dat$weca),'weca']<-0
    dat$west<-dat$Nwest/dat$N
   }

  dat$N.bar<-dat$N*(1-exp(-dat$Z))/dat$Z
  dat$C<-NULL
  dat$N_dist<-NULL
  dat$Area<-NULL
  dat1<-subset(dat1,select=c(Species,Year,Quarter,Species.n,Age,M1,M2,M,F,Z,N,N.bar,west,weca,Yield,CWsum,BIO,SSB))
  dat <-subset(dat, select=c(Species,Year,Quarter,Species.n,Age,M1,M2,M,F,Z,N,N.bar,west,weca,Yield,CWsum,BIO,SSB))

  dat<-rbind(dat1,dat)
}
#tapply(dat$Yield,list(dat$Year,dat$Species),sum)

dat<-subset(dat,Year<=last.year )
if (first.year>0) dat<-subset(dat,Year>=first.year )

for (sp in (first.VPA:nsp)){
    sp.name<-sp.names[sp]

    newplot(dev,nox,noy,filename=paste(file.name,'_',sp.name,sep=''),Portrait=Portrait,w8=8,w11=10)
    par(mar=c(3,4,3,2))

    s<-subset(dat,Species.n==sp)
    b<-tapply(s$M2,list(s$Year,s$Age),sum)
    b<-apply(b,2,mean)
    M2<-tapply(s$M2,list(s$Quarter,s$Year,s$Age),sum)
    M2[is.na(M2)]<-0
    for (a in (1:length(b))) {
      if (b[a]>0.001 & a<=noxy) barplot(M2[,,a],space=0.5,xlab='',ylab='',main=paste(sp.name,", Age ",a-1,sep=''),col=c(1,2,3,4))
    }
    if (paper) cleanup()
}

dat$M1M2<-dat$M1+dat$M2
library(mgcv)
b<-aggregate(M1M2~Species.n+Species+Year+Age,sum,data=dat )

  by(b,list(b$Species),function(x) {
    X11()
    print(ggplot(x,aes(Year,M1M2)) +
            theme_bw() +
            geom_point() +
            geom_smooth(method = "gam",formula = y ~ s(x, bs = "cs")) +
            #facet_wrap(~ paste0(Species,' Age:',Age), scale="free_y") +
            facet_wrap(~ paste0(Species,' Age:',Age)) +
            labs(x="Year", y="M=M1+M2",title=""))

  })

  a<-gam(M1M2 ~s(Year,bs='cs'),data=subset(b,Species=='Herring' & Age==1))
  a
  predict(a)

 bb<- by(b,list(b$Species,b$Age),function(x) {
     a<-gam(M1M2 ~s(Year,bs='cs'),data=x)
     return(data.frame(Species=x$Species,Species.n=x$Species.n,Year=x$Year,Age=x$Age,M=predict(a)))
  })

 M<-do.call(rbind,bb)

 tab_annual_sum_data<-function(data,vari='C.obs',outfile,title,decimals=0,tableNo=1,my.species=c(first.VPA:SMS.control@no.species)) {
   if (file.exists(file.path(data.path,outfile))) file.remove(file.path(data.path,outfile))
   for (sp in my.species) {
     a<-subset(data,Species.n==sp)
     if (dim(a)[1] >0) {
       if (vari=='C.obs') tab1<-tapply(a$C.obs,list(a$Year,a$Age),sum)
       if (vari=='F') tab1<-tapply(a$F,list(a$Year,a$Age),sum)
       if (vari=='M2') tab1<-tapply(a$M2,list(a$Year,a$Age),sum)
       if (vari=='M1M2') tab1<-tapply(a$M2+a$M1,list(a$Year,a$Age),sum)
       if (vari=='M') tab1<-tapply(a$M,list(a$Year,a$Age),sum)
       if (vari=='ration') tab1<-tapply(a$ration,list(a$Year,a$Age),sum)
       if (vari=='consum') tab1<-tapply(a$consum,list(a$Year,a$Age),sum)

       if (sum(tab1,na.rm=T)>0) {
         colnames(tab1)<-sort(unique(a$Age))
         xtab(tab1, caption=paste("Table ",tableNo,'  ',sp.names[sp],title),
              cornername='Year/Age',
              file=file.path(data.path,'_tmp.html'), dec=rep(decimals,length(unique(a$Age))), width='"100%"')
         if (length(my.species)==1) {
           file.copy(file.path(data.path,'_tmp.html'), file.path(data.path,outfile), overwrite = T, recursive = FALSE)
         } else file.append(file.path(data.path,outfile), file.path(data.path,'_tmp.html'))
       }
     }
   }
 }

 tab_annual_sum_data(data=M,vari='M',outfile='Msmooth.html',title='Smoothed M',decimals=3)


prep_data_mod_sdss <- function (gdat, nnfits, which.spax=1) {
  i <- which.spax
  z <- gdat$meta$z
  flux <- gdat$flux
  ivar <- gdat$ivar
  lambda.rest <- gdat$lambda/(1 + z)
  logl <- log10(lambda.rest)
  T.gyr <- 10^(ages - 9)
  dT <- diff(c(0, T.gyr))
  lib.ssp$lambda <- airtovac(lib.ssp$lambda)
  lib.st <- regrid(lambda.rest, lib.ssp)
  x.st <- blur.lib(lib.st, nnfits$vdisp.st[i])
  n.st <- ncol(x.st)
  nz <- length(Z)
  nt <- n.st/nz
  ind.young <- (0:(nz - 1)) * nt + 1
  allok <- complete.cases(flux, ivar, x.st)
  lambda <- lambda.rest[allok]
  gflux <- flux[allok]
  x.st <- x.st[allok,]
  wl_ind <- findInterval(c(5375,5625), lambda)
  nl <- length(which(allok))
  norm_g <- mean(pmax(gflux[wl_ind[1]:wl_ind[2]], 0))
  norm_st <- colMeans(x.st[wl_ind[1]:wl_ind[2], ])
  x.st <- scale(x.st, center = FALSE, scale = norm_st)
  x.em <- make_emlib(emlines, nnfits$vdisp.em[i], logl, allok)
  in.em <- x.em$in_em
  x.em <- x.em$x_em
  n.em <- ncol(x.em)
  norm_em <- 1
  list(nt = nt, nz = nz, nl = nl, n_em = n.em, ind_young = ind.young,
    lambda = lambda, gflux = gflux/norm_g,
    g_std = 1/sqrt(ivar[allok])/norm_g, norm_g = norm_g,
    norm_st = norm_st, norm_em = norm_em, sp_st = x.st,
    dT = rep(dT, nz), sp_em = x.em[allok, ], in_em = in.em)
}


library(plyr)
library(RColorBrewer)                   # will use for color-coding
                                        # continent

## data import from local file
gDat <- read.delim("gapminderDataFiveYear.tsv")

## reach out and touch the data
str(gDat) # 'data.frame':  1704 obs. of  6 variables:

## continent-level info
(cDat <- aggregate(country ~ continent, gDat,
                   function(x) length(unique(x))))
(nCont <- nrow(cDat))

## map continent and country into colors

## choose a range of colors for each continent
#display.brewer.all(type = "div")

color_anchors <-
  list(Africa = brewer.pal(n = 11, 'PuOr')[1:5], # orange/brown/gold
       Americas = brewer.pal(n = 11, 'RdYlBu')[1:5],     # red
       Asia = brewer.pal(n = 11, 'PRGn')[1:5],           # purple
       Europe = brewer.pal(n = 11, 'PiYG')[11:7],        # green
       Oceania = brewer.pal(n = 11, 'RdYlBu')[11:10])    # blue

## retain the first or darkest color to represent the whole continent
cDat$color <- laply(color_anchors, "[", 1)

## expand into palettes big enough to cover each country in a
## continent
country_colors <- ddply(gDat, ~ continent, function(x) {
  the_continent <- x$continent[1]
  x <- droplevels(x)
  countriesBigToSmall <-
    with(x, levels(reorder(country, desc(pop), max)))
  colorFun <- colorRampPalette(color_anchors[[the_continent]])
  return(data.frame(country = I(countriesBigToSmall),
                    color = I(colorFun(length(countriesBigToSmall)))))
})

## make a nice figure of my color scheme

## fiddly parameters that control printing of country names
charLimit <- 12
xFudge <- 0.05
jCex <- 0.75

## store figure making code as a function so can make pdf and png
make_figure <- function() {
  plot(c(0, nCont), c(0, 1), type = "n",
       xlab = "", ylab="", xaxt = "n", yaxt = "n", bty = "n",
       main = "Gapminder Color Scheme")
  for(i in seq_len(nCont)) {
    thisCont <- cDat$continent[i]
    nCols <- with(cDat, country[continent == thisCont])
    yFudge <- 0.1/nCols
    foo <- seq(from = 0, to = 1, length = nCols + 1)
    rect(xleft = i - 1,
         ybottom = foo[-(nCols + 1)],
         xright = i,
         ytop = foo[-1],
         col = with(country_colors, color[continent == thisCont]))
    text(x = i - 1 + xFudge,
         y = foo[-(nCols + 1)] + yFudge,
         labels = with(country_colors,
                       substr(country[continent == thisCont], 1, charLimit)),
         adj = c(0, 0), cex = jCex)
  }
  mtext(cDat$continent, side = 3, at = seq_len(nCont) - 0.5)
  mtext(c("smallest\npop", "largest\npop"),
        side = 2, at = c(0.9, 0.1), las = 1)
}

op <- par(mar = c(1, 4, 6, 1) + 0.1)
make_figure()
par(op)

png("gapminder-country-colors.png",
    width = 7, height = 10, units = "in", res = 200)
op <- par(mar = c(1, 4, 6, 1) + 0.1)
make_figure()
dev.off()
par(op)

pdf("gapminder-country-colors.pdf",
    width = 7, height = 10)
op <- par(mar = c(1, 4, 6, 1) + 0.1)
make_figure()
dev.off()
par(op)

write.table(country_colors, "gapminder-country-colors.tsv",
            quote = FALSE, sep = "\t", row.names = FALSE)

write.table(cDat, "gapminder-continent-colors.tsv",
            quote = FALSE, sep = "\t", row.names = FALSE)


#Load package
suppressMessages(library(qvalue))

#Read command line arguments
args <- commandArgs(trailingOnly = TRUE)
try(if(length(args) != 1) stop("Incorrect number of arguments, usage> Rscript pi1.R INPUT"))
opt_input  = args[1];

 #caucalate pi1
a<-read.table(opt_input)
library(qvalue)
pi0<-pi0est(a$V1,lambda=seq(0.1,0.9,0.1),method="smoother")
print(1-pi0$pi0)


# I arranged the working directory into "input" (all input files went here)
# and "output" - for submission files.

# For completeness I will past all the code in this one file. This includes:
# 1. Reading Data
# 2. Preparing Data
# 3. Building the Model.
# 4. Wrigin Submission File.

###############################################################################
################################### SOURCES ###################################
###############################################################################

setwd("~/GitHub/Data/mlsp-2014-mri")
getwd()
data_txt = read.csv("breadwrapper.txt")
data = read.csv("bf_study.csv")
data
# Used libraries

library(verification)
library(DWD)

###############################################################################
################################## LOAD DATA ##################################
###############################################################################

trainFNC = read.csv(file='Train/train_FNC.csv', head=TRUE, sep=",")
trainSBM = read.csv(file='Train/train_SBM.csv', head=TRUE, sep=",")
trainLAB = read.csv(file='Train/train_labels.csv', head=TRUE, sep=",")

testFNC = read.csv(file='Test/test_FNC.csv', head=TRUE, sep=",")
testSBM = read.csv(file='Test/test_SBM.csv', head=TRUE, sep=",")

# myExample <- read.csv(file.path(projectTree, "input/submission_example.csv"), as.is=T, header=T, sep=",")

###############################################################################
################################## PREP DATA ##################################
###############################################################################

myTrain = rbind(t(trainFNC[,-1]), t(trainSBM[,-1]))
colnames(myTrain) = trainLAB$Class

myTest = rbind(t(testFNC[,-1]), t(testSBM[,-1]))
colnames(myTest) = testFNC$Id

###############################################################################
############################## CROSS-VALIDATION ###############################
###############################################################################

# This part is optional and was used to select the values of C constraint.

# (This runs 100 itterations of 10-fold cross validation

ROCS = list()

Cs = c(1, 5, 10, 50, 100, 300, 500, 1000)

for(Cind in 1:length(Cs)) {
  C = Cs[Cind]
  tmpRocs = numeric()
  for(i in 1:100) {
    trainInds1 = sample(which(colnames(myTrain)==0), 42)
    trainInds2 = sample(which(colnames(myTrain)==1), 36)
    trainInds = c(trainInds1, trainInds2)
    theTrain = myTrain[,trainInds]
    theTest = myTrain[,-trainInds]

    myFit = kdwd(t(myTrain), colnames(myTrain), C=C)
    testScores = t(myFit@w[[1]]) %*% theTest
    testScores = 1 - ((testScores - min(testScores)) / max(testScores - min(testScores)))

    tmpRocs[i] = roc.area(as.numeric(colnames(theTest)), testScores)$A

    print(i)
  }
  ROCS[[Cind]] = tmpRocs
}

###############################################################################
################################## FIT MODEL ##################################
###############################################################################

myFit = kdwd(t(myTrain), colnames(myTrain), C=300)

# Get scores for training data (meaningless for now).

scores = t(myFit@w[[1]]) %*% myTrain
scores = 1 - ((scores - min(scores)) / max(scores - min(scores)))

# Check ROC area. (meaningless, because of possible overfitting)

roc.area(as.numeric(colnames(myTrain)), scores)

###############################################################################
################################ WRITE SCORES #################################
###############################################################################

testScores = t(myFit@w[[1]]) %*% myTest
testScores = 1 - ((testScores - min(testScores)) / max(testScores - min(testScores)))

myExample$Probability = as.numeric(testScores)

write.csv(myExample, file=file.path(projectTree, "output/submission.csv"), row.names=F)


library(Seurat)
library(tmod)

fn = "data/H1_day0_scranNorm_adtbatchNorm_dist_clustered_TSNE_labels.rds"
h1 = readRDS(fn)

bg = h1@data %>% rownames()

genes = readRDS("sig/sig.list.RDS")$CD40.act

res = tmodHGtest(genes, bg, mset="LI")
df = res %>%
  dplyr::mutate(label = glue::glue("{ID} - {Title}") %>% fct_inorder() %>% fct_rev())

ggplot(df, aes(label, -log10(adj.P.Val))) +
  geom_col() +
  geom_hline(yintercept = -log10(0.05), col="red", lty=2) +
  xlab("") +
  ylab("adjusted p-value, -log10") +
  coord_flip() +
  theme_classic()

dn.fig = "figures/CD40act"
dir.create(dn.fig, showWarnings = F, recursive = T)

ggsave(file.path(dn.fig, "CD40act_genes_HG.test_p.adj_barplot.png"), w=8, h=4)
ggsave(file.path(dn.fig, "CD40act_genes_HG.test_p.adj_barplot.pdf"), w=8, h=4)


"
Fit Nicolas's model to the Colombia data.
"
library(RJSONIO)
source("contagious_infected/model.r")
source("visualization.r")

params = list(
  "alpha" = 2 ^ 40,
  "beta_min" = 0,
  "beta_max" = 2,
  "gamma_min" = 1/3,
  "gamma_max" = 1/3,
  "lambda_min" = 1/40,
  "lambda_max" = 1/4,
  "N0_min" = 0,
  "N0_max" = 2000,
  "C0_min" = 0,
  "C0_max" = 2000,
  "t0" = 1
)
bootstrap_params = list(
  "number_samples" = 500,
  "window_size" = 10,
  "confidence" = 0.95
)
# load data and initialize parameters
load("CasosAjustados_Diagnostico.Rda")
observed_I = data$`Estimados Totales`
observed_I = c(observed_I[1], 0, tail(observed_I, -1))
observed_I = observed_I[params$t0:length(observed_I)]
for (i in 1:100) {
  # params$beta0 = read.table("BetaInitials.txt", quote="\"", comment.char="")$V1
  params$beta0 = runif(length(observed_I), params$beta_min, params$beta_max)
  params$gamma0 = runif(1, params$gamma_min, params$gamma_max)
  params$lambda0 = runif(1, params$lambda_min, params$lambda_max)
  params$N00 = runif(1, params$N0_min, params$N0_max)
  params$C00 = runif(1, params$C0_min, params$C0_max)
  params$observed_I = observed_I
  # fit Nicolas's model
  model = fit(observed_I=observed_I, beta0=params$beta0, beta_min=params$beta_min,
              beta_max=params$beta_max, gamma0=params$gamma0,
              gamma_min=params$gamma_min, gamma_max=params$gamma_max,
              lambda0=params$lambda0, lambda_min=params$lambda_min,
              lambda_max=params$lambda_max, N00=params$N00, N0_min=params$N0_min,
              N0_max=params$N0_max, C00=params$C00, C0_min=params$C0_min,
              C0_max=params$C0_max, alpha=params$alpha, ignore_beta_diff=27)
  # save fitted model and parameters
  timestamp = format(Sys.time(), "%Y%m%d%H%M")
  out_dir = paste("contagious_infected", "tuned", timestamp, sep="/")
  dir.create(out_dir, recursive=TRUE)
  write(toJSON(params), paste(out_dir, "params.json", sep="/"))
  write(toJSON(model), paste(out_dir, "model.json", sep="/"))
  # plot reproduction number series
  R = model$beta / model$lambda
  png(paste(out_dir, "R(t).png", sep="/"))
  plot(R, xlab="t", ylab="R(t)", type="l")
  dev.off()
  # plot expected new cases with confidence intervals
  expected_I = get_expected_I(model$N0, model$C0, model$beta, model$gamma, model$lambda)
  png(paste(out_dir, "I(t).png", sep="/"))
  plot(1:length(expected_I), expected_I, type="l")
  lines(1:length(observed_I), observed_I, col="red")
  dev.off()
}


# get the clean RNA-seq table
source("code/setup.r")

## THIS IS THE REFERENCE SET
####
# Need to add in edgeR for comparison with Barton group paper
# also, ALDEx2 has essentially no FP, just FN
# while point estimate methods have both
# edgeR
library(edgeR)

 group <- factor(c(rep("C", length(WT.g$good)), rep("E", length(SNF.g$good))) )
 y <- DGEList(counts=d.good,group=group)
 y <- calcNormFactors(y)
 design <- model.matrix(~group)
 y <- estimateDisp(y,design)
 fit <- glmQLFit(y,design)
 qlf <- glmQLFTest(fit,coef=2)
 sum.tags <- data.frame(topTags(qlf, n=nrow(d.good)))
 ref.set.edgeR <- rownames(sum.tags[sum.tags$FDR < 0.05,])

 save(ref.set.edgeR, file="data/ref.set.edgeR.RData")

et.ref <- exactTest(y)
ref.set.edgeR.et <- data.frame(topTags(et.ref, n=nrow(d.good)))
save(ref.set.edgeR.et, file="data/ref.set.edgeR.et.RData")

## THIS IS THE TEST SET
test.set.edgeR <- lapply(test.set.edgeR <- vector(mode = 'list',40), function(x) x <- vector(mode='list',100))
test.set.edgeR.et <- lapply(test.set.edgeR.et <- vector(mode = 'list',40), function(x) x <- vector(mode='list',100))

### add in exactTest for comparison with Schurch
for(i in 2:40){

    for(j in 1:100){

    d.sample <- cbind(d.good[,sample( WT.g$good, i)], d.good[,sample( SNF.g$good, i)])
    group.i <- factor(c(rep("C", i), rep("E", i)))

    y <- DGEList(counts=d.sample,group=group.i)
    y <- calcNormFactors(y)
    design <- model.matrix(~group.i)
    y <- estimateDisp(y,design)
    fit <- glmQLFit(y,design)
    qlf <- glmQLFTest(fit,coef=2)
    sum.tags <- data.frame(topTags(qlf, n=nrow(d.good)))
    test.set.edgeR[[i]][[j]] <- rownames(sum.tags[sum.tags$FDR < 0.05,])
    et <- exactTest(y)
    sum.tags.et <- data.frame(topTags(et, n=nrow(d.good)))
    test.set.edgeR.et[[i]][[j]] <- rownames(sum.tags.et[sum.tags.et$FDR < 0.05,])
    }
    save(test.set.edgeR.et, file="data/test.set.edgeR.et.Rdata")
    save(test.set.edgeR, file="data/test.set.edgeR.Rdata")
}


R version 4.1.1 (2021-08-10) -- "Kick Things"
Copyright (C) 2021 The R Foundation for Statistical Computing
Platform: x86_64-apple-darwin17.0 (64-bit)

R is free software and comes with ABSOLUTELY NO WARRANTY.
You are welcome to redistribute it under certain conditions.
Type 'license()' or 'licence()' for distribution details.

  Natural language support but running in an English locale

R is a collaborative project with many contributors.
Type 'contributors()' for more information and
'citation()' on how to cite R or R packages in publications.

Type 'demo()' for some demos, 'help()' for on-line help, or
'help.start()' for an HTML browser interface to help.
Type 'q()' to quit R.

[R.app GUI 1.77 (7985) x86_64-apple-darwin17.0]

[Workspace restored from /Users/salmaabusamrah/.RData]
[History restored from /Users/salmaabusamrah/.Rapp.history]

> install.packages("rio")
--- Please select a CRAN mirror for use in this session ---
trying URL 'https://mirror.las.iastate.edu/CRAN/bin/macosx/contrib/4.1/rio_0.5.27.tgz'
Content type 'application/x-gzip' length 533163 bytes (520 KB)
==================================================
downloaded 520 KB

The downloaded binary packages are in
	/var/folders/ns/4vw4qg350f76xc84clgnpqhh0000gn/T//Rtmpnnxcug/downloaded_packages
> library(rio)
The following rio suggested packages are not installed: ‘arrow’, ‘feather’, ‘fst’, ‘hexView’, ‘jsonlite’, ‘pzfx’, ‘readODS’, ‘rmarkdown’, ‘rmatio’, ‘xml2’, ‘yaml’
Use 'install_formats()' to install them
> data_name<-import(file="Hookup Culture Final Data 2.9.21.sav")
> hookup<-import(file="Hookup Culture Final Data 2.9.21.sav")
> install.packages("dplyr")
trying URL 'https://mirror.las.iastate.edu/CRAN/bin/macosx/contrib/4.1/dplyr_1.0.7.tgz'
Content type 'application/x-gzip' length 1263555 bytes (1.2 MB)
==================================================
downloaded 1.2 MB

The downloaded binary packages are in
	/var/folders/ns/4vw4qg350f76xc84clgnpqhh0000gn/T//Rtmpnnxcug/downloaded_packages
> library("dplyr")

Attaching package: ‘dplyr’

The following objects are masked from ‘package:stats’:

    filter, lag

The following objects are masked from ‘package:base’:

    intersect, setdiff, setequal, union

> hookup<-subset(hookup, select=-AttendService)
> ##code above removed people who attend services
> table(hookup$Year)

 1  2  3  4
37 27 21 34
> ##code above shows frequencies for "year"
> hist(hookup$HCTotal)
> ##code above creates a histogram of hctotal
> hctotal.test<-t.test(x=hookup$hctotal,mu=0)
> hctotal.test

	One Sample t-test

data:  hookup$hctotal
t = 34.511, df = 114, p-value < 2.2e-16
alternative hypothesis: true mean is not equal to 0
95 percent confidence interval:
 48.63809 54.56191
sample estimates:
mean of x
     51.6

> ##level 4


# load packages needed to run this code
library(generativeart)
library(ggplot2)
library(tidyr)
library(dplyr)
library(gganimate)

# set different formulas that will be used in the animation
set.seed(6288)

# include a specific formula, for example:
my_formula <- list(
  x = quote(runif(1, -1, 1) * x_i^2 - sin(y_i^2)),
  y = quote(runif(1, -1, 1) * y_i^2 - cos(x_i^2))
)

# making a data frame with the visualization
df <- generate_data(my_formula)

# make different states
df %>% select(x, y) %>%
  mutate(state = 1) -> df_t1

# make a file name
file_name <- generate_filename(seed)

# make an animation
df_animate %>%
  group_by(state) %>%
  ggplot(ggplot2::aes(x = x, y = y)) +
  scale_fill_identity() +
  geom_point(alpha = 0.2, size = 0, shape = 20) +
  theme_void() +
  coord_fixed(expand = FALSE) +
  transition_states(state, transition_length = 5, state_length = 0) -> p_genart

# animate
animate(p_genart,
        device = "png",
        width = 600,
        height = 600)

# save as gif
anim_save("generativeart.gif")


library(rrBLUP)
set.seed(42)
args = commandArgs(trailingOnly=TRUE)
X_file <- args[1]
Y_file <- args[2]
feat_file <- args[3]
trait <- args[4]
save_name <- args[5]

Y <- read.csv(Y_file, row.names=1)
X <- read.csv(X_file, row.names=1)
# make X and Y have the same order of rows
X <- X[rownames(Y),]
cvs <- read.csv('CVFs.csv', row.names=1)
# Make the relationship matrix from the markers
M=tcrossprod(scale(X))  # centered and scaled XX'
M=M/mean(diag(M))
rownames(M) <- 1:nrow(X)

# Subset X if feat_file is not all
if (feat_file != 'all'){
  print('Pulling features to use...')
  FEAT <- scan(feat_file, what='character')
  X <- X[FEAT]
  feat_method <- tail(unlist(strsplit(feat_file, '/')), n=1)
}

if (trait == 'all') {
  print('Modeling all traits')
} else {
  Y <- Y[trait]
}

R2 <- c()
for(i in 1:length(Y)){
	print(names(Y)[i])
	Accuracy <- c()
	Coef <- c()
	for(k in 1:10){
		print(k)
		tst = cvs[,k]
		Coeff <- c()
		yhat <- data.frame(cbind(Y, yhat = 0))
		yhat$yhat <- as.numeric(yhat$yhat)
		row.names(yhat) <- row.names(Y)
		for(j in 1:5){
			validation <- which(tst==j)
			training <- which(tst!=j)
			yNA <- Y[,i]
			yNA[validation] <- NA # Mask yields for validation set
			# Build rrBLUP model and save yhat for the masked values
			#rrblup <- kin.blup(df,K=M,geno="gid",pheno='y') #optional parameters: fixed effects, gaussian kernel, covariates
			# predict marker effects
			coeff <- mixed.solve(y=Y[training,i], Z=X[training,], K=NULL, method='ML', SE=FALSE, return.Hinv=FALSE)
			Coeff <- rbind(Coeff,coeff$u)
			# predict breeding
			rrblup <- mixed.solve(y=yNA, K=A.mat(X))
			yhat$yhat[validation] <- rrblup$u[validation]
			}
		accuracy <- cor(yhat[,i], yhat$yhat)
		Accuracy <- c(Accuracy,accuracy^2)
		Coef <- rbind(Coef,colMeans(Coeff))
		}
	R2 <- cbind(R2,Accuracy)
	write.csv(Coef,paste('Coef_',save_name,'_',names(Y)[i],'.csv',sep=''),row.names=F,quote=F)
	}
colnames(R2) <- names(Y)
write.csv(R2,paste('R2_results_',save_name,'.csv',sep=''),row.names=F,quote=F)


library(tidyverse)
library(readxl)
library(mosaic)
library(lme4)
library(RItools)
library(texreg)

dat <- read_excel('data/ASSISTment_merge_2021_04_12_N=1,587_ver.02.xlsx')

dat$student_number <- gsub(".0","",dat$student_number,fixed=TRUE)

dat <- dat[order(dat$student_number),]

### are students unique? what are their IDs?
## nrow(dat)
## sum(is.na(dat$student_number))
## n_distinct(dat$student_number)
## n_distinct(dat$student_id.x)
## all good

### look at random assignment
table(dat$initial_CONDITION)
table(dat$condition_updated)
xtabs(~initial_CONDITION+condition_updated,data=dat) ## same thing

n_distinct(dat$initial_school_id)
xtabs(~initial_school_id+initial_CONDITION,data=dat)
xtabs(~KEEP+condition_updated,data=dat,addNA=TRUE)  ## I only have KEEP rows. should I have all rows?

n_distinct(dat$initial_teacher)
xtabs(~initial_teacher+condition_updated,data=dat,addNA=TRUE)
xtabs(~initial_SectionNumber+condition_updated,data=dat,addNA=TRUE)
xtabs(~movement+condition_updated,data=dat,addNA=TRUE)%>%addmargins()

n_distinct(dat$initial_teacher_class)

xtabs(~initial_teacher_class+condition_updated,data=dat)

xtabs(~initial_teacher_class+condition_updated,data=dat[!is.na(dat$mid.total_math_score),])

dat%>%
    mutate(itc=as.factor(initial_teacher_class))%>%
    filter(!is.na(mid.total_math_score))%>%
    group_by(itc,.drop=FALSE)%>%
    summarize(n=n(),bothDrop=n()==0,oneDrop=!bothDrop&(sum(condition_updated=='Instant')==0|sum(condition_updated=='Delay')==0))%>%
    ungroup()%>%
    summarize(sum(bothDrop),sum(oneDrop),sum(n[oneDrop]))

dat%>%
    mutate(itc=as.factor(initial_teacher_class))%>%
    filter(!is.na(mid.total_math_score),!is.na(pre.total_math_score))%>%
    group_by(itc,.drop=FALSE)%>%
    summarize(n=n(),bothDrop=n()==0,oneDrop=!bothDrop&(sum(condition_updated=='Instant')==0|sum(condition_updated=='Delay')==0))%>%
    ungroup()%>%
    summarize(sum(bothDrop),sum(oneDrop),sum(n[oneDrop]))

## are section numbers nested w/i teachers?
dat%>%group_by(initial_SectionNumber)%>%summarize(nt=n_distinct(initial_teacher))%>%xtabs(~nt,data=.)
## no!

dat%>%group_by(initial_teacher_class)%>%summarize(nt=n_distinct(initial_teacher))%>%xtabs(~nt,data=.)
dat%>%group_by(initial_teacher_class)%>%summarize(nt=n_distinct(initial_SectionNumber))%>%xtabs(~nt,data=.)

## are teachers nested w/i section numbers?
dat%>%group_by(initial_teacher)%>%summarize(nt=n_distinct(initial_SectionNumber))%>%xtabs(~nt,data=.)
## no!

## are section numbers nested w/i schools?
dat%>%group_by(initial_SectionNumber)%>%summarize(nt=n_distinct(initial_school_id))%>%xtabs(~nt,data=.)
## mostly...

## are teachers nested w/i schools?
dat%>%group_by(initial_teacher)%>%summarize(nt=n_distinct(initial_school_id))%>%xtabs(~nt,data=.)
## partly

### missigness on mid test
sum(is.na(dat$mid.total_math_score))

tally(is.na(mid.total_math_score)~condition_updated,data=dat,format="percent")

### test covariate balance between responders and non-responders
dat$midMis <- is.na(dat$mid.total_math_score)
balMid <- xBalance(midMis~ScaleScore+PerformanceLevel+EIP+ESOL+IEP+FEMALE+GIFTED+student_hispanicEthnicity+student_raceEthnicityFed,data=dat,
                   report='all')

tally(is.na(mid.total_math_score)~is.na(pre.total_math_score),data=dat,format="percent")

mean(is.na(dat$pre.total_math_score))

mean(is.na(dat$mid.total_math_score[!is.na(dat$pre.total_math_score)]))

tally(midMis~condition_updated,data=filter(dat,!is.na(pre.total_math_score)),format="percent")

summary(glm(midMis~condition_updated*scale(pre.total_math_score),data=dat,family=binomial(probit)))
summary(glm(midMis~condition_updated*ScaleScore,data=dat,family=binomial(probit)))

mean(dat$midMis)
mean(dat$midMis[dat$condition_updated=='Instant'])-mean(dat$midMis[dat$condition_updated!='Instant'])
### meets optimistic WWC standard

### treatment effect estimates for mid test
library(estimatr)

mod1 <- lm_robust(mid.total_math_score~condition_updated,data=dat)
mod2 <- lm_robust(mid.total_math_score~condition_updated,data=dat,fixed_effects=~initial_SectionNumber)
mod4 <- lm_robust(mid.total_math_score~condition_updated+pre.total_math_score,data=dat,fixed_effects=~initial_SectionNumber)
mod6 <- lm_robust(mid.total_math_score~condition_updated+pre.total_math_score+ScaleScore+EIP+ESOL+IEP+FEMALE+GIFTED+race,data=dat,fixed_effects=~initial_SectionNumber)

mod5a <- lm(mid.total_math_score~condition_updated+pre.total_math_score+ScaleScore+EIP+ESOL+IEP+FEMALE+GIFTED+raceLump,data=dat)
plot(mod5a)
summary(mod5a)

loopDat <- dat%>%filter(!is.na(mid.total_math_score))%>%
    transmute(Y=mid.total_math_score,
              Tr=ifelse(condition_updated=='Instant',1,0),
              across(c(pre.total_math_score,ScaleScore,EIP,ESOL,IEP,FEMALE,GIFTED),list(imp=~ifelse(is.na(.),median(.,na.rm=TRUE),.),mis=~is.na(.)))
              )

LOOP <- loop.estimator::loop(loopDat$Y,loopDat$Tr,as.matrix(loopDat[,-c(1:2)]))

plot(table(dat$mid.total_math_score))

ggplot(dat,aes(mid.total_math_score))+geom_histogram(bins=10)+facet_wrap(~condition_updated,ncol=1)

ggplot(dat,aes(mid.total_math_score))+geom_bar()+facet_wrap(~condition_updated,ncol=1)+scale_x_continuous(breaks=0:10)

dat%>%group_by(condition_updated)%>%mutate(nt=sum(!is.na(mid.total_math_score)))%>%group_by(condition_updated,mid.total_math_score)%>%summarize(percent=n()/nt)%>%ggplot(aes(mid.total_math_score,percent,color=condition_updated,group=condition_updated))+geom_point()+geom_line()+scale_x_continuous(breaks=0:10)+scale_y_continuous(labels=scales::percent,limits=c(0,.15))

dat%>%group_by(condition_updated,mid.total_math_score)%>%summarize(n=n())%>%ggplot(aes(mid.total_math_score,n,color=condition_updated,group=condition_updated))+geom_point()+geom_line()+scale_x_continuous(breaks=0:10,minor_breaks=NULL)+scale_y_continuous(breaks=seq(0,60,10),minor_breaks=seq(0,60,5),limits=c(0,60))

wilcox.test(mid.total_math_score~condition_updated,data=dat)


library(dplyr)
library(readr)
library(ggplot2)
library(readr)
library(stringr)
library(assertive)

dataset <- read_csv("https://raw.githubusercontent.com/sit-2021-int214/022_Bestselling_books/main/Group_mid/bestsellers_with_categories.csv")
#0
datasetcle <- dataset %>% filter(Year >= 2015 && Year <= 2019)
datasetcle$Price_baht <- datasetcle$Price*33.37
#1.Data Transformation with dplyr
#1.1 Rename
datasetcle <- datasetcle %>% rename(Book_Name=Name)
datasetcle <- datasetcle %>% rename(Rating=`User Rating`)
datasetcle <- datasetcle %>% rename(Fiction=Genre)
#1.2 Mutate and Transmute
glimpse(datasetcle)
#1.3 Drop column
datasetcle <- datasetcle %>% select(Book_Name,Author,Rating,Reviews,Price_baht,Fiction)

# plot graph
datasetcle %>% ggplot(aes(x=Rating))+ geom_bar()
# 3.Checking the types of values
is.character(datasetcle$Book_Name)
is.character(datasetcle$Author)
is.numeric(datasetcle$Rating)
is.integer(datasetcle$Reviews)
is.numeric(datasetcle$Price_baht)
is.factor(datasetcle$Fiction)

# 4.Changing the types of values
datasetcle$Reviews <- as.integer(dataset$Reviews)
datasetcle$Fiction <- as.factor(datasetcle$Fiction)

# 5. Handling String with stringr

# 6. Removing duplicate data
datasetcle %>% duplicated() %>% table()
datasetcle %>% duplicated() %>% sum()
datasetcle %>% filter(duplicated(datasetcle))
datasetcle <-
  datasetcle %>% distinct()
# 7. Handling missing data and outliers
#7.1. Missing Data
is.na(datasetcle)
#7.2. Outliers data & Range Values

write.csv(dataset, file = "D:/Project214/bestsellers_with_categories_clearing.csv")


# Basic scatterplot
library(ggvis)

set.seed(1014)
df <- data.frame(x = 1:5, y = 5:1, z = runif(5))

df %>%
  ggvis(x = ~x, y = ~x) %>%
  layer_points() %>%
  save_spec("scatter/basic.json")

df %>%
  ggvis(x = ~factor(x), y = ~x / y) %>%
  layer_points() %>%
  save_spec("scatter/transform.json")

df %>%
  ggvis(x = ~x, y = ~y, fill = ~z) %>%
  layer_points() %>%
  save_spec("scatter/fill-continuous.json")

df %>%
  ggvis(x = ~x, y = ~y, fill = ~factor(z)) %>%
  layer_points() %>%
  save_spec("scatter/fill-discrete.json")


library(dplyr)
library(ggplot2)

## import data
phate <- read.csv("results/phate.csv", header = FALSE)
cell_labels <- read.delim("data/tasic_labels.tsv", header = FALSE)
dim(phate); dim(cell_labels)

## plot
p <- phate %>%
  mutate(cell_labels = cell_labels$V1) %>%
  ggplot(aes(x = V1, y = V2, color = cell_labels)) +
  geom_point() +
  theme_classic() +
  xlab("Dim 1") +
  ylab("Dim 2")

ggsave("results/phate_plot.png", p)


################################################################################
# The contents of this file are Teradata Public Content
# and have been released to the Public Domain.
# Licensed under BSD; see "license.txt" file for more information.
# Copyright (c) 2021 by Teradata
################################################################################
#
# R And Python Analytics with SCRIPT Table Operator
# Orange Book supplementary material
# Alexander Kolovos - August 2021 - v.2.1
#
# Example 1: Scoring (R version)
# File     : ex1rFit.r
#
# Note: Present script is meant to be run on a client machine
#
# Fit a Ranfom Forests model to a given dataset. Export model information
# to an R model object to score data in a target SQL Engine database.
# Use case:
# Predict the propensity of a financial services customer base
# to open a credit card account.
#
# The present file creates the R model object for prediction, and saves it
# into "ex1rMod.rds". This task is assumed to take place on a client machine
# where the present script and the data file with the fitting data reside.
# Execute this script in advance of using the scoring script "ex1rSco.r"
# in the database.
#
# Requires the randomForest add-on package.
#
# Required input:
# - model fitting data from the file "ex1dataFit.csv"
#
# Output:
# - R model file "ex1rMod.rds". To be imported in the database together
#   with the scoring R script.
#
################################################################################

# Load dependency package
library(randomForest)

# Import the fitting data from CSV file
cv <- c("numeric", "numeric", "numeric", "numeric", "numeric", "numeric",
        "numeric", "numeric", "numeric", "numeric", "numeric", "numeric",
        "numeric", "numeric", "numeric", "numeric", "numeric", "numeric",
        "numeric", "numeric", "numeric", "numeric", "numeric", "numeric",
        "numeric", "numeric", "numeric", "numeric")
trainDataDF <- try( read.table("ex1dataFit.csv", sep=",", flush=TRUE,
                    header=TRUE, quote="", na.strings="", colClasses=cv) )

# Change the class of the dependent variable to a factor to indicate to
# randomForest that we want to built a classification tree.
trainDataDF$cc_acct_ind = as.factor(trainDataDF$cc_acct_ind)

# For the classifier, specify the following parameters:
# ntree=10, mtry=3, and nodesize=1
RFmodel <- randomForest(formula = (cc_acct_ind ~
                                   tot_income + tot_age + tot_cust_years +
                                   tot_children + female_ind + single_ind +
                                   married_ind + separated_ind +
                                   ca_resident_ind + ny_resident_ind +
                                   tx_resident_ind + il_resident_ind +
                                   az_resident_ind + oh_resident_ind +
                                   ck_acct_ind + sv_acct_ind + ck_avg_bal +
                                   sv_avg_bal + ck_avg_tran_amt +
                                   sv_avg_tran_amt + q1_trans_cnt +
                                   q2_trans_cnt + q3_trans_cnt + q4_trans_cnt),
                         data = trainDataDF,
                         ntree = 10,
                         nodesize = 1,
                         mtry = 3)

RFmodel

# Export the Random Forest model into a file
saveRDS(RFmodel, "ex1rMod.rds")


include	defs

# wkday --- get day-of-week corresponding to month,day,year

   integer function wkday (month, day, year)
   integer month, day, year

   integer lmonth, lday, lyear

   lmonth = month - 2
   lday = day
   lyear = year

   if (lmonth <= 0) {
      lmonth = lmonth + 12
      lyear = lyear - 1
      }

   wkday = mod (lday + (26 * lmonth - 2) / 10 + lyear + lyear / 4 - 34,
       7) + 1

   return
   end


library(shiny)	#First load shiny library
load("../pcas.RDATA")	#Load data

#Define the overall UI
shinyUI(
	#Use a fluid Bootstrap layout
	fluidPage(
		#Give the page a title
		titlePanel("PCA of Metrics"),
		#Define page with a sidebar panel and main panel
		sidebarLayout(
			#Sidebar Panel
			sidebarPanel(
				#Create drop-down menu to select Variable to plot PCA for
				selectInput(inputId='var', label = h3('Variable'),
					choices = c(
						"Colless" = "colless",
						"Species Pool Size" = "numsp",
						"Spatially Contiguous" = "spatial"
						)
					),
				#Check box group, contingent upon previous drop-down menu selection
				uiOutput(outputId="paramchkbxgrp"),
				#Create a slider that will adjust the cex value of the text displayed called "cexSlider".
				sliderInput(inputId = "cexSlider", label=h4("Adjust cex"),
				min = 0, max=5, value=1),
				uiOutput(outputId="sliderX"),
				uiOutput(outputId="sliderY")
			),
			#Create a spot for the plot
			mainPanel(
				 plotOutput(outputId="pcaplot",  width="500px",height="500px")
			)
		)

    )
)


#' make_pen: automatically assigns a penalties.
#' 'make_pen' calls one of four available penalty functions to automatically
#' assign penalties for the dynamic programming.
#' The two functions to be called are:
#' 1. fragment_HL_pen
#' 2. fragment_inty_pen
#' These functions return the amount of statistically correct and statistically
#' wrong splits at a specific pair of penalties.
#' 'make_pen' iterates over many penalty pairs and picks the most suitable pair
#' based on the difference between wrong and correct splits.
#' The sample size, penalty range and resolution as well as the number of cycles
#' can be customized.
#' The primary start parameters create a matrix with n = rez_pen rows and
#' n = rez_pen_out columns with values between sta_pen/sta_pen_out
#' and end_pen/end_pen_out. The best penalty pair is picked. If dept is bigger
#' than 1 the same process is repeated with a new matrix of the same size
#' based on the result of the previous cycle. Only position segments with length
#' within the sample size range are considered for the penalties to increase
#' run time.
#' Returns a penalty object including the logbook.
#'
#' @param probe data frame: the probe based data frame.
#' @param FUN function: one of the four bottom level functions (see details)
#' @param cores integer: the number of assigned cores for the task
#' @param logs numeric vector: the logbook vector.
#' @param dpt integer: the number of times a full iteration cycle is repeated
#' with a more narrow range based on the previous cycle. Default is 2.
#' @param smpl_min integer: the smaller end of the sampling size. Default is 10.
#' @param smpl_max integer: the larger end of the sampling size. Default is 100.
#' @param sta_pen numeric: the lower starting penalty. Default is 0.5.
#' @param end_pen numeric: the higher starting penalty. Default is 4.5.
#' @param rez_pen numeric: the number of penalties iterated within the penalty
#' range. Default is 9.
#' @param sta_pen_out numeric: the lower starting outlier penalty. Default is
#' 0.5.
#' @param end_pen_out numeric: the higher starting outlier penalty. Default is
#' 3.5.
#' @param rez_pen_out numeric: the number of outlier penalties iterated within
#' the outlier penalty range. Default is 7.
#'
#' @return A list with 4 items:
#'     \describe{
#'       \item{logbook:}{The logbook vector containing all penalty information}
#'       \item{penalties:}{a vetor with the respective penalty and outlier
#'       penalty}
#'       \item{correct:}{a matrix of the correct splits}
#'       \item{wrong:}{a matrix of the incorrect splits}
#'     }
#'
#' @examples
#' data(df_comb_minimal)
#' make_pen(
#'   probe = df_comb_minimal, FUN = rifi_comparative_data:::fragment_HL_pen,
#'   cores = 2, logs = as.numeric(rep(NA, 8)), dpt = 1, smpl_min = 10,
#'   smpl_max = 50, sta_pen = 0.5, end_pen = 4.5, rez_pen = 9, sta_pen_out = 0.5,
#'   end_pen_out = 3.5, rez_pen_out = 7
#' )
#'
#' @export

make_pen <- function(probe,
                     FUN,
                     cores = 1,
                     logs,
                     dpt = 1,
                     smpl_min = 10,
                     smpl_max = 100,
                     sta_pen = 0.5,
                     end_pen = 4.5,
                     rez_pen = 9,
                     sta_pen_out = 0.5,
                     end_pen_out = 3.5,
                     rez_pen_out = 7) {
  num_args <-
    list(
      cores,
      dpt,
      smpl_min,
      smpl_max,
      sta_pen,
      end_pen,
      rez_pen,
      sta_pen_out,
      end_pen_out,
      rez_pen_out
    )
  names(num_args) <-
    c(
      "cores",
      "dpt",
      "smpl_min",
      "smpl_max",
      "sta_pen",
      "end_pen",
      "rez_pen",
      "sta_pen_out",
      "end_pen_out",
      "rez_pen_out"
    )
  res2 <- vector("list", dpt)
  res3 <- vector("list", dpt)
  step_pen <- (end_pen - sta_pen) / (rez_pen - 1)
  step_pen_out <- (end_pen_out - sta_pen_out) / (rez_pen_out - 1)
  pen <- seq(sta_pen, end_pen, step_pen)
  pen_out <- seq(sta_pen_out, end_pen_out, step_pen_out)
  for (i in seq_len(dpt)) {
    correct <- matrix(, length(pen), length(pen_out))
    wrong <- matrix(, length(pen), length(pen_out))
    rownames(correct) <- pen
    colnames(correct) <- pen_out
    rownames(wrong) <- pen
    colnames(wrong) <- pen_out
    for (j in seq_along(pen)) {
      tmp_pen_out <- pen_out[pen_out >= 0.4 * pen[j]]
      for (k in seq_along(tmp_pen_out)) {
        tmp <-
          FUN(probe, pen[j], tmp_pen_out[k], smpl_min, smpl_max, cores = cores)
        correct[j, as.character(tmp_pen_out[k])] <- tmp[[1]]
        wrong[j, as.character(tmp_pen_out[k])] <- tmp[[2]]
      }
    }
    res2[[i]] <- correct
    res3[[i]] <- wrong
    dif <- correct - wrong
    if (any(dif >= wrong, na.rm = TRUE)) {
      ind <-
        which(dif == max(dif[dif >= wrong], na.rm = TRUE), arr.ind = TRUE)[1, ]
    } else {
      ind <- which(dif == max(dif, na.rm = TRUE), arr.ind = TRUE)[1, ]
      warning("no set of penalties suits the criteria, continued with next best
              option")
    }
    sta_pen <- as.numeric(rownames(dif)[ind[1]]) - step_pen
    end_pen <- as.numeric(rownames(dif)[ind[1]]) + step_pen
    sta_pen_out <- as.numeric(colnames(dif)[ind[2]]) - step_pen_out
    end_pen_out <- as.numeric(colnames(dif)[ind[2]]) + step_pen_out
    step_pen <- (end_pen - sta_pen) / (rez_pen - 1)
    step_pen_out <- (end_pen_out - sta_pen_out) / (rez_pen_out - 1)
    pen <- seq(sta_pen, end_pen, step_pen)
    pen_out <- seq(sta_pen_out, end_pen_out, step_pen_out)
    res1 <-
      c(as.numeric(rownames(dif)[ind[1]]), as.numeric(colnames(dif)[ind[2]]))
  }
  logs[c(
    paste0(names(tmp)[1], "_penalty"),
    paste0(names(tmp)[1], "_outlier_penalty")
  )] <- c(res1[1], res1[2])
  names(res1) <- names(tmp)
  res <- list(logs, res1, res2, res3)
  res
}


#' ssi_index
#'
#' Calculate Summer Simmer index developed in Canada for heat.
#'
#' @param t numeric Air temperature in degC.
#' @param rh numeric Relative humidity in percentage.
#' @return Summer Simmer index in degC
#'
#'
#' @author Istituto per la Bioeconomia CNR Firenze Italy  Alfonso Crisci \email{alfonso.crisci@@ibe.cnr.it}
#' @keywords  SSI
#'
#' @export
#'
#'
#'
#'

ssi_index=function(t,rh) {
                         ct$assign("t", as.array(t))
                         ct$assign("rh", as.array(rh))
                         ct$eval("var res=[]; for(var i=0, len=t.length; i < len; i++){ res[i]=ssi_index(t[i],rh[i])};")
                         res=ct$get("res")
                         return(ifelse(res==9999,NA,res))
}


#load libraries
require(igraph.RColorBrewer)

#load the edges with time stamp
#there are three columns in edges.csv: id1, id2, time
edges <- read.table("edges.csv",header=T)

#generate the full graph
g <- graph.data.frame(edges,directed=F)

#generate a temperature palette for the graph (darker = older)
Y1OrBr.pal <- colorRampPalette(brewer.pal(8,"Y1OrRd"))
#colors for the nodes are chosen from the beginning
V(g)$color <- rev(Y1ORBr.pal(vcount(g)))[as.numeric(V(g)$name)]

#time in the edges goes from 1 to 300.  Start at 3.
ti <- 3
#remove edges which are not present
gt <- delete_edges(g,which(E(g)$time>ti))
#generate first layout using graphopt with normalized coordinates.  This places the initially connected set of nodes in the middle.  If you use Fruchterman-Reingold it will place that initial set in the outer ring.
layout.old <- norm_coords(layout.graphopt(gt), xmin=-1, xmax = 1, ymin = -1, ymax = 1)

#total time of the dynamics
total_time <- max(E(g)$time)
#This is the time interval for the animation.  In this case is taken to be 1/10 of the time (i.e. 10 snapshots) between adding two consecutive nodes
dt <- 0.1
#Output for each frame will be a png with HD size 1600x900
png(file="animation/example%03d.png", width=1600,height=900)
#Time loop starts
for(time in seq(3,total_time,dt)){
  #remove edges which are not present
  gt <- delete_edges(g,which(E(g)$time>time))
  #with the new graph, update the layout
  layout.new <- layout_with_fr(gt,coords=layout.old,niter=10,start.temp=0.05,grid="nogrid")
  #plot the new graph
  plot(gt,layout=layout.new,vertex.label=" ",vertex.size=1+2*log(degree(gt)),vertex.frame.color=V(g)$color,edge.width=1.5,asp=9/16,margin=-0.15)
  #use new layout in the next round
  layout.old <- layout.new
}
dev.off()

#produce the video using the ffmpeg tool
#ffmpeg -r 10 -i example%03d.png -b:v 20M output.mp4


#' @name topologies
#' @rdname topologies
#' @title Build topologies
#' Build pixel and reach topologies for delineated streams
#' @param x A [raster::stack], such as one created by [delineate()], or specify layers separately with `drain` and `stream`.
#' @param drainage Optional, ignored if `x` is provided; a drainage direction raster
#' @param stream Optional, ignored if `x` is provided; a delineated stream raster, all non-stream cells must be `NA`
#' @param Tp Topology for pixels in the network, e.g., the output from [pixel_topology()].
#' @details The topology is a square matrix showing immediate adjacency between pixels/reaches. Each row/column
#' in the topology is a single pixel/reach. Zero entries indicate no adjacency between two nodes. A non-zero entry
#' for row `i` column `j` indicates that `i` is upstream of `j`. The value in the entry is the reaction length of the
#' upstream pixel/reach; this is the midpoint to midpoint distance from i to j. The actual length of each node is stored in the
#' `length` attribute; thus `Tp[i,j] == sum(attr(Tp, "length")[c(i,j)])/2`
#' @return A [Matrix::sparseMatrix] giving the pixel or reach topology
#' @examples
#' \donttest{
#'     data(kamp_dem)
#'     kamp = delineate(kamp_dem, outlet = NA)
#'     Tp = pixel_topology(kamp)
#'     Tr = reach_topology(kamp, Tp)
#'
#' }
NULL

#' @rdname topologies
#' @export
pixel_topology = function(x, drainage, stream) {
	if(!requireNamespace("Matrix"))
		stop("This functionality requires the Matrix package; please install it with install.packages('Matrix') and try again.")

	if(! missing(x)) {
		stream = x[['stream']]
		drainage = x[['drainage']]
	}

	nr = raster::nrow(drainage)
	nc = raster::ncol(drainage)
	ncl = raster::ncell(drainage)
	vals = raster::values(raster::stack(list(
		x = raster::raster(matrix(1:nc, nrow=nr, ncol=nc, byrow=TRUE), template = drainage),
		y = raster::raster(matrix(1:nr, nrow=nr, ncol=nc), template = drainage),
		id = raster::raster(matrix(1:ncl, nrow=nr, ncol=nc, byrow=TRUE), template = drainage),
		drainage = drainage,
		stream = stream)))
	vals = vals[complete.cases(vals),]

	## compute the length of each pixel
	r = raster::res(stream)
	vals = cbind(vals, len = ifelse(vals[, 'drainage'] %in% c(1,3,5,7), sqrt(r[1]^2 + r[2]^2),
									ifelse(vals[, 'drainage'] %in% c(2, 6), r[2], r[1])))
	xy = .flowto(vals, xmax = nc, ymax = nr)

	## this is the reaction length of each connection, the midpoint-midpoint distance
	p_len = (vals[match(xy[,'from_id'], vals[,'id']), 'len'] + vals[match(xy[,'to_id'], vals[,'id']), 'len'])/2

	res = Matrix::sparseMatrix(i = xy[,'from_id'], j = xy[,'to_id'], dims=rep(raster::ncell(drainage), 2), x = p_len)
	attr(res, "length") = vals[,'len']
	.check_topology(res, warn = TRUE)
	res
}

#' @rdname topologies
#' @export
reach_topology = function(x, Tp, stream) {
	if(missing(Tp))
		stop("A topology is required for this function")

	if(!requireNamespace("Matrix"))
		stop("This functionality requires the Matrix package; please install it with install.packages('Matrix') and try again.")

	if(missing(stream))
		stream = x[['stream']]

	if(!is.null(getOption("mc.cores")) && getOption("mc.cores") > 1) {
		lapplfun = parallel::mclapply
	} else {
		lapplfun = lapply
	}

	rids = raster::unique(stream)

	if(!all(rids == 1:length(rids)))
		stop("Reach IDs not in strict ascending order, they must be renumbered")

	adj = lapplfun(rids, .upstream_r, stream = stream, Tx = Tp)
	adj = do.call(rbind, adj)

	## compute the length of each reach as the sum of all pixels
	pids = lapplfun(rids, extract_reach, stream=stream, Tp = Tp)
	lens = unlist(lapplfun(pids, function(x) sum(Tp[x,,drop=FALSE])))

	## the reaction length is the midpoint to midpoint distance for each reach
	## actual reach lengths are saved in an attribute
	r_len = (lens[adj[,1]] + lens[adj[,2]])/2

	res = Matrix::sparseMatrix(adj[,'from'], adj[,'to'], dims=rep(max(rids), 2),
									dimnames = list(rids, rids), x = r_len)
	attr(res, "length") = lens
	res
}

#' Find pixel IDs matching reach i
#' @param i Reach number to extract
#' @param stream Raster stream layer
#' @param Tp optional Topology, only needed for sorting
#' @param sorted Logical, should the ids be returned sorted from upstream to down?
#' @return A vector of pixel ids
#' #' @examples
#' \donttest{
#'     data(kamp_dem)
#'     kamp = delineate(kamp_dem, outlet = NA)
#'     Tp = pixel_topology(kamp)
#'     extract_reach(5, kamp$stream, Tp)
#' }
#' @export
extract_reach = function(i, stream, Tp, sorted = FALSE) {
	pids = which(raster::values(stream) == i)
	if(sorted && length(pids) > 1) {
		pid_s = numeric(length(pids))
		Tp_r = Tp[pids, pids, drop=FALSE]
		pid_s[1] = .headwater(Tp_r)
		for(i in 2:length(pid_s))
			pid_s[i] = .downstream(Tp_r, pid_s[i-1])
		pids = pids[pid_s]
	}
	pids
}

#' @name upstream
#' @rdname upstream
#' @title Simple topology analysis
#' Simple functions for extracting information from river topologies
#' @param Tx A (pixel or reach) topology
#' @param i,j Focal node
#' @param stream A stream raster (as produced by [delineate()]) with reachIDs as the values
#' @details upstream/downstream take a single node as input, and return the up- or downstream node.
#' Outlets/headwaters analyzes the entire toplogy and finds nodes that have no downstream or upstream neighbours.
#' @return The id (corresponding to dims of Tx) of the desired node(s)
NULL

#' @rdname upstream
#' @keywords internal
.upstream = function(Tx, j) {
	which(Tx[,j] != 0)
}

#' @rdname upstream
#' @keywords internal
.downstream = function(Tx, i) {
	which(Tx[i,] != 0)
}

#' @rdname upstream
#' @keywords internal
.headwater = function(Tx) {
	which(.is_headwater(Tx))
}

#' @rdname upstream
#' @keywords internal
.outlet = function(Tx) {
	which(.is_outlet(Tx))
}

#' @rdname upstream
#' @keywords internal
.is_headwater = function(Tx) {
	## single-member topologies are always both headwaters and outlets
	if(all(dim(Tx) == c(1,1))) {
		return(TRUE)
	} else {
		## check for rowsums as well because we exclude nodes that are connected to nothing
		(Matrix::colSums(Tx) == 0 & Matrix::rowSums(Tx) != 0)
	}
}

#' @rdname upstream
#' @keywords internal
.is_outlet = function(Tx) {
	## single-member topologies are always both headwaters and outlets
	if(all(dim(Tx) == c(1,1))) {
		return(TRUE)
	} else {
		## check for colsums as well because we exclude nodes that are connected to nothing
		(Matrix::colSums(Tx) != 0 & Matrix::rowSums(Tx) == 0)
	}
}

#' @rdname upstream
#' @return For `.upstream_r`, A named2-column matrix, 'to' is the downstream reach (i.e., i) and
#' 'from' contains ids of the reach(es) upstream of i; or NULL if there are none
#' @keywords internal
.upstream_r = function(i, stream, Tx) {
	pids = extract_reach(i, stream)
	Tp_r = Tx[pids, pids, drop=FALSE]
	r_top = pids[.headwater(Tp_r)]
	r_nb = .upstream(Tx, r_top)
	if(length(r_nb) > 0) {
		from_ids = stream[r_nb]
		res = cbind(to = i, from = from_ids)
	} else {
		res = NULL
	}
	res
}

#' Compute which pixels flow into which other pixels
#' @param mat A matrix with 4 named columns; 'x', 'y', 'drainage', and 'id'
#' @return A matrix of IDs, the first column the upstream pixel, the second column downstream pixel
#' @keywords internal
.flowto = function(mat, xmax, ymax) {
	mat = mat[mat[, 'drainage'] > 0,] ## can only interpret positive drainages
	xoffset = c(1, 0, -1, -1, -1, 0, 1, 1)
	yoffset = c(-1, -1, -1, 0, 1, 1, 1, 0)
	newx = mat[,'x'] + xoffset[mat[,'drainage']]
	newy = mat[,'y'] + yoffset[mat[,'drainage']]

	res_mat = cbind(mat, newx, newy)
	res_mat = merge(res_mat[,c('newx', 'newy', 'id', 'drainage')], res_mat[,c('x', 'y', 'id')], by = c(1,2), all.x = TRUE)
	res_mat = res_mat[,c('newx', 'newy', 'drainage', 'id.x', 'id.y')]
	colnames(res_mat)[4:5] = c('from_id', 'to_id')

	# res_mat = .fix_topology(res_mat, mat)
	res_mat = res_mat[order(res_mat[,'from_id']),]
	res_mat = res_mat[complete.cases(res_mat),]
	return(res_mat)
}

#' Verify that the topology is working as expected
#' @param Tp A topology matrix
#' @param warn if TRUE, warnings are raised instead of errors
#' @return NULL, raises errors/warnings when invalid topologies detected
#' @keywords internal
.check_topology = function(Tp, warn = FALSE) {
	if(warn) {
		fun = warning
	} else {
		fun = stop
	}

	rs = Matrix::rowSums(Tp != 0)
	cs = Matrix::colSums(Tp != 0)
	if(any(rs > 1))
		fun("Invalid topology; ", sum(rs > 1), " nodes are upstream of more than one node.")

	if(sum(rs == 0 && cs != 0) > 1)
		fun("Invalid topology; ", sum(rs == 0), " outlets found.")

	if(any(cs > 2))
		fun("Invalid topology; ", sum(cs > 2), " nodes are downstream of more than two nodes.")
}


##CTE534_Gráficos=group
##showplots
##Vector=vector
##X=Field Vector
##Y=Field Vector
##Tipo=selection punto;línea;punto&línea
if (Tipo == 0) {
plot(Vector[[X]],
     Vector[[Y]],
     xlab=X,
     ylab=Y)
box()
grid(lwd=1,
     col="black")
} else if (Tipo == 1) {
plot(Vector[[X]],
     Vector[[Y]],
     xlab=X,
     ylab=Y,
     type="l")
box()
grid(lwd=1,
     col="black")
} else if (Tipo == 2) {
plot(Vector[[X]],
     Vector[[Y]],
     xlab=X,
     ylab=Y,
     type="b")
box()
grid(lwd=1,
     col="black")
}


# Randomly select 75% of the USArrest data as training data and the rest as testData
# Used to validate the created models.
u <- USArrests

trainingvec <- sample(1:nrow(u), 0.75*nrow(u))
testvec <- (1:nrow(u))[-trainingvec]
u[trainingvec,]


# variables.path
# run.name
# setwd(variables.path)
require(raster)

# Create the Data table == == == == == === == == == == === == == === == == == ==

# make var list
varlist <- list.files(pattern = '*.tif$')
varlist <- varlist[10:length(varlist)]

# get # of pixels from variable folder
forpixels <- raster(varlist[1])
pixels <- nrow(forpixels) * ncol(forpixels)

# initialize prediction table based on those pixels above
unseen.table <- matrix(0, pixels, length(varlist))

# make prediction table
unseen.table <- lapply(seq(length(varlist)),
	function(a){
		unseen.table[,a] <- c(as.matrix(raster(varlist[a])))
		# unseen.table[,a][is.na(unseen.table[,a])]  <- -99
	}
)
unseen.table <- as.data.frame(do.call('cbind', unseen.table))

# create variable names (remove '.tif')
varnames <- substr(varlist, 1, nchar(varlist) - 4)

# create col headers
for(k in seq(length(varnames))){
	colnames(unseen.table)[k] <- varnames[k]
}
unseen.table[is.na(unseen.table)] <- -99

# Output unseen.table to folder containing variables.path (the rfc folder)
#filename3 <- paste(substr(variables.path, 1, nchar(variables.path) - 3), 'kmcluster.csv' , sep='')
#write.csv(unseen.table, filename3, row.names = FALSE)

# Kmeans Cluster == == == == == === == == == == === == == === == == == == == ==

# kmeans
centers <- 5
km <- kmeans(as.matrix(unseen.table), centers = centers)

# .. to raster
# km.raster <- raster(matrix(km$cluster, nrow = nrow(forpixels), ncol=ncol(forpixels), byrow=FALSE))
vals <- matrix(km$cluster, nrow = nrow(forpixels), ncol=ncol(forpixels), byrow=FALSE)
# km.raster <- c(km.raster)
km.raster <- forpixels
values(km.raster) <- vals

# Get raster sample for the proj and extent from var list first entry
raster.sample <- raster(varlist[1])
extent(km.raster) <- c(raster.sample@extent@xmin, raster.sample@extent@xmax, raster.sample@extent@ymin, raster.sample@extent@ymax)
projection(km.raster) <- CRS(raster.sample@crs@projargs)

# output raster in folder containing variables.path
outrastername <- paste('temp_cluster.tif' , sep='')
writeRaster(km.raster, outrastername, formats = 'GTiff', overwrite=TRUE)

# --------------------------
# make the line graph by class
# --------------------------
require(reshape2)
require(ggplot2)

nclasses <- 5
linedf <- data.frame( matrix(rep(NA, nclasses*length(varlist)), ncol=nclasses) )
classlist <- lapply(seq(length(varlist)), function(x) {
	classes <- c()
	for(i in seq(nclasses)) {
		classes <- c(classes, mean(getValues(brick[[x]])[getValues(km.raster) == i]))
	}
	return(classes)
})

for(i in seq(nclasses)) {
	class <- sapply(classlist, function(x) {
		x[i]
	})
	linedf[i] <- class
}
linedf$id <- seq(length(varlist))
linedflong <- melt(linedf, id="id")
ggplot(data=linedflong, aes(x=id, y=value, colour=variable)) + geom_line()

write.table(linedf, "classes.txt",sep="\t",row.names=FALSE)


########################################################################################################################
### Calculate percentiles of phenomatch scores for the analyzed gene values per DGAP case
### Input: phenomatch and max_phenomatch scores file. Remember to delete the _A and _B from the file before processing.
### Output: file with percentiles for the analyzed pheno/maxphenomatch scores per gene.
### how to run: Rscript --vanilla get_percentiles_DGAP_all.r v07_breakpoint_window_with_HPO.bed.6MB_win.bed.annotated.out.overlapped_genes_formatted.txt > percentiles_6Mb_pheno_maxpheno.txt
########################################################################################################################
require(lattice)
require(stringr) # for str_split_fixed()

#arguments:
args <- commandArgs(trailingOnly = TRUE)

allgenes <- args[1]
rm(args)

#input file format
#1	2	3	4	5		6		7		8
#chr	start	end	name	phenotypes	gene_symbol	phenoMatchScore MaxPhenoMatchScore
#chr18	60566041	66566041	DGAP322	HP:0008736;HP:0011342;HP:0000119;HP:0012856;HP:0001510;HP:0000047	SERPINB7	0.014	0.003
#chr18	60566041	66566041	DGAP322	HP:0008736;HP:0011342;HP:0000119;HP:0012856;HP:0001510;HP:0000047	BCL2	0.821	0.797
#chr10	7161499	13161499	DGAP287	HP:0001264;HP:0001251;HP:0002307;HP:0011343;HP:0001344	GATA3	1.822	1.365
#chr10	7161499	13161499	DGAP287	HP:0001264;HP:0001251;HP:0002307;HP:0011343;HP:0001344	DHTKD1	9.057	2.09

#remember to delete the _A and _B from the file before processing

allgene <- read.table(file = allgenes, header = TRUE, comment.char = "")

# delete the _A and _B from name column
allgene$name <- str_split_fixed(allgene$name, '_', 2)[, 1]

for (i in 1:nrow(allgene)){

	data <- allgene[allgene$name == allgene[i,4],]

	#write.table(data, file="out_matrices_phenomatch_6Mb.txt", append = TRUE, quote = FALSE, sep = "\t", eol = "\n", row.names = FALSE, col.names = TRUE)

	#print(allgene[i,4],max.levels = 0)

	cat(allgene[i,4])
	cat("\t")
	cat(as.character(allgene[i,6]))
	cat("\t")
	cat(as.character(allgene[i,1]))
	cat("\t")
	cat(allgene[i,7])
	cat("\t")
	cat(allgene[i,8])
	cat("\t")
	cat(nrow(data))
	cat("\t")
	cat(mean(data[,7] <= allgene[i,7]))
	cat("\t")
	cat(min(data[,7]))
	cat("\t")
	cat(max(data[,7]))
	cat("\t")
	cat(mean(data[,8] <= allgene[i,8]))
	cat("\t")
	cat(min(data[,8]))
	cat("\t")
	cat(max(data[,8]))
	cat("\n")

}


#THIS SCRIPT GENERATES THE DASHABORD FOR EACH EXPERIMENT IN A DEDICATED PLOT,  WITH THE FOUR BASELINES IN A SINGLE PLOT, LOG SCALE

log_plot_dash <- function(x,y,sdx,sdy, col, pch){
  if(x>1 && y >1){
    print(paste(col, "lat", x,"sd", sdx))
    print(paste(col, "mem", y, "sd", sdy))
    lx <- log(x)
    ly <- log(y)

    points(x = lx, y = ly, col=col, type = "p", pch=pch)
    arrows(lx, log(y-sdy),lx,log(y+sdy),, length=0.05, angle=90, code=3, col="grey55")
    arrows(log(x-sdx), ly,log(x+sdx),ly, length=0.05, angle=90, code=3, col="gray55")

  }
}

plot_dashboard <- function(i){
  print(paste("----START",i, "----"))
  NAIVE_GRAPH <- i
  NAIVE_STMT <- NAIVE_GRAPH+1
  INC_GRAPH <- NAIVE_STMT+1
  INC_STMT <- INC_GRAPH+1

  plot(seq(0.025,200,0.1), seq(0.025,50,0.025), log="xy", type = "n", ylab = "Memory", xlab = "Latency")
  abline( h = seq( 0.1, 200, 0.05 ), lty = 3, col = colors()[ 440 ] )
  abline( v = seq( 0.1, 200, 0.05), lty = 3, col = colors()[ 440 ] )

  #Graph naive
  log_plot_dash(lat_report_rhodf$Mean.SS[NAIVE_GRAPH], mem_report_rhodf$A..Mean.SS[NAIVE_GRAPH], lat_report_rhodf$Dev.StdSS[NAIVE_GRAPH], mem_report_rhodf$A.Dev.Std.SS[NAIVE_GRAPH], "red", 0)

  #stmt naive
  log_plot_dash(lat_report_rhodf$Mean.SS[NAIVE_STMT],mem_report_rhodf$A..Mean.SS[NAIVE_STMT], lat_report_rhodf$Dev.StdSS[NAIVE_STMT], mem_report_rhodf$A.Dev.Std.SS[NAIVE_STMT], "blue", 15)

  #Graph inc
  log_plot_dash(lat_report_rhodf$Mean.SS[INC_GRAPH],mem_report_rhodf$A..Mean.SS[INC_GRAPH], lat_report_rhodf$Dev.StdSS[INC_GRAPH], mem_report_rhodf$A.Dev.Std.SS[INC_GRAPH], "black", 1)

  #stmt inc
  log_plot_dash(lat_report_rhodf$Mean.SS[INC_STMT],mem_report_rhodf$A..Mean.SS[INC_STMT], lat_report_rhodf$Dev.StdSS[INC_STMT], mem_report_rhodf$A.Dev.Std.SS[INC_STMT], "green", 16)

#   abline(v = log(min(lat_report_rhodf$Mean.SS[NAIVE_GRAPH],lat_report_rhodf$Mean.SS[NAIVE_STMT],lat_report_rhodf$Mean.SS[INC_GRAPH],lat_report_rhodf$Mean.SS[INC_STMT])),  col = "black")
#   abline (v = log(max(lat_report_rhodf$Mean.SS[NAIVE_GRAPH],lat_report_rhodf$Mean.SS[NAIVE_STMT],lat_report_rhodf$Mean.SS[INC_GRAPH],lat_report_rhodf$Mean.SS[INC_STMT])), col = "black")

  legend(300,100,pch=c(0,15,1,16), bg = "white", legend=c("NAIVE GRAPH", "NAIVE STMT", "INC GRAPH", "INC STMT"), cex=0.9 , col=c("red","blue","black","green"))
  title(paste("TRIPLE", mem_report_rhodf$K[NAIVE_GRAPH], "SLOT", mem_report_rhodf$EW[NAIVE_GRAPH]), paste("EXP", lat_report_rhodf$EN[NAIVE_GRAPH], lat_report_rhodf$EN[INC_STMT]))

  print("----END----")
}

for(i in seq(1,60,4)){

  if(i!=17){
    png(paste(paste("DASHBOARD LOG EXP", lat_report_rhodf$EN[i], lat_report_rhodf$EN[i+2]), "TRIPLE", mem_report_rhodf$K[i], "SLOT", mem_report_rhodf$EW[i], ".png", sep="_"), 1000, 1000)
    plot_dashboard(i)
    dev.off()
  }

}


#' Simulate data to test tryx
#'
#' # Create data using model here: https://www.draw.io/#G1VqjTd4iH2de7sXI4PhUrxazBnYLduH_w. Create summary data for all necessary traits, then perform tryx scan
#' x = exposure
#' y = outcome
#' u1 = confounder of x and y
#' u2 = mediator of horizontal pleiotropy from gx to y. One for each gx
#' u3 = mediator between x and y
#'
#' @param nid = 10000 Number of samples
#' @param ngx = 30 Number of direct instruments to x
#' @param ngu1 = 30 Number of instruments influencing confounder of x and y
#' @param ngu2 = 30 Number of instruments per mediating
#' @param nu2 = 2 Number of gx that are pleiotropic
#' @param ngu3 = 30 Number of instruments for u3 mediator
#' @param vgx = 0.2 Variance explained by gx instruments
#' @param vgu1 = 0.6 Variance explained by u1 instruments
#' @param vgu2 = 0.2 Variance explained by u2 instruments
#' @param vgu3 = 0.2 Variance explained by u3 instruments
#' @param bxy = 0 Causal effect of x on y
#' @param bu1x = 0.6 Effect of u1 on x
#' @param bu1y = 0.4 Effect of u1 on y
#' @param bxu3 = 0.3 Effect of x on u3
#' @param bu3y = 0 Effect of u3 on y
#' @param vgxu2 = 0.2 Variance explained by each gx instrument on each u2 mediator
#' @param vu2y = 0.2 Variance explained by all u2 mediators on y
#' @param ngxu3 = 0 Number of gx instruments that pleiotropically associate with u3 mediator
#' @param vgxu3y = 0 Variance explained by all gx variants directly on u3 mediator
#' @param mininum_instruments = 10 Minimum number of instruments required to have been detected to run simulation
#' @param instrument_threshold = "bonferroni" Threshold, either numeric or 'bonferroni'
#' @param outlier_threshold = "bonferroni" Threshold, either numeric or 'bonferroni'
#' @param outliers_known = "detected" Either detected = using radial mr to find heterogeneity outliers; known = adjust for all known invalid instruments; all = adjust for all instruments
#' @param directional_bias = FALSE Is the pleiotropic effect randomly centered around 0 (FALSE) or does it have a non-0 mean (TRUE)
#'
#' @export
#' @return list for tryx.analyse
tryx.simulate <- function(nid = 10000, ngx = 30, ngu1 = 30, ngu2 = 30, nu2 = 2, ngu3 = 30, vgx = 0.2, vgu1 = 0.6, vgu2 = 0.2, vgu3 = 0.2, bxy = 0, bu1x = 0.6, bu1y = 0.4, bxu3 = 0.3, bu3y = 0, vgxu2 = 0.2, vu2y = 0.2, ngxu3 = 0, vgxu3=0, mininum_instruments = 10, instrument_threshold = "bonferroni", outlier_threshold = "bonferroni", outliers_known = "detected", directional_bias = FALSE)
{
	out <- list()

	message("Generating genetic effects")

	gx <- make_geno(nid, ngx, 0.5)
	gu1 <- make_geno(nid, ngu1, 0.5)
	gu2 <- make_geno(nid, ngu2 * nu2, 0.5)
	gu3 <- make_geno(nid, ngu3, 0.5)
	u1 <- make_phen(choose_effects(ngu1, vgu1), gu1)
	x <- make_phen(c(abs(choose_effects(ngx, vgx)), bu1x), cbind(gx, u1))
	if(ngxu3 > 0)
	{
		u3 <- make_phen(c(choose_effects(ngu3, vgu3), bxu3, choose_effects(ngxu3, vgxu3)), cbind(gu3, x, gx[,sample(1:ngx, ngxu3)]))
	} else {
		u3 <- make_phen(c(choose_effects(ngu3, vgu3), bxu3), cbind(gu3, x))
	}

	# Some number of the direct gx SNPs also influence the outcome via a mediator
	# This is mediated pleiotropy

	message("Creating potential pleiotropy paths")

	u2 <- matrix(rnorm(nid * nu2), nid, nu2)
	for(i in 1:nu2)
	{
		message("SNP ", i, " is pleiotropic")
		u2[,i] <- make_phen(
			c(choose_effects(ngu2, vgu2), abs(choose_effects(1, vgxu2))),
			cbind(gu2[,((i-1) * ngu2 + 1):(ngu2 * i)], gx[,i])
		)
	}

	message("Creating outcome")

	bu2y <- choose_effects(nu2, vu2y)

	if(directional_bias)
	{
		message("U2 bias is directional")
		bu2y <- abs(bu2y)
	}
	y <- make_phen(
		c(bxy, bu3y, bu1y, bu2y),
		cbind(x, u3, u1, u2)
	)

	# Single genotype data source for simplicity

	G <- cbind(gx, gu1, gu2, gu3)
	G_annotation <- tibble(
		snp=1:ncol(G),
		origin1=c(
			rep("x", ngx),
			rep("u1", ngu1),
			rep(paste0("u2_",1:nu2), each=ngu2),
			rep("u3", ngu3)
		),
		origin2=c(
			rep("x", ngx),
			rep("u1", ngu1),
			rep("u2", each=ngu2*nu2),
			rep("u3", ngu3)
		)
	)

	# How do we select instruments?

	if(instrument_threshold == "bonferroni")
	{
		instrument_threshold <- 0.05 / ncol(G)
	} else {
		stopifnot(is.numeric(instrument_threshold))
	}
	message("instrument_threshold = ", instrument_threshold)

	# Get summary set

	message("Getting instruments")

	out$dat_all <- get_effs(x, y, G, "X", "Y")
	out$dat <- subset(out$dat_all, pval.exposure < instrument_threshold)
	stopifnot(nrow(out$dat) > mininum_instruments)
	out$dat$mr_keep <- TRUE
	G_annotation$detected <- G_annotation$snp %in% out$dat$SNP
	message("Detected ", nrow(out$dat), " associations for x")

	## Determine valid instruments

	if(vu2y == 0)
	{
		valid <- 1:ngx
	} else {
		valid <- (1:ngx)[! (1:ngx %in% 1:nu2)]
	}

	if(bu1y == 0)
	{
		valid <- c(valid, (ngx+1):(ngx+ngu1))
	}
	message("Valid instruments: ", paste(valid, collapse=","))
	G_annotation$valid <- G_annotation$snp %in% valid

	## known invalid instruments
	invalid <- which(! 1:ncol(G) %in% valid)

	out$valid <- valid
	out$invalid <- invalid

	# Get outliers

	no_outlier_flag <- FALSE
	if(outliers_known == "known")
	{
		message("Assuming knowledge of all outliers")
		outliers <- out$dat$SNP[out$dat$SNP %in% invalid]
	} else if(outliers_known %in% c("detected", "all")) {
		message("Detecting outliers")
		radial <- RadialMR::ivw_radial(RadialMR::format_radial(out$dat$beta.exposure, out$dat$beta.outcome, out$dat$se.exposure, out$dat$se.outcome, out$dat$SNP), ifelse(outlier_threshold == "bonferroni", 0.05/nrow(out$dat), outlier_threshold), weights=3)
		if(radial$outliers[1] == "No significant outliers")
		{
			message("No significant outliers detected")
			outliers <- as.character(out$dat$SNP[out$dat$SNP %in% invalid])
			if(length(outliers) == 0) outliers <- 1
			no_outlier_flag <- TRUE
		} else {
			outliers <- as.character(sort(radial$outliers$SNP))
			message("Number of outliers: ", length(outliers))
		}
	} else {
		stop("outliers_known must be 'known', 'detected' or 'all'")
	}

	nout <- length(outliers)
	outliers <- subset(out$dat, SNP %in% outliers)$SNP
	out$outliers <- outliers
	if(outliers_known == "all")
	{
		message("Treating all variants as outliers")
		outliers <- out$dat$SNP
	}
	# out$id_list <- c(paste0("U1_", 1:nu1), paste0("U2_", 1:nu2))
	message("Outliers to be analysed: ", paste(outliers, collapse=","))

	message("Perform outlier scan")

	U <- cbind(u1, u2, u3)
	colnames(U) <- c("U1", paste0("U2_", 1:ncol(u2)), "U3")
	outlier_scan <- list()
	for(i in 1:ncol(U))
	{
		outlier_scan[[colnames(U)[i]]] <- gwas(U[,i], G[,outliers, drop=FALSE])
		outlier_scan[[colnames(U)[i]]]$SNP <- outliers
		outlier_scan[[colnames(U)[i]]]$outcome <- colnames(U)[i]
	}
	outlier_scan <- bind_rows(outlier_scan)
	out$search <- tibble::tibble(
		SNP=outlier_scan$SNP,
		beta.outcome=outlier_scan$bhat,
		se.outcome=outlier_scan$se,
		pval.outcome=outlier_scan$pval,
		id.outcome=outlier_scan$outcome,
		outcome=outlier_scan$outcome,
		mr_keep=TRUE,
		effect_allele.outcome="A",
		other_allele.outcome="G",
		eaf.outcome=0.5
	)
	out$search$sig <- out$search$pval.outcome < 5e-8
	message("Found the following candidate traits: ", paste(unique(subset(out$search, sig)$id.outcome), collapse=","))

	message("Organise data for mvmr")

	traitlist <- as.character(unique(subset(out$search, sig)$id.outcome))
	PHEN <- cbind(x, U[,traitlist])
	PHEN <- lapply(seq_len(ncol(PHEN)), function(i) PHEN[,i])
	names(PHEN) <- c("x", traitlist)
	message("Analysing ", length(PHEN), " traits: ", paste(names(PHEN), collapse=","))

	snplist <- sapply(1:length(PHEN), function(x) {
		subset(gwas(PHEN[[x]], G), pval < instrument_threshold)$snp
	}) %>% unlist() %>% sort %>% unique
	message("Found ", length(snplist), " unique instruments")

	message("Perform mvmr")
	out$mvres <- try({
		mvdat <- make_mvdat(PHEN, y, G[,snplist])
		mvres <- mv_multiple(mvdat)
		mvres$result$exposure <- c("x", traitlist)
		mvres
	})

	message("Building effects for ", length(traitlist), " trait(s)")

	## get effects
	ux <- list()
	uy <- list()
	for(i in traitlist)
	{
		message(i)
		ux[[i]] <- get_effs(U[,i], x, G, i, "X") %>% subset(pval.exposure < instrument_threshold)
		uy[[i]] <- get_effs(U[,i], y, G, i, "Y") %>% subset(pval.exposure < instrument_threshold)
		if(nrow(ux[[i]]) > 0)
		{
			ux[[i]]$effect_allele.exposure <- "A"
			ux[[i]]$other_allele.exposure <- "G"
			ux[[i]]$effect_allele.outcome <- "A"
			ux[[i]]$other_allele.outcome <- "G"
			ux[[i]]$eaf.exposure <- 0.5
			ux[[i]]$eaf.outcome <- 0.5
		}

		if(nrow(uy[[i]]) > 0)
		{
			uy[[i]]$effect_allele.exposure <- "A"
			uy[[i]]$other_allele.exposure <- "G"
			uy[[i]]$effect_allele.outcome <- "A"
			uy[[i]]$other_allele.outcome <- "G"
			uy[[i]]$eaf.exposure <- 0.5
			uy[[i]]$eaf.outcome <- 0.5
		}
	}

	out$candidate_instruments <- subset(bind_rows(ux), select=c(
		SNP, beta.exposure, se.exposure, id.exposure, exposure, effect_allele.exposure, other_allele.exposure, eaf.exposure, pval.exposure
	))

	message("Removing known outliers from candidate instruments")

	out2 <- subset(out$search, sig)
	out$candidate_instruments <- group_by(out$candidate_instruments, id.exposure) %>%
		do({
			x <- .
			y <- subset(out2, id.outcome == x$id.exposure[1])
			x <- subset(x, !SNP %in% y$SNP)
			x
		})

	message("MR of candidates on outcome")

	out$candidate_outcome <- subset(bind_rows(uy), select=c(
		SNP, beta.outcome, se.outcome, id.outcome, outcome, effect_allele.outcome, other_allele.outcome, eaf.outcome, pval.outcome
	))

	# out$candidate_outcome_dat <- suppressMessages(harmonise_data(out$candidate_instruments, out$candidate_outcome))
	out$candidate_outcome_dat <- harmonise_data(out$candidate_instruments, out$candidate_outcome)
	out$candidate_outcome_mr <- suppressMessages(mr(out$candidate_outcome_dat, method_list="mr_ivw"))

	message("MR of candidates on exposure")

	out$candidate_exposure <- subset(bind_rows(ux), select=c(
		SNP, beta.outcome, se.outcome, id.outcome, outcome, effect_allele.outcome, other_allele.outcome, eaf.outcome, pval.outcome
	))

	# out$candidate_exposure_dat <- suppressMessages(harmonise_data(out$candidate_instruments, out$candidate_exposure))
	out$candidate_exposure_dat <- harmonise_data(out$candidate_instruments, out$candidate_exposure)
	out$candidate_exposure_mr <- suppressMessages(mr(out$candidate_exposure_dat, method_list="mr_ivw"))

	message("Finalising")
	out$G_annotation <- G_annotation
	out$simulation <- list()
	out$simulation$no_outlier_flag <- no_outlier_flag
	out$simulation$nid <- nid
	out$simulation$ngx <- ngx
	out$simulation$ngu1 <- ngu1
	out$simulation$ngu2 <- ngu2
	out$simulation$nu2 <- nu2
	out$simulation$ngu3 <- ngu3
	out$simulation$vgx <- vgx
	out$simulation$vgu1 <- vgu1
	out$simulation$vgu2 <- vgu2
	out$simulation$vgu3 <- vgu3
	out$simulation$bxy <- bxy
	out$simulation$bu1x <- bu1x
	out$simulation$bu1y <- bu1y
	out$simulation$bxu3 <- bxu3
	out$simulation$bu3y <- bu3y
	out$simulation$vgxu2 <- vgxu2
	out$simulation$vu2y <- vu2y
	out$simulation$ngxu3 <- ngxu3
	out$simulation$vgxu3 <- vgxu3
	out$simulation$mininum_instruments <- mininum_instruments
	out$simulation$instrument_threshold <- instrument_threshold
	out$simulation$outlier_threshold <- outlier_threshold
	out$simulation$outliers_known <- outliers_known
	out$simulation$directional_bias = directional_bias
	out$simulation$n_instruments <- sum(G_annotation$detected)
	out$simulation$n_valid_instruments <- sum(G_annotation$detected * G_annotation$valid)

return(out)
}

# #' Simulate data to test tryx
# #'
# #' Choose a sample size, number of horizontal pleiotropy paths, and number of confounders. Create summary data for all necessary traits, then perform tryx scan
# #'
# #' @param nid Sample size to simulate
# #' @param nu1 Number of traits which influence both X and Y
# #' @param nu2 Number of traits which influence Y
# #' @param bxu3 Effect of x on mediator
# #' @param bu3y Effect of mediator on y
# #' @param bxy Causal effect of X on Y
# #' @param outliers_known Assume that all outliers are detected (default = 'known'). But can also be 'detected', where we use heterogeneity based outlier detection, or 'all' where we try to adjust for every outlier regardless of heterogeneity
# #' @param directional_bias Is the outlier typically in one direction (i.e. unbalanced pleiotropy?)
# #' @param outlier_threshold Either 'nominal' or 'bonferroni'
# #' @param single_pleiotropy_trait = FALSE
# #'
# #' @export
# #' @return Results from simulations and tryx scan
# tryx.simulate <- function(nid, nu1, nu2, bxu3=0, bu3y=0, bxy=3, outliers_known=c("known", "detected", "all")[1], directional_bias=FALSE, outlier_threshold = 'nominal', single_pleiotropy_trait = FALSE, debug=FALSE, ngu4=10, ngx=30, bu4x=0, bu4y=0)
# {
# 	# scenario 1 - confounder g -> u; u -> x; u -> y
# 	# scenario 2 - pleiotropy g -> u -> y
# 	# scenario 3 - mediator
# 	# scenario 4 -

# 	out <- list()

# 	cpg <- require(simulateGP)
# 	if(!cpg)
# 	{
# 		stop("Please install the simulateGP package\ndevtools::install_github('explodecomputer/simulateGP')")
# 	}

# 	ngu1 <- 30
# 	ngu2 <- 30
# 	ngu3 <- 30
# 	nu3 <- 1
# 	nu4 <- 1
# 	nu <- nu1 + nu2 + nu3
# 	stopifnot(ngx >= nu)

# 	gx <- make_geno(nid, ngx, 0.5)
# 	out$true_outliers <- 1:nu

# 	# Effect sizes
# 	bgu1 <- lapply(1:nu1, function(x) runif(ngu1))
# 	bgu2 <- lapply(1:nu2, function(x) runif(ngu2))
# 	bgu3 <- runif(ngu3)
# 	bgx <- runif(ngx)

# 	bu1x <- out$bu1x <- rnorm(nu1)
# 	bu1y <- out$bu1y <- rnorm(nu1)
# 	bu2y <- out$bu2y <- rnorm(nu2)
# 	if(directional_bias)
# 	{
# 		bu1x <- out$bu1x <- abs(bu1x)
# 		bu1y <- out$bu1y <- abs(bu1y)
# 		bu2y <- out$bu2y <- abs(bu2y)
# 	}
# 	out$bxu3 <- bxu3
# 	bu3y <- out$bu3y <- bu3y
# 	bxy <- out$bxy <- bxy

# 	# create outlier traits
# 	gu1 <- list()
# 	u1 <- matrix(rnorm(nid * ngx), nid, ngx)
# 	if(nu1 > 0)
# 	{
# 		for(i in 1:nu1)
# 		{
# 			gu1[[i]] <- cbind(gx[,i], make_geno(nid, ngu1-1, 0.5))
# 			if(single_pleiotropy_trait)
# 			{
# 				u1[,1] <- u1[,1] + gu1[[i]] %*% bgu1[[i]]
# 			} else {
# 				u1[,i] <- gu1[[i]] %*% bgu1[[i]] + rnorm(nid)
# 			}
# 		}
# 	}

# 	gu2 <- list()
# 	u2 <- matrix(rnorm(nid * ngx), nid, ngx)
# 	if(nu2 > 0)
# 	{
# 		for(j in 1:nu2)
# 		{
# 			gu2[[j]] <- cbind(gx[,i+j], make_geno(nid, ngu1-1, 0.5))
# 			if(single_pleiotropy_trait)
# 			{
# 				u2[,1] <- u2[,1] + gu2[[j]] %*% bgu2[[j]]
# 			} else {
# 				u2[,j] <- gu2[[j]] %*% bgu2[[j]] + rnorm(nid)
# 			}
# 		}
# 	}

# 	u4 <- rnorm(nid)
# 	if(ngu4 > 0)
# 	{
# 		u4 <- u4 + gx[,1:ngu4] %*% runif(ngu4)
# 	}
# 	x <- drop(gx[,c((ngu4+1):ngx)] %*% bgx[c((ngu4+1):ngx)] + u4 %*% bu4x + u1 %*% bu1x + rnorm(nid))

# 	gu3 <- list(make_geno(nid, ngu3, 0.5))
# 	u3 <- matrix(gu3[[1]] %*% bgu3 + x * bxu3 + rnorm(nid), nid, 1)

# 	y <- drop(x * bxy + u1 %*% bu1y + u2 %*% bu2y + u3 * bu3y + u4 %*% bu4y + rnorm(nid))

# 	out$dat <- get_effs(x, y, gx, "X", "Y")
# 	out$dat$mr_keep <- TRUE
# 	no_outlier_flag <- FALSE

# 	if(outliers_known == "known")
# 	{
# 		message("Assuming knowledge of all outliers")
# 		outliers <- as.character(c(1:nu))
# 	} else if(outliers_known %in% c("detected", "all")) {
# 		message("Detecting outliers")
# 		radial <- RadialMR::ivw_radial(RadialMR::format_radial(out$dat$beta.exposure, out$dat$beta.outcome, out$dat$se.exposure, out$dat$se.outcome, out$dat$SNP), ifelse(outlier_threshold == "nominal", 0.05, 0.05/nrow(out$dat)))
# 		if(radial$outliers[1] == "No significant outliers")
# 		{
# 			message("No significant outliers detected")
# 			outliers <- as.character(c(1:nu))
# 			no_outlier_flag <- TRUE
# 		} else {
# 			outliers <- as.character(sort(radial$outliers$SNP))
# 			message("Number of outliers: ", length(outliers))
# 		}
# 	} else {
# 		stop("outliers_known must be known, detected or all")
# 	}
# 	# output$radialmr <- radial
# 	nout <- length(outliers)
# 	outliers <- subset(out$dat, SNP %in% outliers)$SNP
# 	out$outliers <- outliers
# 	if(outliers_known == "all")
# 	{
# 		message("Treating all variants as outliers")
# 		outliers <- 1:ngx
# 	}
# 	out$id_list <- c(paste0("U1_", 1:nu1), paste0("U2_", 1:nu2))

# 	# temp1 <- gwas(u1, gx[,1:2])

# 	temp <- list()
# 	for(i in 1:nu1)
# 	{
# 		temp[[i]] <- gwas(u1[,i], gx[,outliers, drop=FALSE])
# 		temp[[i]]$SNP <- outliers
# 		temp[[i]]$outcome <- paste0("U1_", i)
# 	}
# 	for(i in 1:nu2)
# 	{
# 		temp[[i + nu1]] <- gwas(u2[,i], gx[,outliers, drop=FALSE])
# 		temp[[i + nu1]]$SNP <- outliers
# 		temp[[i + nu1]]$outcome <- paste0("U2_", i)
# 	}
# 	for(i in 1:nu3)
# 	{
# 		temp[[i + nu1 + nu2]] <- gwas(u3[,i], gx[,outliers, drop=FALSE])
# 		temp[[i + nu1 + nu2]]$SNP <- outliers
# 		temp[[i + nu1 + nu2]]$outcome <- paste0("U3_", i)
# 	}
# 	for(i in 1:nu4)
# 	{
# 		temp[[i + nu1 + nu2 + nu3]] <- gwas(u4[,i], gx[,outliers, drop=FALSE])
# 		temp[[i + nu1 + nu2 + nu3]]$SNP <- outliers
# 		temp[[i + nu1 + nu2 + nu3]]$outcome <- paste0("U4_", i)
# 	}

# 	temp <- bind_rows(temp)

# 	out$search <- tibble::data_frame(SNP=temp$SNP, beta.outcome=temp$bhat, se.outcome=temp$se, pval.outcome=temp$pval, id.outcome=temp$outcome, outcome=temp$outcome, mr_keep=TRUE, effect_allele.outcome="A", other_allele.outcome="G", eaf.outcome=0.5)
# 	out$search$sig <- out$search$pval.outcome < 5e-8

# 	## Multivariable MR
# 	# Do mvmr with just the outlier detected traits

# 	traitlist <- as.character(unique(subset(out$search, sig)$id.outcome))
# 	G <- list()
# 	PHEN <- list(x)
# 	j <- 2
# 	if(any(grepl("U1", traitlist)))
# 	{
# 		u1traits <- gsub("U1_", "", traitlist[grepl("U1", traitlist)]) %>% as.numeric()
# 		message("U1 traits: ", paste(u1traits, collapse=","))
# 		G[[1]] <- lapply(u1traits, function(x) {
# 			return(gu1[[x]][,-1])
# 		}) %>% do.call(cbind, .)
# 		for(i in u1traits)
# 		{
# 			PHEN[[j]] <- u1[,i]
# 			j <- j + 1
# 		}
# 	}
# 	if(any(grepl("U2", traitlist)))
# 	{
# 		u2traits <- gsub("U2_", "", traitlist[grepl("U2", traitlist)]) %>% as.numeric()
# 		message("U2 traits: ", paste(u2traits, collapse=","))
# 		G[[2]] <- lapply(u2traits, function(x) {
# 			return(gu2[[x]][,-1])
# 		}) %>% do.call(cbind, .)
# 		for(i in u2traits)
# 		{
# 			PHEN[[j]] <- u2[,i]
# 			j <- j + 1
# 		}
# 	}
# 	if(any(grepl("U3", traitlist)))
# 	{
# 		u3traits <- gsub("U3_", "", traitlist[grepl("U3", traitlist)]) %>% as.numeric()
# 		message("U3 traits: ", paste(u3traits, collapse=","))
# 		G[[3]] <- lapply(u3traits, function(x) {
# 			return(gu3[[x]])
# 		}) %>% do.call(cbind, .)
# 		for(i in u3traits)
# 		{
# 			PHEN[[j]] <- u3[,i]
# 			j <- j + 1
# 		}
# 	}
# 	if(any(grepl("U4", traitlist)))
# 	{
# 		u4traits <- gsub("U4_", "", traitlist[grepl("U4", traitlist)]) %>% as.numeric()
# 		message("U4 traits: ", paste(u4traits, collapse=","))
# 		G[[4]] <- lapply(u4traits, function(x) {
# 			return(gx)
# 		}) %>% do.call(cbind, .)
# 		for(i in u4traits)
# 		{
# 			PHEN[[j]] <- u4[,i]
# 			j <- j + 1
# 		}
# 	}
# 	G[[5]] <- gx
# 	G <- do.call(cbind, G)
# 	traitlist <- c("X", traitlist)
# 	names(PHEN) <- traitlist

# 	out$mvres <- try({
# 		mvdat <- make_mvdat(PHEN, y, G)
# 		mvres <- mv_multiple(mvdat)
# 		mvres$result$exposure <- traitlist
# 		mvres
# 	})
# 	## get effects
# 	u1x <- list()
# 	u1y <- list()
# 	for(i in 1:nu1)
# 	{
# 		u1x[[i]] <- get_effs(u1[,i], x, gu1[[i]], paste0("U1_", i), "X")
# 		u1y[[i]] <- get_effs(u1[,i], y, gu1[[i]], paste0("U1_", i), "Y")
# 		u1x[[i]]$SNP <- u1y[[i]]$SNP <- c(i, paste0("u1_",1:(ngu1-1)))
# 		u1x[[i]]$effect_allele.exposure <- u1y[[i]]$effect_allele.exposure <- "A"
# 		u1x[[i]]$other_allele.exposure <- u1y[[i]]$other_allele.exposure <- "G"
# 		u1x[[i]]$effect_allele.outcome <- u1y[[i]]$effect_allele.outcome <- "A"
# 		u1x[[i]]$other_allele.outcome <- u1y[[i]]$other_allele.outcome <- "G"
# 		u1x[[i]]$eaf.exposure <- u1y[[i]]$eaf.exposure <- 0.5
# 		u1x[[i]]$eaf.outcome <- u1y[[i]]$eaf.outcome <- 0.5
# 	}

# 	u2x <- list()
# 	u2y <- list()
# 	for(i in 1:nu2)
# 	{
# 		u2x[[i]] <- get_effs(u2[,i], x, gu2[[i]], paste0("U2_", i), "X")
# 		u2y[[i]] <- get_effs(u2[,i], y, gu2[[i]], paste0("U2_", i), "Y")
# 		u2x[[i]]$SNP <- u2y[[i]]$SNP <- c(i+nu1, paste0("u2_",1:(ngu2-1)))
# 		u2x[[i]]$effect_allele.exposure <- u2y[[i]]$effect_allele.exposure <- "A"
# 		u2x[[i]]$other_allele.exposure <- u2y[[i]]$other_allele.exposure <- "G"
# 		u2x[[i]]$effect_allele.outcome <- u2y[[i]]$effect_allele.outcome <- "A"
# 		u2x[[i]]$other_allele.outcome <- u2y[[i]]$other_allele.outcome <- "G"
# 		u2x[[i]]$eaf.exposure <- u2y[[i]]$eaf.exposure <- 0.5
# 		u2x[[i]]$eaf.outcome <- u2y[[i]]$eaf.outcome <- 0.5
# 	}

# 	u3x <- list()
# 	u3y <- list()
# 	for(i in 1:nu3)
# 	{
# 		u3x[[i]] <- get_effs(u3[,i], x, gu3[[i]], paste0("U3_", i), "X")
# 		u3y[[i]] <- get_effs(u3[,i], y, gu3[[i]], paste0("U3_", i), "Y")
# 		u3x[[i]]$SNP <- u3y[[i]]$SNP <- c(i+nu1, paste0("u3_",1:(ngu3-1)))
# 		u3x[[i]]$effect_allele.exposure <- u3y[[i]]$effect_allele.exposure <- "A"
# 		u3x[[i]]$other_allele.exposure <- u3y[[i]]$other_allele.exposure <- "G"
# 		u3x[[i]]$effect_allele.outcome <- u3y[[i]]$effect_allele.outcome <- "A"
# 		u3x[[i]]$other_allele.outcome <- u3y[[i]]$other_allele.outcome <- "G"
# 		u3x[[i]]$eaf.exposure <- u3y[[i]]$eaf.exposure <- 0.5
# 		u3x[[i]]$eaf.outcome <- u3y[[i]]$eaf.outcome <- 0.5
# 	}

# 	u4x <- list()
# 	u4y <- list()
# 	for(i in 1:nu4)
# 	{
# 		u4x[[i]] <- get_effs(u4[,i], x, gx[,1:ngu4], paste0("U4_", i), "X")
# 		u4y[[i]] <- get_effs(u4[,i], y, gx[,1:ngu4], paste0("U4_", i), "Y")
# 		u4x[[i]]$SNP <- u4y[[i]]$SNP <- c(i+nu1, paste0("u4_",1:(ngu4-1)))
# 		u4x[[i]]$effect_allele.exposure <- u4y[[i]]$effect_allele.exposure <- "A"
# 		u4x[[i]]$other_allele.exposure <- u4y[[i]]$other_allele.exposure <- "G"
# 		u4x[[i]]$effect_allele.outcome <- u4y[[i]]$effect_allele.outcome <- "A"
# 		u4x[[i]]$other_allele.outcome <- u4y[[i]]$other_allele.outcome <- "G"
# 		u4x[[i]]$eaf.exposure <- u4y[[i]]$eaf.exposure <- 0.5
# 		u4x[[i]]$eaf.outcome <- u4y[[i]]$eaf.outcome <- 0.5
# 	}

# 	out$candidate_instruments <- subset(rbind(bind_rows(u1x), bind_rows(u2x), bind_rows(u3x)), select=c(
# 		SNP, beta.exposure, se.exposure, id.exposure, exposure, effect_allele.exposure, other_allele.exposure, eaf.exposure, pval.exposure
# 	))
# 	out2 <- subset(out$search, sig)
# 	out$candidate_instruments <- group_by(out$candidate_instruments, id.exposure) %>%
# 		do({
# 			x <- .
# 			y <- subset(out2, id.outcome == x$id.exposure[1])
# 			x <- subset(x, !SNP %in% y$SNP)
# 			x
# 		})

# 	out$candidate_outcome <- subset(rbind(bind_rows(u1y), bind_rows(u2y), bind_rows(u3y)), select=c(
# 		SNP, beta.outcome, se.outcome, id.outcome, outcome, effect_allele.outcome, other_allele.outcome, eaf.outcome, pval.outcome
# 	))

# 	# out$candidate_outcome_dat <- suppressMessages(harmonise_data(out$candidate_instruments, out$candidate_outcome))
# 	out$candidate_outcome_dat <- bind_rows(bind_rows(u1y), bind_rows(u2y), bind_rows(u3y))
# 	out$candidate_outcome_mr <- suppressMessages(mr(out$candidate_outcome_dat, method_list="mr_ivw"))

# 	out$candidate_exposure <- subset(rbind(bind_rows(u1x), bind_rows(u2x), bind_rows(u3x)), select=c(
# 		SNP, beta.outcome, se.outcome, id.outcome, outcome, effect_allele.outcome, other_allele.outcome, eaf.outcome, pval.outcome
# 	))

# 	# out$candidate_exposure_dat <- suppressMessages(harmonise_data(out$candidate_instruments, out$candidate_exposure))
# 	out$candidate_exposure_dat <- bind_rows(bind_rows(u1x), bind_rows(u2x), bind_rows(u3x))
# 	out$candidate_exposure_mr <- suppressMessages(mr(out$candidate_exposure_dat, method_list="mr_ivw"))

# 	out$simulation <- list()
# 	out$simulation$no_outlier_flag <- no_outlier_flag
# 	out$simulation$nu1 <- nu1
# 	out$simulation$nu2 <- nu2
# 	out$simulation$nu3 <- nu3
# 	out$simulation$bxu3 <- bxu3
# 	out$simulation$bu3y <- bu3y
# 	out$simulation$outliers_known <- outliers_known
# 	out$simulation$bxy <- bxy

# 	if(debug)
# 	{
# 		out$phen <- list(
# 			y=y, x=x, u1=u1, u2=u2, u3=u3, u4=u4
# 		)
# 	}
# 	return(out)
# }


#!/usr/bin/env Rscript

install.packages("optparse")
install.packages("vegan")
install.packages("igraph")
install.packages("networkD3")
install.packages("R.utils")
install.packages("xtable")
install.packages("hash")
install.packages("qgraph")


# Licensed to the Apache Software Foundation (ASF) under one
# or more contributor license agreements.  See the NOTICE file
# distributed with this work for additional information
# regarding copyright ownership.  The ASF licenses this file
# to you under the Apache License, Version 2.0 (the
# "License"); you may not use this file except in compliance
# with the License.  You may obtain a copy of the License at
#
#  http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing,
# software distributed under the License is distributed on an
# "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
# KIND, either express or implied.  See the License for the
# specific language governing permissions and limitations
# under the License.

sc <- sparkR.session(MASTER)

full_path <- function(file_path) {
    working_storage <- "WORKING_STORAGE"
    output_directory <- "rstudio"
    protocol_name <- "PROTOCOL_NAME"
    sprintf("%s://%s/%s/%s", protocol_name, working_storage, output_directory, file_path)
}

carriers <- read.df(full_path("carriers"), "parquet")
createOrReplaceTempView(carriers, "carriers")
printSchema(carriers)

airports <- read.df(full_path("airports"), "parquet")
createOrReplaceTempView(airports, "airports")
printSchema(airports)

flights <- read.df(full_path("flights"), "parquet")
createOrReplaceTempView(flights, "flights")
printSchema(flights)

library(ggplot2)
library(reshape2)

delay_sql <- sql("
SELECT SUBSTR(c.description, 0, 15) as Carrier, WorkDayDelay, WeekendDelay
FROM
       (SELECT CEIL( AVG(f.ArrDelay + f.DepDelay) ) as WorkDayDelay, f.UniqueCarrier
        FROM flights f
        WHERE f.DayOfWeek < 6
        GROUP BY f.UniqueCarrier
        ORDER BY WorkDayDelay desc
        LIMIT 10) t
    JOIN
       (SELECT CEIL( AVG(f.ArrDelay + f.DepDelay) ) as WeekendDelay, f.UniqueCarrier
        FROM flights f
        WHERE f.DayOfWeek > 5
        GROUP BY f.UniqueCarrier) t1
      ON t.UniqueCarrier = t1.UniqueCarrier
    JOIN carriers c
      ON t.UniqueCarrier = c.code
ORDER BY WeekendDelay DESC, WorkDayDelay DESC
")

delay <- collect(delay_sql)
delay_melt <- melt(delay[c('Carrier', 'WorkDayDelay', 'WeekendDelay')])

color_range_days <- c("#2966FF", "#61F2FF")

ggplot(data=delay_melt, aes(x=Carrier, y=value, fill=variable)) +
    geom_bar(stat="identity", width=.7, position="dodge") +
    stat_summary(fun.y=mean, geom = "line", mapping = aes(group = 1), color="red") +
    stat_summary(fun.y=mean, geom = "point", mapping = aes(group = 1), color="red") +
    theme(legend.position="right", axis.text.x=element_text(angle=90)) +
    labs(x="Carrier", y="Minutes", fill="Day Type") +
    coord_fixed(ratio = .2) +
    scale_fill_manual(values=color_range_days) +
    scale_y_continuous(breaks=seq(0, 30, 5))

top_flights_sql <- sql("
SELECT t.cnt as FlightsAmt, carriers.description as Carrier
FROM (
    SELECT count(*) as cnt, flights.UniqueCarrier as carrier_code
    FROM flights
    GROUP BY flights.UniqueCarrier LIMIT 6) t
LEFT JOIN carriers
  ON t.carrier_code = carriers.code
")

top_flights <- collect(top_flights_sql)

ggplot(transform(transform(top_flights, value=FlightsAmt/sum(FlightsAmt)), labPos=cumsum(FlightsAmt)-FlightsAmt/2),
       aes(x="", y = FlightsAmt, fill = Carrier)) +
    geom_bar(width = 1, stat = "identity") +
    coord_polar("y", start=0) +
    scale_fill_brewer(palette="Dark2") +
    theme_bw() +
    theme(axis.text.x=element_blank() ,panel.grid.major=element_blank(),panel.grid.minor = element_blank(),panel.border = element_blank()) +
    geom_text(size=4, aes(y=labPos, label=scales::percent(value))) +
    geom_text(size=3, aes(x=1.8, y=labPos, label=top_flights$Carrier)) +
    theme(legend.position="none")

distance_sql = sql("
SELECT SUBSTR(c.description, 0, 15) as Carrier, COUNT(Distance) AS Distance
FROM flights f
JOIN carriers c
  ON f.UniqueCarrier = c.code
GROUP BY c.description
ORDER BY distance DESC
LIMIT 10
")

distance <- collect(distance_sql)

distance$Carrier <- factor(distance$Carrier, levels = distance$Carrier[order(-distance$Distance)])

color_range <-  c("#2966FF", "#2E73FF","#3380FF", "#388CFF", "#3D99FF", "#42A6FF", "#47B2FF", "#4CBFFF", "#52CCFF",
                  "#57D9FF", "#5CE6FF", "#61F2FF", "#66FFFF")

ggplot(data=distance, aes(x=Carrier, y=Distance, fill=Carrier)) +
    geom_bar(stat="identity", width=.7, position="dodge") +
    theme(axis.text.x=element_text(angle=90)) +
    scale_fill_manual(values=color_range) +
    theme(legend.position="none")


# DataUtil.r
# Functions to get data for selection and analysis.

# From Micah Altman 20170726
# Adapted RBLlandau 20171002

library(tidyverse)

# H A C K S

# Absurd hack in here to make lifem print reasonably.
#  Increase the penalty for printing in scientific
#  (exponential) format, and limit the number of digits
#  so that there are no places after the radix point.
options("scipen"=100, "digits"=1)
# End of absurd hack.

# Enable printing wide tables.
options("width"=120)

# Add an infix concatenation operator for strings.
`%+%` <- function(a,b) paste0(a,b)

# U T I L I T Y   F U N C T I O N S

# Better functions for summarizing the loss data.
# These are more robust than just mean, and more broadly estimated
#  than median.
# midmean is just a trimmed mean of the middle half of the sample.
# trimean is a less efficient but easier trimmed central measure,
#  and was a JWT favorite.
trimean <-  function(vect)
{   foo <- fivenum(vect);
    ans <- 0.5*foo[3] + 0.25*foo[2] + 0.25*foo[4];
    ans
}
midmean <-  function(vect)
{   ans <- mean(vect, trim=0.25, na.rm=TRUE);
    ans
}

# Select only the dataframe rows with N copies.
fnSelectCopies <- function(dfIn, nCopies)
{   dfIn[dfIn$copies==nCopies,]
}

# Safe functions for plotting.
# Note that safelog(0) returns 0, as needed for sensible axis labeling.
safelog <- function(x) {return(log10(x+1))}
safe    <- function(x) {return(x+0.5)}

# Shock tabulation functions.
fntShockTab <- function(input, freq, impact, duration) {
    res1 <- input[input$copies>1 &
                input$shockfreq==freq &
                input$shockimpact==impact &
                input$shockmaxlife==duration,]
    assign("res.shocktdat", res1, envir=globalenv())
    #print(paste("res.shockdat",length(res.shockdat$copies)))
    restab <- dcast(res1, copies~lifem, value.var="mdmlosspct")
    return(restab)
}

# f n d f G e t G i a n t D a t a
fndfGetGiantData <- function(dir.string)
{
    # L O A D   F I L E S

    # Load & merge all files in directory
    if (dir.string == "") {dir.string <- "./"}
    filesList <- grep(pattern="^Giant.*\\.txt$", dir(dir.string),
                perl=TRUE, value = TRUE)
# !!! I need to get fully qualified names out of grep here.  How?
# !!! As it is, works only for current directory.
    sims.df.ls = lapply( filesList,
          function(x)read.table(x,
                                header=TRUE,sep=" ", na.strings="nolinefound")
    ) # NOTE MISSING PARAMETER ENTRIES in na.strings
    sims.merged.df <- bind_rows(sims.df.ls)

    # Set up namesets for dependent, independent, ignored vars.
    #  Many of the columns are not relevant to data analysis, only tracking.
    allVarNames <- colnames(sims.merged.df)
    ignoreVarNames <- c("timestamp","seed","walltime","cputime","logfilename",
        "logfilesize","instructionfilename","todaysdatetime","extractorversion",
        "cpuinfo","mongoid")
    resultVarNames <- c("docslost","docsrepairedmajority","docsrepairedminority",
        "lost","nshocks","nglitches","deadserversactive","deadserversall",
        "docsokay","auditmajority","auditminority","auditlost","auditrepairs",
        "auditcycles")
    coreResultVarNames<- c("docslost","docsrepairedmajority",
        "docsrepairedminority")
    paramVarNames<- setdiff(setdiff(allVarNames, resultVarNames), ignoreVarNames)
    testVarNames<-c("copies", "lifem")
    nonIgnoreVarNames<-setdiff(allVarNames, ignoreVarNames)

    # Select, group, and aggregate.
    sims.selected.df <- sims.merged.df[nonIgnoreVarNames]
    gp_sims.merged<-eval(parse(text=paste("group_by(sims.selected.df,",
        paste(collapse=",", paramVarNames),")")))
    results <- summarise(gp_sims.merged,
                mdmlosspct=round(midmean(docslost/docstotal)*100,1), n=n())
    selectedresults <- results[which(results[["copies"]]!=1),]

    return(results)
}

# f n d f G e t S u b s e t D a t a
fndfGetSubsetData <- function(results, lColumnNames)
{
    subset <- results[lColumnNames]
    return(subset)
}

# f n d f G e t A u d i t D a t a
fndfGetAuditData <- function(results)
{
    # Specific to audit analyses:
    lNamesIWant <- c("copies","lifem","mdmlosspct",
                    "auditfrequency","auditsegments",
                                            #"audittype", too, needs fixed
                    "docsize","shelfsize")
    results.narrow <- fndfGetSubsetData(results, lNamesIWant)
    results.plausible <- results.narrow[results.narrow$lifem>=2,]
    return(results.plausible)
}

# f n d f G e t S h o c k D a t a
fndfGetShockData <- function(results)
{
    # Specific to shock analyses:
    lNamesIWant <- c("copies","lifem","mdmlosspct",
                    "shockfreq","shockimpact","shockmaxlife","shockspan",
                    "docsize","shelfsize")
    shockresults <- results[lNamesIWant]
    return(shockresults)
}

# f n d f G e t G l i t c h D a t a
fndfGetGlitchData <- function(results)
{
    # Specific to shock analyses:
    lNamesIWant <- c("copies","lifem","mdmlosspct",
                    "glitchfreq","glitchspan","glitchimpact","glitchmaxlife",
                    "docsize","shelfsize")
    shockresults <- results[lNamesIWant]
    return(shockresults)
}

# f n d f G e t D o c s i z e D a t a
fndfGetDocsizeData <- function(results)
{
    lNamesIWant <- c("copies","lifem","mdmlosspct",
                    "auditfreq","auditsegments",
                                            #"audittype", too, needs fixed
                    "docsize","shelfsize")
}

# f n d f G e t S h e l f s i z e D a t a
fndfGetShelfsizeData <- function(results)
{
    lNamesIWant <- c("copies","lifem","mdmlosspct",
                    "auditfreq","auditsegments",
                                            #"audittype", too, needs fixed
                    "docsize","shelfsize")
}

# Edit history:
# 20171002  RBL Copy from Altman original ExploreGiantOutputs.r.
#               Add functions to select data for specific analyses.
#
#