## ########################################### ##
##         SOFTWARE LICENSE AGREEMENT          ##
## ########################################### ##

# This work is licensed under a Creative Commons Attribution 4.0 International License.
# See http://creativecommons.org/licenses/by/4.0/ for details on license restrictions.
# Please attribute any work that makes use or is derived from this work
#   by refering to https://github.com/jalmar/openmx-models

## ########################################### ##
##             DESCRIPTION OF FILE             ##
## ########################################### ##

# In this R script, a measurement model with two latent factors (nf=2) is provided.
# This measurement model can be used to obtain a estimate of the association between
# the reliable components of two constructs that is free of random measurement error.
# In this example, there are two constructs with a total of three observed variables (nv=3).
# Two parallel scores "M1_H1" and "M1_H2" are available for the first construct "M1".
# The first latent factor "F1" is derived from these two parallel scores.
# Since the two parallel scores are measurements of the same construct,
# their expected means are constrained to be equal.
# The second latent factor "F1" is derived from the single score of the second construct "M2".
# If there are repeated measurements of the second construct "M2", the measurement model
# can easily be expanded for reliablity modelling of the second construct "M2".
# The quality of the fit is assessed with the Comparative Fit Index (CFI),
# the Tucker-Lewis Index (TLI), and the Root Mean Square Error of the Approximation (RMSEA).
# These fit indices are based on the comparison between the measurement model to
# a saturated model and an independence (or null) model. The saturated model is a model that
# estimates all means, variances and covariances freely for all variables (i.e. unconstrained).
# The independence model estimates only the means and variances with covariances fixed to zero.
# Finally, a summary of the most relevant parameters is printed.
# For more details, see https://github.com/jalmar/openmx-models/reliability

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

## ########################################### ##
##       LOAD LIBRARIES AND SET OPTIONS        ##
## ########################################### ##

## load OpenMx library
require(OpenMx) # SEM
options(warn=1)

## ########################################### ##
##    INPUT DATASETS AND SELECTED VARIABLES    ##
## ########################################### ##

## INPUT: a data frame data_df with the parallel and single scores measurements
data_df <- readRDS("ExampleData.rds")
selVars <- c("FC_Z_H1", "FC_Z_H2", "BHV")

## ########################################### ##
##      CALCULATE MEANS AND (CO)VARIANCES      ##
## ########################################### ##

## calculate initial mean and variance of measures
init_means <- apply(data_df[,selVars, drop=F], 2, mean, na.rm=T)
init_vars <- apply(data_df[,selVars, drop=F], 2, var, na.rm=T)
init_sds <- apply(data_df[,selVars, drop=F], 2, sd, na.rm=T)

## calculate initial covariance matrices between measures
init_covars <- var(data_df[,selVars, drop=F], na.rm=T)
init_corrs <- cor(data_df[,selVars, drop=F], method="pearson", use="pairwise.complete.obs")

## ########################################### ##
##        MEASUREMENT MODEL PARAMETERS         ##
## ########################################### ##

## number of observed variables
nf=2 # number of factors
nv=3 # number of measurements

## initial guess at factor variances [nf x nf matrices]; NOTE: standardized symmetric matrix with variances on diagnoal fixed to 1.0!
# initialize with rough estimate of expected correlation; e.g. corr(M1_H1, M2)
init_factor_variance_values = c(1.0, 0.5,
                                0.5, 1.0)
init_factor_variance_paths = c(F, T,
                               T, F)
init_factor_variance_labels = c("varF1", "covF12",
                                "covF12", "varF2")

## loading of factors on the measures [nf x nv matrices]:
# factor 1 loads on the two parallel scores of measure 1
# factor 2 loads on the single score of measure 2
# initialize with rough estimate of factor loadings; e.g. cov(M1_H1, M1_H2))
init_factor_loading_values = c(0.70, 0.70, 0.00, # factor 1
                               0.00, 0.00, 1.00) # factor 2
init_factor_loading_paths = c(T, T, F, # factor 1
                              F, F, F) # factor 2; NOTE: third position fixed for single score measurement
init_factor_loading_labels = c("f1", "f1", NA, # factor 1
                                NA,   NA, "f2") # factor 2

## loadings of residual variances on the measures [1 x nv matrices]
# initialize with rough estimate of residual variance; e.g. 1 - sqrt(corr(M1_H1, M1_H2)) or 1 - factor loading
init_es_loading_values = c(0.30, 0.30, 0.00)
init_es_loading_paths = c(T, T, F) # NOTE: third position fixed for single score measurement
init_es_loading_labels = paste0("es", 1:nv)

## restrict the means of variables to be equal through shared labels [1 x nv matrices]
# Here, the means for parallel scores of the same construct are contrained to be equal
init_means_labels = c("mean_FC_Z", "mean_FC_Z", "mean_BHV")

## ########################################### ##
##  OPENMX SPECIFICATION OF MEASUREMENT MODEL  ##
## ########################################### ##

## measurement model
MeasurementModel <- mxModel("mm",

    # variance matrix Vf to store total variance for latent phenotypic factor; NOTE: standardized with variance on diagonals fixed to 1.0
    mxMatrix(type="Full", nrow=nf, ncol=nf, free=init_factor_variance_paths, values=init_factor_variance_values, labels=init_factor_variance_labels, name="Vf", lbound=-1, ubound=1),

    # matrices for correlations between latent factors (only nf>1)
    mxMatrix(type="Iden", ncol=nf, nrow=nf, name="Idnf"), # identity matrix of size nf x nf
    mxAlgebra(expression=solve(sqrt(Idnf*Vf)) %*% Vf %*% solve(sqrt(Idnf*Vf)), name="Rphf"),

    # matrix fs to store path coefficients for latent phenotypic factors loading on observed variables
    mxMatrix(type="Full", nrow=nv, ncol=nf, free=init_factor_loading_paths, values=init_factor_loading_values*init_vars, labels=init_factor_loading_labels, name="fs", lbound=0),

    # matrix es to store path coefficients for measurement-specific factors loading on each measurement; NOTE: fixing off-diagonals to zero assumes no correlation between residual variances of measurements
    mxMatrix(type="Diag", nrow=nv, ncol=nv, free=init_es_loading_paths, values=init_es_loading_values*init_vars, labels=init_es_loading_labels, name="es", lbound=0),

    # matrix Es to store variance for measurement-specific factors
    mxAlgebra(expression=es%*%t(es), name="Es"),

    # total variance of the measures is the proportion of variance explained by the factor(s) plus residual variances
    mxAlgebra(expression=fs%&%Vf+Es, name="Vm"), # (co)variances between the measures
    mxMatrix(type="Iden", nrow=nv, ncol=nv, free=F, name="Inv"),
    mxAlgebra(expression=solve(sqrt(Inv*Vm)), name="SDm"), # standard deviation of the measures

    # phenotypic correlation between measures
    mxAlgebra(expression=solve(sqrt(Inv*Vm)) %*% Vm %*% solve(sqrt(Inv*Vm)), name="Rphm"),

    # standardized estimates for loadings on latent factor
    mxAlgebra(expression=SDm%*%fs, "Fs_std"),
    mxAlgebra(expression=Fs_std*Fs_std, "Fs_std2"),

    # standardized estimates for measurement-specific factors
    mxAlgebra(expression=SDm%*%es, name="Es_std"),
    mxAlgebra(expression=Es_std*Es_std, name="Es_std2"),

    # observed data of subjects
    mxData(observed=data_df, type="raw"),

    # expected means vector
    mxMatrix(type="Full", nrow=1, ncol=nv, free=T, values=init_means, labels=init_means_labels, name="expMeans"),

    # expected covariance matrix; NOTE: %&% is quadratic product (A %&% B == ABA'); same as Vm
    mxAlgebra(expression=mm.fs %&% mm.Vf + mm.Es, name="expCov"),

    # optimization objective
    mxExpectationNormal(means="expMeans", covariance="expCov", dimnames=selVars),
    mxFitFunctionML(),

    # calculate confidence intervals of freely estimated parameters
    mxCI(sprintf("mm.Fs_std2[%s]", apply(which(matrix(init_factor_loading_paths, nrow=nv, ncol=nf), arr.ind = TRUE), MARGIN=1, paste0, collapse=",")), interval = 0.95, type="both"), # standardized factor loadings
    mxCI(sprintf("mm.Rphf[%s]", apply(which(lower.tri(matrix(1,nf,nf)), arr.ind = TRUE), MARGIN=1, paste0, collapse=",")), interval = 0.95, type="both"), # correlation between factors
    mxCI(sprintf("mm.Rphm[%s]", apply(which(lower.tri(matrix(1,nv,nv)), arr.ind = TRUE), MARGIN=1, paste0, collapse=",")), interval = 0.95, type="both") # correlation between measures

) # END of mxModel MeasurementModel

## assign first value to parameters with same labels but different starting values
MeasurementModel <- omxAssignFirstParameters(MeasurementModel)

## ########################################### ##
##          FIT THE MEASUREMENT MODEL          ##
## ########################################### ##

MeasurementModelFit <- mxTryHard(MeasurementModel, extraTries=30, checkHess=F, intervals=T, silent=T)

## ########################################### ##
##  EXTRACT PARAMETERS OF INTEREST FROM MODEL  ##
## ########################################### ##

## summary of measurement model model fit
print(summary(MeasurementModelFit))

## corrected/reliable association between the two constructs
message(sprintf("Corrected association between the two constructs = %0.3f [%0.3f; %0.3f]", MeasurementModelFit$output$algebras$mm.Rphf[2,1], MeasurementModelFit$output$confidenceIntervals["mm.Rphf[2,1]","lbound"], MeasurementModelFit$output$confidenceIntervals["mm.Rphf[2,1]","ubound"]))

## standardized factor loading on parallel scores of the first construct
message(sprintf("Standardized factor loading on first parallel score = %2.1f%% [%2.1f%%; %2.1f%%]", MeasurementModelFit$output$algebras$mm.Fs_std2[1,1]*100, MeasurementModelFit$output$confidenceIntervals["mm.Fs_std2[1,1]","lbound"]*100, MeasurementModelFit$output$confidenceIntervals["mm.Fs_std2[1,1]","ubound"]*100))
message(sprintf("Standardized factor loading on second parallel score = %2.1f%% [%2.1f%%; %2.1f%%]", MeasurementModelFit$output$algebras$mm.Fs_std2[2,1]*100, MeasurementModelFit$output$confidenceIntervals["mm.Fs_std2[2,1]","lbound"]*100, MeasurementModelFit$output$confidenceIntervals["mm.Fs_std2[2,1]","ubound"]*100))

## test-retest reliability between the two parallel scores
message(sprintf("Test-retest reliability between the two parallel scores = %0.3f [%0.3f; %0.3f]", MeasurementModelFit$output$algebras$mm.Rphm[2,1], MeasurementModelFit$output$confidenceIntervals["mm.Rphm[2,1]","lbound"], MeasurementModelFit$output$confidenceIntervals["mm.Rphm[2,1]","ubound"]))

## uncorrected associations of the individual parallel scores with the second measurement
message(sprintf("Uncorrected association between the first parallel score and second construct = %0.3f [%0.3f; %0.3f]", MeasurementModelFit$output$algebras$mm.Rphm[3,1], MeasurementModelFit$output$confidenceIntervals["mm.Rphm[3,1]","lbound"], MeasurementModelFit$output$confidenceIntervals["mm.Rphm[3,1]","ubound"]))
message(sprintf("Uncorrected association between the second parallel score and second construct = %0.3f [%0.3f; %0.3f]", MeasurementModelFit$output$algebras$mm.Rphm[3,2], MeasurementModelFit$output$confidenceIntervals["mm.Rphm[3,2]","lbound"], MeasurementModelFit$output$confidenceIntervals["mm.Rphm[3,2]","ubound"]))

## ########################################### ##
##          DETERMINE GOODNESS OF FIT          ##
## ########################################### ##

## specification of the saturated model
SaturatedModel <- mxModel("sat",

    # expected (co)variance matrix; unconstrained variances and covariance estimates
    mxMatrix(type="Symm", nrow=nv, ncol=nv, free=T, values=vech(init_covars), name="expCov"),

    # observed data of subjects
    mxData(observed=data_df, type="raw"),

    # expected means vector; unconstrained means estimates
    mxMatrix(type="Full", nrow=1, ncol=nv, free=T, values=init_means, labels=paste0("mean_m",1:nv), name="expMeans"),

    # optimization objective
    mxExpectationNormal(means="expMeans", covariance="expCov", dimnames=selVars),
    mxFitFunctionML()

) # END of mxModel SaturatedModel

SaturatedModel <- omxAssignFirstParameters(SaturatedModel)

## specification of the independence/null model
IndependenceModel <- mxModel("indep",

    # expected (co)variance matrix; unconstrained variances and covariance estimates
    mxMatrix(type="Diag", nrow=nv, ncol=nv, free=T, values=init_vars, name="expCov"),

    # observed data of subjects
    mxData(observed=data_df, type="raw"),

    # expected means vector; same means constraints as substantive model
    mxMatrix(type="Full", nrow=1, ncol=nv, free=T, values=init_means, labels=init_means_labels, name="expMeans"),

    # optimization objective
    mxExpectationNormal(means="expMeans", covariance="expCov", dimnames=selVars),
    mxFitFunctionML()

) # END of mxModel IndependenceModel

IndependenceModel <- omxAssignFirstParameters(IndependenceModel)

## fit saturated and independence model
SaturatedModelFit <- mxTryHard(SaturatedModel, extraTries=10, checkHess=F, intervals=F)
IndependenceModelFit <- mxTryHard(IndependenceModel, extraTries=10, checkHess=F, intervals=F)

## print goodness of fit indices
tmp_summary <- summary(MeasurementModelFit, refModels=list(Saturated=SaturatedModelFit, Independence=IndependenceModelFit))
message(sprintf("Goodness of fit indices are CFI=%0.3f, TLI=%0.3f, and RMSEA=%0.3f", tmp_summary$CFI, tmp_summary$TLI, tmp_summary$RMSEA))


library(MutationalPatterns)
#filename <- "C:\\Users\\tuf78332\\Desktop\\CancerSoftware\\sigLASSO-master\\sigLASSO-master\\data\\signatures_probabilities.txt"
#'C:\\Users\\tuf78332\\Desktop\\mutational-signature\\PhyloSig\\PhyloSig1\\cosmicSig.csv'
#cancer_signatures <- read.table(filename, sep = "\t", header = TRUE)

#mut_mat=read.delim('MUTCOUNTIN',sep=',',header=FALSE,check.names=FALSE) #C:\\Users\\tuf78332\\Desktop\\mutational-signature\\PhyloSig\\Example\\E.csv
#colnames(mut_mat) <- c('Type','Count')
#order = match(mut_mat$Type, cancer_signatures$Somatic.Mutation.Type)
#cancer_signatures = cancer_signatures[order,]
#cancer_signatures = as.matrix(cancer_signatures[,4:33])
#colnames(cancer_signatures) = as.character(1:30)
#mut_mat1=data.frame(mut_mat$Count)
#fit_res <- fit_to_signatures(mut_mat1, cancer_signatures)
#write.table(fit_res$contribution/sum(mut_mat$Count),'Expo.out')

########
filename <-'SIGIN'#'C:\\Users\\tuf78332\\Desktop\\mutational-signature\\PhyloSig\\PhyloSig1\\cosmicSig.csv'
cancer_signatures <- read.table(filename, sep=',',header = TRUE)
cancer_signatures=cancer_signatures[,c('X','SIGLS')]
colnames(cancer_signatures)[colnames(cancer_signatures)=="X"] <- "Somatic.Mutation.Type"
mut_mat=read.delim('MUTCOUNTIN',sep=',',header=FALSE,check.names=FALSE) #C:\\Users\\tuf78332\\Desktop\\mutational-signature\\PhyloSig\\Example\\E.csv
colnames(mut_mat) <- c('Type','Count')
order = match(mut_mat$Type, cancer_signatures$Somatic.Mutation.Type)
cancer_signatures = cancer_signatures[order,]
cancer_signatures = as.matrix(cancer_signatures[,2:ncol(cancer_signatures)])
colnames(cancer_signatures) = as.character(1:ncol(cancer_signatures))
mut_mat1=data.frame(mut_mat$Count)
fit_res <- fit_to_signatures(mut_mat1, cancer_signatures)
write.table(fit_res$contribution/sum(mut_mat$Count),'Expo.out')


# This script cannot be run on linux's conda (as lwgeom is not uploaded to package)
setwd('C:/Dev/msc-thesis-code/2019-05-28-spatial-layers')
# setwd('mnt/c/Dev/msc-thesis-code/2019-05-28-spatial-layers')

library(tidyverse)
library(sf)

# Merge IDN to country level as it is missing
region = read_sf("../data/geo/1_separate/gadm/shp_sec/gadm36_IDN_1.shp")
region %>%
  st_set_geometry(NULL) %>%
  glimpse()

region$area = st_area(region)

ind =
  region %>%
  summarise(NAME_0="Indonesia", GID_0="IDN")

st_write(ind, "../data/geo/1_separate/gadm/shp_pri/gadm36_IDN_0.shp", driver="ESRI Shapefile")


library("ggplot2")
library("plyr")

results <- read.csv2("../output/output.csv", row.names = NULL)

testset = ddply(results, c("Tool", "RunIndex", "ChangeSet", "View"), MetricValue=max(MetricValue))
testset = ddply(testset, c("Tool", "ChangeSet", "View"), summarize, Memory=mean(MetricValue)/(1024*1024))

pointSize = 3
lineSize = 1

bwTheme <- theme(text=element_text(family="Helvetica", size=16),
                 panel.background = element_rect(fill="#FFFFFF"),
                 legend.position="bottom",
                 legend.direction="horizontal",
                 panel.grid.major = element_line(size=0.3, colour="#333333"),
                 panel.grid.minor = element_line(size=0.15, colour="#CCCCCC"),
                 axis.text.x = element_text(colour="black"),
                 axis.text.y = element_text(colour="black"),
                 legend.position="right"
)

for (query in unique(testset$View)) {

  data = subset(testset, View==query)

  sizes <- unique(data$ChangeSet)
  minValue <- min(data$Memory)
  maxValue <- max(data$Memory)

plot <- ggplot(data, aes_string(x="ChangeSet",y="Memory"))
plot <- plot + geom_line(aes_string(group="Tool",colour="Tool"),size=lineSize)
plot <- plot + geom_point(aes_string(shape="Tool", colour="Tool"), size=pointSize)
plot <- plot + scale_shape_manual(values=1:4) + ylab("Memory (Mbyte)")
plot <- plot + xlab("ChangeSet")
plot <- plot + bwTheme
plot <- plot + scale_y_log10(breaks = 10^seq(round(log10(minValue)), round(log10(maxValue)), by=1),
                             labels = 10^seq(round(log10(minValue)), round(log10(maxValue)), by=1))
plot <- plot + ggtitle(paste(query, ", working set", sep=""))

ggsave(plot, filename=paste(query, "-memory.pdf", sep=""), width=7, height=4, dpi=192)
}


dataPts <- read.csv('Output.csv')

plot(dataPts$X, dataPts$Y,
	 col='blue', pch=16,
	 main='Polynomial Regression',
	 xlab='X', ylab='Y')
lines(dataPts$X, dataPts$Yh, col='red')

l <- c('Ground truth', 'Hypothesis')
legend('bottomright', legend=l, col=c('blue', 'red'), pch=16)


library(tidyr)
library(dplyr)
library(rstan)
library(data.table)
library(lubridate)
library(gdata)
library(EnvStats)
library(matrixStats)
library(scales)
library(gridExtra)
library(ggpubr)
library(bayesplot)
library(cowplot)
library(ggplot2)

source("nature/utils/geom-stepribbon.r")
#---------------------------------------------------------------------------
make_three_panel_plot <- function(filename){

  print(sprintf("loading: %s",paste0("nature/results/",filename,'-stanfit.Rdata')))
  load(paste0("nature/results/", filename,'-stanfit.Rdata'))
  out <- rstan::extract(fit)
  covariates = readRDS('nature/data/interventions.rds')

  for(i in 1:length(countries)){
    print(i)
    N <- length(dates[[i]])
    country <- countries[[i]]

    predicted_cases <- colMeans(prediction[,1:N,i])
    predicted_cases_li <- colQuantiles(prediction[,1:N,i], probs=.025)
    predicted_cases_ui <- colQuantiles(prediction[,1:N,i], probs=.975)
    predicted_cases_li2 <- colQuantiles(prediction[,1:N,i], probs=.25)
    predicted_cases_ui2 <- colQuantiles(prediction[,1:N,i], probs=.75)

    estimated_deaths <- colMeans(estimated.deaths[,1:N,i])
    estimated_deaths_li <- colQuantiles(estimated.deaths[,1:N,i], probs=.025)
    estimated_deaths_ui <- colQuantiles(estimated.deaths[,1:N,i], probs=.975)
    estimated_deaths_li2 <- colQuantiles(estimated.deaths[,1:N,i], probs=.25)
    estimated_deaths_ui2 <- colQuantiles(estimated.deaths[,1:N,i], probs=.75)

    rt <- colMeans(out$Rt_adj[,1:N,i])
    rt_li <- colQuantiles(out$Rt_adj[,1:N,i],probs=.025)
    rt_ui <- colQuantiles(out$Rt_adj[,1:N,i],probs=.975)
    rt_li2 <- colQuantiles(out$Rt_adj[,1:N,i],probs=.25)
    rt_ui2 <- colQuantiles(out$Rt_adj[,1:N,i],probs=.75)

    # delete these 2 lines
    covariates_country <- covariates[which(covariates$Country == country), 2:6]
    covariates_country_long <- gather(covariates_country, key = "key",
                                      value = "value")
    covariates_country_long$x <- rep(NULL, length(covariates_country_long$key))
    un_dates <- unique(covariates_country_long$value)

    for (k in 1:length(un_dates)){
      idxs <- which(covariates_country_long$value == un_dates[k])
      max_val <- round(max(rt_ui)) + 0.3
      for (j in idxs){
        covariates_country_long$x[j] <- max_val
        max_val <- max_val - 0.3
      }
    }

    covariates_country_long$value <- as_date(covariates_country_long$value)
    covariates_country_long$country <- rep(country,
                                           length(covariates_country_long$value))

    data_country <- data.frame("time" = as_date(as.character(dates[[i]])),
                               "country" = rep(country, length(dates[[i]])),
                               "reported_cases" = reported_cases[[i]],
                               "reported_cases_c" = cumsum(reported_cases[[i]]),
                               "predicted_cases_c" = cumsum(predicted_cases),
                               "predicted_min_c" = cumsum(predicted_cases_li),
                               "predicted_max_c" = cumsum(predicted_cases_ui),
                               "predicted_cases" = predicted_cases,
                               "predicted_min" = predicted_cases_li,
                               "predicted_max" = predicted_cases_ui,
                               "predicted_min2" = predicted_cases_li2,
                               "predicted_max2" = predicted_cases_ui2,
                               "deaths" = deaths_by_country[[i]],
                               "deaths_c" = cumsum(deaths_by_country[[i]]),
                               "estimated_deaths_c" =  cumsum(estimated_deaths),
                               "death_min_c" = cumsum(estimated_deaths_li),
                               "death_max_c"= cumsum(estimated_deaths_ui),
                               "estimated_deaths" = estimated_deaths,
                               "death_min" = estimated_deaths_li,
                               "death_max"= estimated_deaths_ui,
                               "death_min2" = estimated_deaths_li2,
                               "death_max2"= estimated_deaths_ui2,
                               "rt" = rt,
                               "rt_min" = rt_li,
                               "rt_max" = rt_ui,
                               "rt_min2" = rt_li2,
                               "rt_max2" = rt_ui2)

    make_plots(data_country = data_country,
               covariates_country_long = covariates_country_long,
               filename = filename,
               country = country)

  }
}

#---------------------------------------------------------------------------
make_plots <- function(data_country, covariates_country_long,
                       filename, country){

  if (country == 'United_Kingdom')
    country = 'United Kingdom'
  data_cases_95 <- data.frame(data_country$time, data_country$predicted_min,
                              data_country$predicted_max)
  names(data_cases_95) <- c("time", "cases_min", "cases_max")
  data_cases_95$key <- rep("nintyfive", length(data_cases_95$time))
  data_cases_50 <- data.frame(data_country$time, data_country$predicted_min2,
                              data_country$predicted_max2)
  names(data_cases_50) <- c("time", "cases_min", "cases_max")
  data_cases_50$key <- rep("fifty", length(data_cases_50$time))
  data_cases <- rbind(data_cases_95, data_cases_50)
  levels(data_cases$key) <- c("ninetyfive", "fifty")

  p1 <- ggplot(data_country) +
    geom_bar(data = data_country, aes(x = time, y = reported_cases),
             fill = "coral4", stat='identity', alpha=0.5) +
    geom_ribbon(data = data_cases,
                aes(x = time, ymin = cases_min, ymax = cases_max, fill = key)) +
    xlab("") +
    ylab("Daily number of infections\n") +
    scale_x_date(date_breaks = "weeks", labels = date_format("%e %b")) +
    scale_y_continuous(expand = c(0, 0), labels = comma) +
    scale_fill_manual(name = "", labels = c("50%", "95%"),
                      values = c(alpha("deepskyblue4", 0.55),
                                 alpha("deepskyblue4", 0.45))) +
    theme_pubr(base_family="sans") +
    theme(axis.text.x = element_text(angle = 45, hjust = 1),
          legend.position = "None") + ggtitle(country) +
    guides(fill=guide_legend(ncol=1))

  data_deaths_95 <- data.frame(data_country$time, data_country$death_min,
                               data_country$death_max)
  names(data_deaths_95) <- c("time", "death_min", "death_max")
  data_deaths_95$key <- rep("nintyfive", length(data_deaths_95$time))
  data_deaths_50 <- data.frame(data_country$time, data_country$death_min2,
                               data_country$death_max2)
  names(data_deaths_50) <- c("time", "death_min", "death_max")
  data_deaths_50$key <- rep("fifty", length(data_deaths_50$time))
  data_deaths <- rbind(data_deaths_95, data_deaths_50)
  levels(data_deaths$key) <- c("ninetyfive", "fifty")

  p2 <-   ggplot(data_country, aes(x = time)) +
    geom_bar(data = data_country, aes(y = deaths, fill = "reported"),
             fill = "coral4", stat='identity', alpha=0.5) +
    geom_ribbon(
      data = data_deaths,
      aes(ymin = death_min, ymax = death_max, fill = key)) +
    scale_x_date(date_breaks = "weeks", labels = date_format("%e %b")) +
    scale_y_continuous(expand = c(0, 0), labels = comma) +
    scale_fill_manual(name = "", labels = c("50%", "95%"),
                      values = c(alpha("deepskyblue4", 0.55),
                                 alpha("deepskyblue4", 0.45))) +
    ylab("Daily number of deaths\n") +
    xlab("") +
    theme_pubr(base_family="sans") +
    theme(axis.text.x = element_text(angle = 45, hjust = 1),
          legend.position = "None") +
    guides(fill=guide_legend(ncol=1))

  plot_labels <- c("Complete lockdown",
                   "Public events banned",
                   "School closure",
                   "Self isolation",
                   "Social distancing")

  # Plotting interventions
  data_rt_95 <- data.frame(data_country$time,
                           data_country$rt_min, data_country$rt_max)
  names(data_rt_95) <- c("time", "rt_min", "rt_max")
  data_rt_95$key <- rep("nintyfive", length(data_rt_95$time))
  data_rt_50 <- data.frame(data_country$time, data_country$rt_min2,
                           data_country$rt_max2)
  names(data_rt_50) <- c("time", "rt_min", "rt_max")
  data_rt_50$key <- rep("fifty", length(data_rt_50$time))
  data_rt <- rbind(data_rt_95, data_rt_50)
  levels(data_rt$key) <- c("ninetyfive", "fifth")

  p3 <- ggplot(data_country) +
    geom_stepribbon(data = data_rt, aes(x = time, ymin = rt_min, ymax = rt_max,
                                        group = key,
                                        fill = key)) +
    geom_hline(yintercept = 1, color = 'black', size = 0.1) +
    geom_segment(data = covariates_country_long,
                 aes(x = value, y = 0, xend = value, yend = max(x)),
                 linetype = "dashed", colour = "grey", alpha = 0.75) +
    geom_point(data = covariates_country_long, aes(x = value,
                                                   y = x,
                                                   group = key,
                                                   shape = key,
                                                   col = key), size = 2) +
    xlab("") +
    ylab(expression(R[t])) +
    scale_fill_manual(name = "", labels = c("50%", "95%"),
                      values = c(alpha("seagreen", 0.75), alpha("seagreen", 0.5))) +
    scale_shape_manual(name = "Interventions", labels = plot_labels,
                       values = c(21, 22, 23, 24, 25, 12)) +
    scale_colour_discrete(name = "Interventions", labels = plot_labels) +
    scale_x_date(date_breaks = "weeks", labels = date_format("%e %b"),
                 limits = c(data_country$time[1],
                            data_country$time[length(data_country$time)])) +
    scale_y_continuous(expand = c(0,0.1)) +
    theme_pubr(base_family="sans") +
    theme(axis.text.x = element_text(angle = 45, hjust = 1)) +
    theme(legend.position="right")
  p <- plot_grid(p1, p2, p3, ncol = 3, rel_widths = c(1, 1, 2))
  save_plot(filename = paste0("nature/figures/", country, "-three-pannel-", filename, ".png"),
            p, base_width = 14)
}


library(geojsonio)
library(leaflet)
library(ggmap)
library(dplyr)
library(sp)

df <- as.data.frame(read.csv("../data/WashingtonSenateContributions.csv", stringsAsFactors = FALSE))

map <- df %>% group_by(State) %>% summarize(total = sum(Amount))

state.abb2 <- c(state.abb, "DC")
map <- map[ map$State %in% state.abb2, ]
state.name2 <- c(state.name, "District of Columbia")
map$State <- state.name2[match(map$State, state.abb2)]
map <- select(map, State, total)

value.max <- map %>% filter_(paste0("total",' == max(',"total",')')) %>% select_("total")
value.max <- max(map$total)
bins <- seq(0, value.max,length=5)

colnames(map) <- c("name","total")
BuildUSMap(map, "total",map.label = "%s
$%g in Contributions")

# Builds a US Choropleth Map at the NATIONAL (values by state) level.
# dataframe name, total
BuildUSMap <- function(df, values = "total", map.label = "%s
$%g in Contributions") {
  # Creates a spatial polygon dataframe --> for mapping
  states <- geojson_read("../json/us-states.json", what = "sp")

  # Get max value of the passed in dataframe
  value.max <- max(df$total)

  # Merge state polygon with state values.
  state.data <- sp::merge(states, df, by = "name")

  # Create "bins" legend intervals
  bins <- seq(0, value.max,length=8)

  # Create colors
  pal <- colorBin("Greens", domain = state.data$total, bins = bins)

  # Create Labels
  labels <- sprintf(
    map.label,
    state.data$name, state.data$total
  ) %>% lapply(htmltools::HTML)

  leaflet(state.data) %>%
    setView(-96, 37.8, 4) %>%
    addProviderTiles(providers$CartoDB.Positron) %>%
    addPolygons(
      fillColor = ~pal(total),
      weight = 2,
      opacity = 1,
      color = "white",
      dashArray = "3",
      fillOpacity = 0.7,
      highlight = highlightOptions(
        weight = 5,
        color = "#666",
        dashArray = "",
        fillOpacity = 0.7,
        bringToFront = TRUE),
      label = labels,
      labelOptions = labelOptions(
        style = list("font-weight" = "normal", padding = "3px 8px"),
        textsize = "15px",
        direction = "auto")) %>%
    addLegend(pal = pal, values = ~total, opacity = 0.7, title = NULL,
              position = "bottomright") %>%
    return()
}


#clearing the workspace
rm(list=ls())
graphics.off()
options(show.error.locations = TRUE)

# if we are in a stand alone distribution we run from there
# otherwise we try to load the package
if(file.exists(file.path('library', 'r_general', 'ubiquity.R'))){
  source(file.path('library', 'r_general', 'ubiquity.R'))
} else {
  library(ubiquity) }

# Rebuilding the system (R scripts and compiling C code)
cfg = build_system(output_directory     = file.path(".", "output"),
                   temporary_directory  = file.path(".", "transient"))

# set name   | Description
# -------------------------------------------------------
# default    | mAb in Humans
# Selecting the default paraemter set
cfg = system_select_set(cfg, 'default')

# Fetching the parameter values
parameters = system_fetch_parameters(cfg)

# To overwrite the default dosing uncomment
cfg = system_zero_inputs(cfg)
cfg = system_set_bolus(cfg, state = "At",
                           times  = c(  0.0,  14.0,  28.0),
                           values = c(400.0, 400.0, 400.0))

# The following applies to both individual and stochastic simulations:
# Define the solver to use
cfg=system_set_option(cfg,group   = "simulation",
                          option  = "solver",
                          value   = "lsoda")

# Specify the output times
cfg=system_set_option(cfg, group  = "simulation",
                           option = "output_times",
                           value  = seq(0,80,.1))
# -------------------------------------------------------------------------
# Individual Simulation:
som = run_simulation_ubiquity(parameters, cfg)

library(ggplot2)
myfig = ggplot() +
        geom_line(data=som$simout, aes(x=ts.days,   y=C_ng_ml), color="red")  +
        xlab("Time (days)")+
        ylab("C (ng/ml)")
myfig = gg_log10_yaxis(myfig, ylim_min=1e3, ylim_max=3e5)
myfig = prepare_figure("print", myfig)
print(myfig)
# -------------------------------------------------------------------------

ggsave(sprintf('output%ssingle.png', .Platform$file.sep), width=8, height=3.4, plot=myfig)


#
# Exemplo 3
#

# somatorio
valor <- 0
n <- 10
# percorra de 1 até n
for (i in 1:n) {
    valor <- valor + 1
}

cat("A soma e ", valor, "\n")


# Estimates and plots family crown age ranges obtained from the Angiosperm Phylogeny Website.
# The code also plots the mean family crown ages obtained from the Angiosperm Time Tree 2.0 (ATT 2.0).
# Must run scripts 1, 2 and 3.
# Uses additional files.
APWeb <- "Parsed_APWeb.csv" # file in data folder

####### The following chunk of code generates the "Parsed_APWeb.csv" file.
rawAPWeb <- "CGages_APWeb.csv" # file in data folder
ages<-read.table(rawAPWeb,sep=",",header=T)
colnames(ages)
table(ages$FAMILY)
un_node <- as.vector(unique(ages$NODE))
un_node <- un_node[match(rownames(resB_fams),un_node)]
un_clades <- ages[match(un_node,ages$NODE),"FAMILY"]
edades <- c();maximos<-c();minimos <- c()
for (i in 1: length(un_node)){
  cat(i,"\n")
  if(is.na(un_node[i])){ edades <- c(edades, NA);maximos <- c(maximos,NA);minimos <- c(minimos,NA);next}
  if(dim(ages[ages$NODE==un_node[i],])[1]==1){
    edades <- c(edades,mean(as.numeric(ages[ages$NODE==un_node[i],9:11]),na.rm = T))
    maximos <- c(maximos,max(as.numeric(ages[ages$NODE==un_node[i],9:11]),na.rm = T))
    minimos <- c(minimos,min(as.numeric(ages[ages$NODE==un_node[i],9:11]),na.rm = T))
    next}
  edades <- c(edades, mean(ages[ages$NODE==un_node[i],"mean"],na.rm=T))
  maximos <- c(maximos, max(ages[ages$NODE==un_node[i],"mean"],na.rm=T))
  minimos <- c(minimos, min(ages[ages$NODE==un_node[i],"mean"],na.rm=T))
}
data <- data.frame(edades=edades,max=maximos,min=minimos,family_APWeb=un_node,clade=un_clades,family_beast=rownames(resB_fams),beast_age=resB_fams$CG_age_Acal)
data$grupos <- rep(NA,dim(data)[1])
head(data)
data[which(data$clade==1),"grupos"] <- "ANA"
data[which(data$clade==2),"grupos"] <- "Magnoliids"
data[which(data$clade==3),"grupos"] <- "Chlor + Cera"
data[which(data$clade==4),"grupos"] <- "Monocots"
data[which(data$clade==5),"grupos"] <- "Monocots"
data[which(data$clade==6),"grupos"] <- "Eudicots"
data[which(data$clade==7),"grupos"] <- "Eudicots"
data[which(data$clade==8),"grupos"] <- "Eudicots"
data[which(data$clade==9),"grupos"] <- "Eudicots"
data[which(data$clade==10),"grupos"] <- "Eudicots"
data[which(data$clade==11),"grupos"] <- "Eudicots"
data[which(data$clade==12),"grupos"] <- "Eudicots"
data[which(is.na(data$clade)),"grupos"] <- "no data"
write.table(data,file="Parsed_APWeb.csv",sep=",",col.names=T, row.names=T)
##########

data<- read.table(APWeb,sep=",",header=T)
data <- data[order(data$grupos,data$clade),]
unique(data$grupos)->un_clados
tre.pruned <- drop.tip(tre,tip=list[which(duplicated(list_fams))])
tre.pruned<- ladderize(tre.pruned, FALSE)
list <- tre.pruned$tip.label
list_outs <- foreach(i=1:length(list),.combine=c) %do% {strsplit(list,"_")[[i]][2]}
outs<-c("Welwitschiaceae","Pinaceae","Ginkgoaceae","Cupressaceae","Gnetaceae","Cycadaceae")
tre.pruned <- drop.tip(tre.pruned,tip=tre.pruned$tip.label[which(list_outs%in%outs)])
list<-tre.pruned$tip.label
list <- foreach(i=1:length(list),.combine=c) %do% {strsplit(list,"_")[[i]][2]}
bb <- resB_fams[match(list,rownames(resB_fams)),]
match(list,rownames(bb))
print(bb[1:5,];tre.pruned$tip.label[1:5])
list<-tre.pruned$tip.label
list_fams <- foreach(i=1:length(list),.combine=c) %do% {strsplit(list,"_")[[i]][2]}
tre.pruned$tip.label<-list_fams
is.rooted(tre.pruned)
is.ultrametric(tre.pruned)
data[match(tre.pruned$tip.label,data$family_beast),"beast_age"]
data[which(data$family_APWeb=="Chloranthaceae"),c(2:3)]<-NA
data<-data[match(tre.pruned$tip.label,data$family_beast),]
HPD_max <- resB_fams[match(data$family_beast,rownames(resB_fams)),"CG_maxHPD"]
HPD_min <- resB_fams[match(data$family_beast,rownames(resB_fams)),"CG_minHPD"]
data$HPD_max <- HPD_max; data$HPD_min <- HPD_min

pdf(paste(ruta_write,"DatedTree_APWED.pdf"),useDingbats = F,width=21,height = 100)
d1 <- data.frame(id=tre.pruned$tip.label, beast=data[match(tre.pruned$tip.label,data$family_beast),"beast_age"],
                 HPDmax=data[match(tre.pruned$tip.label,data$family_beast),"HPD_max"],
                 HPDmin=data[match(tre.pruned$tip.label,data$family_beast),"HPD_min"])
p <- ggtree(tre.pruned) + geom_tiplab() + ggplot2::xlim(0,250)
p2 <- facet_plot(p, panel="Family crown age estimates", data=d1, geom=geom_point, aes(x=beast),pch=21, bg='red',cex=8)
d2 <- data.frame(id=tre.pruned$tip.label, max=data[match(tre.pruned$tip.label,data$family_APWeb),"max"],min=data[match(tre.pruned$tip.label,data$family_APWeb),"min"])
facet_plot(p2, panel='Family crown age estimates', data=d2, geom=geom_segment, aes(x=min, xend=max, y=y, yend=y), size=5, color = rgb(0,0,0,0.6)) + theme_tree2()
dev.off()


# 데이터: 숫자형(1,2,3), 문자형("문자")

# 데이터 숫자형(1,2,3)

num1 <- c(1,2,3,4,5)

# c 행렬 벡터, 여러개의 변수를 동시에 저장하는 방식
# 변수이름은 하나이지만, 그 안에 공간(주소)을 여러개 만들어 놓는 것
# 들어오는 순서대로 공간을 저장함 => 5개의 방을 저장
# 저장만 된다. 출력은 안된다(명령을 내려서 출력해야 한다)

num1

mode(num1)
typeof(num1)

# double : 소수점 들어가는 것

# 문자형 ("영어")
char1 <- c("male","femamle")
mode(char1)
typeof(char1)

# 문자형("한글")

char2 <- c("남자","여자")

mode(char2)
typeof(char2)


args = commandArgs(TRUE)

category_f=args[1]
outfig=args[2]

library(ggplot2)
dat = read.table(file=category_f, header=F, sep="\t")
dat$V2 = -log10(dat$V2)

#colnames(dat) = c("Category","-log10(pvalue)")

dat$V1 <- factor(dat$V1, levels = dat$V1[order(dat$V2)])

pdf(outfig, width=10,height=4)
p<-ggplot(data=dat, aes(x=V1, y=V2)) +
  geom_bar(stat="identity") +
  ylab("-log10(p-value)") +
  xlab("Category") +
  coord_flip()
p
dev.off()


prune <- function(motif){
  # Arguments:
  #   motif: a tree graph
  # Returns:
  #   a pruned motif
  # 4 colors: 1(black) 2(red) 4(orange)
  # we can only remove black nodes
  # there can be only two black nodes together
  # delete
  parents <- which(degree(motif, mode='in')>2)
  to.delete <- c()
  if(length(parents)==0){
    return(motif)
  }
  # If more than two siblings with no children, keep only the first two
  # (the most ancient)
  for (p in 1:length(parents)){
    siblings <- neighbors(motif, parents[p], mode='in')
    siblings <- siblings[order(V(motif)$date[siblings])]
    siblings.indegree <- degree(motif, v=siblings, mode='in')

    if(length(siblings)<3){
      next
    }
    x <- siblings$color

    counts <- 1
    delete <- rep(FALSE, length(x))
    for(i in 2:length(x)){
      if(x[i] != x[i-1]){
        counts <- 1
      }
      else if(siblings.indegree[i]>0){
        counts <- 1
      }
      else{
        counts <- counts + 1
      }
      cat('\n id:', as.numeric(siblings[i]), '--', counts)
      if(counts>2){
        delete[i] <- TRUE
      }
    }
    to.delete <- union(to.delete, siblings[delete])
  }
  motif <- delete.vertices(motif, to.delete)
  motif
}

i <- 28

par(mfrow=c(4,2))
par(mfrow=c(1,2))

#for (i in 1:length(motifs)){

#for (i in 1:100){

  gmotif <- motifs[[i]]
  if(!any(degree(gmotif, mode='in')>1)){
    next
  }
  mypalette <- c("grey", "red", "white", 'orange')
  if(!any(degree(gmotif, mode='in')>3)){
    next
  }
  #root <- V(gmotif)[which(degree(gmotif, mode='out')==0)]

  gmotif <- as.undirected(gmotif)
  la = layout_as_tree(gmotif, mode='out', root=which.min(as.numeric(V(gmotif)$date)))
  plot(gmotif,
       layout = la,
       vertex.color=mypalette[V(gmotif)$color],
       vertex.label = V(gmotif),#"",
       edge.arrow.size=0.6)
  title(i)

  gmotif <-  prune(motifs[[i]])
  gmotif <- as.undirected(gmotif)

  la = layout_as_tree(gmotif, mode='out', root=which.min(V(gmotif)$date))
  plot(gmotif,
       layout = la,
       vertex.color=mypalette[V(gmotif)$color],
       vertex.label = V(gmotif),#"",
       edge.arrow.size=0.6)
#}

if(FALSE){
  ##########################################
  par(mfrow=c(1,2))
  empty_graph()

  g <- make_empty_graph(n=23)
  g <- add_edges(g, c(2,1,
                      3,2,
                      6,2,
                      5,2,
                      4,2,
                      7,3,
                      8,3,
                      8,9,
                      10,6,
                      11,10,
                      12,10,
                      14,10,
                      15,5,
                      13,10,
                      17,10,
                      18,15,
                      16,15,
                      19,2,
                      20,2,
                      21,2,
                      22,12,
                      23,22))

  mypalette <- c("black", "red", "white", 'orange')
  V(g)$color <- '3'
  V(g)$date <- as.numeric(V(g))
  g_ <- as.undirected(g)
  la = layout_as_tree(g_, mode='out', root=1)
  plot(g_,
       layout = la,
       vertex.color=mypalette[V(g_)$color],
       vertex.label = V(g_)$date,
       edge.arrow.size=0.6)

  g_ <-  prune(g)
  g_ <- as.undirected(g_)

  la = layout_as_tree(g_, mode='out', root=1)
  plot(g_,
       layout = la,
       vertex.color=mypalette[V(g_)$color],
       vertex.label = V(g_)$date ,
       edge.arrow.size=0.6)
}


# R code
# Luis P. F. Garcia 2018
# Read the time series and apply k-fold cross-validation

read <- function(files) {
  data = data.frame(do.call("rbind", lapply(files, read.csv)))
  data$timestamp = as.POSIXct(data$timestamp, format="%Y-%m-%d %H:%M:%OS")
  return(data)
}

sampling <- function(data, hz=15, cores=10) {

  aux = names(table(data$timestamp))

  foo = mclapply(aux, mc.cores=cores, function(i) {
    tmp = subset(data, as.character(timestamp) %in% i)
    vet = seq(1, nrow(tmp), length.out=hz)
    tmp[vet,]
  })

  do.call("rbind", foo)
}

kfold <- function(data) {

  user = unique(data$user)

  tran = lapply(user, function(i) {
    subset(data, user %in% setdiff(user, i))
  })

  test = lapply(user, function(i) {
    subset(data, user %in% i)
  })

  tmp = list()
  tmp$tran = tran
  tmp$test = test
  return(tmp)
}


#' Extract the midpoint of an interval assigned to a data frame.
#'
#' \code{interval_mid} Calculates the mid-point of an interval to be used as an
#' attractive label for plot axes when binning an axis. Intervals as defined by
#' functions such as base-R \code{\link{cut}}.
#'
#' @author Alex M Trueman
#'
#' @param x A numeric vector or data frame column with intervals typically
#'   applied using the base-R \code{cut} function.
#' @param dp A numeric scalar (default 1) defining the number of decimal places
#'   for the base-R \code{round} function. May be needed to ensure that
#'   mid-points are unique.
#' @return A numeric vector containing the mid points of the intervals.
#' @keywords internal
interval_mid <- function(x, dp = 1) {
  # Extract lower and upper bounds of the intervals.
  lower <- as.double(gsub(",.*", "", gsub("\\(|\\[|\\)|\\]", "", x)))
  upper <- as.double(gsub(".*,", "", gsub("\\(|\\[|\\)|\\]", "", x)))
  # Return midpoint.
  return(as.double(round(lower + (upper - lower) / 2, dp)))
}

#' Calculate Data for Contact Analysis
#'
#' \code{contact_data} generates data from domain-coded drillhole data suitable
#' for plotting contact analysis plots. For each possible pairing of categorical
#' domain codes it reports the distance and grade of drillhole samples from each
#' contact of the domain pairing. The distance for the first domain in the
#' pairing ('left' side) is reported as a negative distance for plotting
#' purposes.
#'
#' Uses nested for loops, which is not ideal for speed. I am sure that more can
#' be done by vecorizing one or more loops, but, for now, it works and is fast
#' enought to be practical. For example: the dataset 'dholes' contains 24,673
#' records in 371 drillholes with 13 valid domain contact pairings. This dataset
#' takes <50 seconds to process on a fast laptop (2018 i9 CPU).
#'
#' @param df Data frame with columns defined in the following arguments.
#' @param grade Name of column in \code{df} containing numeric values to be
#'   averaged by contact distance.
#' @param bhid Name of column in \code{df} containing character or numeric
#'   categorical hole ID (default `bhid`) identifying each unique drillhole.
#' @param from,to Name of numeric columns of \code{df} with the downhole
#'   distance to the start and end of sample intervals (defaults \code{from} and
#'   \code{to}).
#' @param x,y,z Name of numeric columns of \code{df} with the cartesian
#'   coordinates of the sample mid-points (defaults \code{x}, \code{y}, and
#'   \code{z}).
#' @param domain Name of the column in \code{df} containing the character or
#'   numeric categorical codes for domains across which contact analysis will be
#'   performed (default \code{domain}).
#' @param pairs Matrix of domain pairs to be used in the contact analysis.
#'   Organized in columns of pairs with two rows each.
#' @param max_dist Positive numeric scalar for the maximum contact distance to
#'   be calculated (default \code{15}).
#' @param min_samp Positive integer scalar for the minimum number of samples on
#'   each side of the contact (default \code{5}). If less than this the data
#'   won't be returned. This helps remove domain pairings with too few data.
#'
#' @return A list of two data frames 'detail' and 'summary'. 'detail' contains
#'   all data points while 'summary' contains mean grade by binned distances.
#' @export
#' @importFrom assertthat assert_that is.scalar
#' @importFrom dplyr group_by select mutate summarise
#' @importFrom magrittr %<>% %>%
#' @importFrom rlang !! .data enquo quo_name
#' @importFrom stats na.omit
#' @importFrom utils combn
#' @examples
#' # Smaller dataset for speed.
#' dholes_sub <- dholes[dholes$domain < 4000,]
#' ca <- contact_data(dholes_sub, grade, max_dist = 20)
#'
#' # Extract only certain contacts from contact data.
#' ca_1100 <- purrr::map(ca, ~dplyr::filter(.x, grepl("1100", contact)))
contact_data <- function(df, grade, bhid = bhid, from = from, to = to,
  x = x, y = y, z= z, domain = domain, max_dist = 15, min_samp = 5,
  pairs = NULL) {

  grade <- enquo(grade)
  grade_str <- quo_name(grade)
  domain <- enquo(domain)
  domain_str <- quo_name(domain)

  # All args passed as symbols (rather than strings) to be consistent.
  bhid_str <- quo_name(enquo(bhid))
  from_str <- quo_name(enquo(from))
  to_str <- quo_name(enquo(to))
  x_str <- quo_name(enquo(x))
  y_str <- quo_name(enquo(y))
  z_str <- quo_name(enquo(z))

  # Assertions on arguments.
  # 'df' is a data frame containing the columns defined by other arguments.
  assert_that(is.data.frame(df),
    msg = "Argument `df` is not a data frame.")
  assert_that(all(
    c(bhid_str, domain_str, grade_str, from_str, to_str, x_str, y_str, z_str)
    %in% colnames(df)),
    msg = paste0(
      "One of the required columns not in the supplied data frame."))
  # 'grade' , 'from', 'to', 'x', 'y', 'z' are all numeric.
  assert_that(is.numeric(df[[grade_str]]),
    msg = "`grade` must be numeric.")
  assert_that(is.numeric(df[[from_str]]),
    msg = "`from` must be numeric.")
  assert_that(is.numeric(df[[to_str]]),
    msg = "`to` must be numeric.")
  assert_that(is.numeric(df[[x_str]]),
    msg = "`x` must be numeric.")
  assert_that(is.numeric(df[[y_str]]),
    msg = "`y` must be numeric.")
  assert_that(is.numeric(df[[z_str]]),
    msg = "`z` must be numeric.")
  # 'max_dist' is positive numeric scalar > 0.
  assert_that(is.scalar(max_dist))
  assert_that(max_dist > 0, msg = "`max_dist` must be > 0")
  # 'min_samp' is positive whole number scalar >= 1.
  assert_that(is.scalar(min_samp))
  assert_that(
    (function(x, tol = .Machine$double.eps^0.5) abs(x - round(x)) < tol)
    (min_samp),
    msg = "`min_samp` must be a whole number")
  assert_that(min_samp >= 1, msg = "`min_samp` must be >= 1")

  all_holes <- sort(unique(df[[bhid_str]]))
  sample_count <- nrow(df)
  cnt <- 0

  for (dom in 1:ncol(pairs)) {
    # Reset for each domain pairing.
    counti <- 0
    countj <- 0
    disti <- rep(NA_real_, sample_count)
    valuei <- rep(NA_real_, sample_count)
    distj <- rep(NA_real_, sample_count)
    valuej <- rep(NA_real_, sample_count)
    for (hole in 1:length(all_holes)) {
      samples <- df[df[[bhid_str]] == all_holes[hole],]
      samples <- samples[order(samples[[from_str]], samples[[to_str]]),]
      count_samples <- nrow(samples)
      # Make sure at least 2 samples in the drillhole.
      if(count_samples < 2) next
      for (sample in 2:count_samples) {
        this_samp <- samples[sample,]
        last_samp <- samples[sample - 1,]
        if (this_samp[[domain_str]] == pairs[2, dom] &
            last_samp[[domain_str]] == pairs[1, dom]) {
          xc <- (this_samp[[x_str]] + last_samp[[x_str]]) * 0.5
          yc <- (this_samp[[y_str]] + last_samp[[y_str]]) * 0.5
          zc <- (this_samp[[z_str]] + last_samp[[z_str]]) * 0.5
          for (consamp in (sample - 1):1) {
            con_samp <- samples[consamp,]
            if (con_samp[[domain_str]] == pairs[1, dom]) {
              d <-
                sqrt(
                  (con_samp[[x_str]] - xc)^2 *
                    (con_samp[[y_str]] - yc)^2 *
                    (con_samp[[z_str]] - zc)^2
                )
              if (d <= max_dist) {
                counti <- counti + 1
                disti[counti] <- d
                valuei[counti] <- con_samp[[grade_str]]
              }
            }
          }
          for (consamp in sample:count_samples) {
            con_samp <- samples[consamp,]
            if (con_samp[[domain_str]] == pairs[2, dom]) {
              d <-
                sqrt(
                  (con_samp[[x_str]] - xc)^2 *
                    (con_samp[[y_str]] - yc)^2 *
                    (con_samp[[z_str]] - zc)^2
                )
              if (d <= max_dist) {
                countj <- countj + 1
                distj[countj] <- d
                valuej[countj] <- con_samp[[grade_str]]
              }
            }
          }
        }
        if (this_samp[[domain_str]] == pairs[1, dom] &
            last_samp[[domain_str]] == pairs[2, dom]) {
          xc <- (this_samp[[x_str]] + last_samp[[x_str]]) * 0.5
          yc <- (this_samp[[y_str]] + last_samp[[y_str]]) * 0.5
          zc <- (this_samp[[z_str]] + last_samp[[z_str]]) * 0.5
          for (consamp in (sample - 1):1) {
            con_samp <- samples[consamp,]
            if (con_samp[[domain_str]] == pairs[2, dom]) {
              d <-
                sqrt(
                  (con_samp[[x_str]] - xc)^2 *
                    (con_samp[[y_str]] - yc)^2 *
                    (con_samp[[z_str]] - zc)^2
                )
              if (d <= max_dist) {
                countj <- countj + 1
                distj[countj] <- d
                valuej[countj] <- con_samp[[grade_str]]
              }
            }
          }
          for (consamp in sample:count_samples) {
            con_samp <- samples[consamp,]
            if (con_samp[[domain_str]] == pairs[1, dom]) {
              d <-
                sqrt(
                  (con_samp[[x_str]] - xc)^2 *
                    (con_samp[[y_str]] - yc)^2 *
                    (con_samp[[z_str]] - zc)^2
                )
              if (d <= max_dist) {
                counti <- counti + 1
                disti[counti] <- d
                valuei[counti] <- con_samp[[grade_str]]
              }
            }
          }
        }
      }
    }
    # Skip to next if not enough samples.
    if(counti < min_samp & countj < min_samp) next
    # Build the detailed dataframe.
    cnt <- cnt + 1
    tempdatai <- data.frame(dist = -disti, value = valuei)
    tempdatai[,"domain"] <- pairs[1, dom]
    tempdataj <- data.frame(dist = distj, value = valuej)
    tempdataj[,"domain"] <- pairs[2, dom]
    tempdata <- na.omit(rbind(tempdatai, tempdataj))
    # Create a contact label with the total number of samples.
    ni <- nrow(tempdata[tempdata[["domain"]] == pairs[1, dom], ])
    nj <- nrow(tempdata[tempdata[["domain"]] == pairs[2, dom], ])
    tempdata[, "contact"] <-
      paste0(
        pairs[1, dom], "(", ni, "):", pairs[2, dom], "(", nj, ")"
      )
    if(cnt == 1) {
      cdata_detail <- tempdata
    } else {
      cdata_detail <- rbind(cdata_detail, tempdata)
    }
  }

  cdata_detail  <- cdata_detail[,c("contact", "domain", "dist", "value")]

  # Create summary data.
  cdata_summary <- cdata_detail %>%
    group_by(.data$contact, .data$domain, bin = cut(.data$dist, seq(-max_dist, max_dist))) %>%
    summarise(value = mean(.data$value, na.rm = TRUE)) %>%
    mutate(dist = interval_mid(.data$bin, 1)) %>%
    select(-.data$bin)

  return(list(detail = cdata_detail, summary = cdata_summary))
}

#' Produce Basic Contact Analysis Plots.
#'
#' \code{contact_plot} produces a minimally formatted contact analysis plot
#' facetted by domain using \code{\link{ggplot2}}. The input data is created by
#' \code{\link{contact_data}}. Additonal formatting can be applied using
#' \code{\link{ggplot2}} functions (see example).
#'
#' @param data List of data frames created by \code{\link{contact_data}} with
#'   'detail' and 'summary' contact data.
#'
#' @return A \code{\link{ggplot2}} plot object.
#' @export
#' @importFrom ggplot2 aes ggplot geom_smooth geom_line geom_vline facet_wrap
#' @importFrom rlang .data
#' @examples
#' library(ggplot2)
#' cdata <- contact_data(dholes, grade)
#' p <- contact_plot(cdata)
#' p +
#'  labs(x = "Distance (m)", y = "Mean grade (g/t)") +
#'  theme_bw()
contact_plot <- function(data) {
  ggplot() +
    geom_smooth(
      data = data$detail,
      aes(x = .data$dist, y = .data$value, group = .data$domain),
      method = "lm",
      linetype = "dashed",
      colour = "black",
      fill = "grey75",
      alpha = 0.5,
      size = 0.25
    ) +
    geom_line(
      data = data$summary,
      aes(.data$dist, .data$value, group = .data$domain),
      size = 0.25, colour = "black"
    ) +
    geom_vline(xintercept = 0, colour = "black") +
    facet_wrap(~contact, scales = "free_y")
}


dist_mode <- function(x) {
  ux <- unique(x)
  ux[which.max(tabulate(match(x, ux)))]
}

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

r = read.table("data/sinking_marbles.csv", sep=",", header=T)
nrow(r)
r$workerid = as.factor(as.character(r$workerid))
length(levels(r$workerid))
r$Item = as.factor(paste(r$effect,r$object))

unique(r$comments)

r = r %>% select(workerid,Item,response,response_unusual) %>%
  gather(responsetype,response,response:response_unusual)

# load original priors to make correlation scatterplots
priors_original = read.table("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/bayesian_model_comparison/priors/data/priors.txt",sep=",",header=T)
length(levels(as.factor(priors_original$workerid)))
head(priors_original)

# original exps:
exps_original = priors_original %>%
  group_by(Item) %>%
  summarise(Expectation=mean(response))
exps_original = as.data.frame(exps_original)
row.names(exps_original) = exps_original$Item

# original allprobs:
t = as.data.frame(prop.table(table(priors_original$Item,priors_original$response),mar=c(1)))
colnames(t) = c("Item","State","Probability")
allprobs_original = droplevels(t[t$State == 15,])
row.names(allprobs_original) = allprobs_original$Item
nrow(allprobs_original)

# original modes:
modes_original = priors_original %>%
  group_by(Item) %>%
  summarise(Mode=dist_mode(response))
modes_original = as.data.frame(modes_original)
row.names(modes_original) = modes_original$Item

r$OriginalExpectation = exps_original[as.character(r$Item),]$Expectation
r$OriginalMode = modes_original[as.character(r$Item),]$Mode
r$OriginalAllprob = allprobs_original[as.character(r$Item),]$Probability

# load info on inferred priors based on original priors (measures of "bi-modality")
bimodality= read.csv("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/bayesian_model_comparison/priors/results/bimodalityMAPs_priorBDA-mix2binomials-fullPosterior_incrMH75000burn37500.csv")
head(bimodality)
row.names(bimodality) = bimodality$Item

r$absMix = bimodality[as.character(r$Item),]$absMix
r$diffTheta = bimodality[as.character(r$Item),]$diffTheta
r$bimodality = bimodality[as.character(r$Item),]$bimodality

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

load("data/r.RData")

## plot subject variability
ggplot(r, aes(x=response,fill=responsetype)) +
  geom_histogram(position="dodge") +
  facet_wrap(~workerid)
ggsave(file="graphs/subject_variability.pdf",width=20,height=15)
table(r$workerid)

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

exps = r %>%
  group_by(Item,responsetype) %>%
  summarise(Expectation = mean(response))
exps = as.data.frame(exps)
exps = exps %>% spread(responsetype,Expectation)
row.names(exps) = exps$Item
r$Expectation = exps[as.character(r$Item),]$response
r$Expectation_unusual = exps[as.character(r$Item),]$response_unusual

## plot individual items
r$It = factor(x=as.character(r$Item),levels=unique(r[order(r[,c("Expectation")]),]$Item))

p=ggplot(r, aes(x=response,fill=responsetype,color=responsetype)) +
  geom_histogram(position="dodge") +
  scale_fill_manual(values=c("blue","red")) +
  scale_color_manual(values=c("blue","red")) +
  geom_vline(aes(xintercept=Expectation),color="blue") +
  geom_vline(aes(xintercept=Expectation_unusual),color="red") +
  facet_wrap(~It)
ggsave(file="graphs/item_variability.pdf",width=20,height=15)

t = as.data.frame(prop.table(table(r$Item,r$responsetype,r$response),mar=c(1,2)))
colnames(t) = c("Item","responsetype","State","Proportion")
head(t)
t$Expectation = exps[as.character(t$Item),]$response
t$Expectation_unusual = exps[as.character(t$Item),]$response_unusual

## plot individual items
t$It = factor(x=as.character(t$Item),levels=unique(t[order(t[,c("Expectation")]),]$Item))

p=ggplot(t, aes(x=State,y=Proportion,fill=responsetype,color=responsetype)) +
  geom_bar(position="dodge",stat="identity") +
  scale_fill_manual(values=c("blue","red")) +
  scale_color_manual(values=c("blue","red")) +
  geom_vline(aes(xintercept=Expectation),color="blue") +
  geom_vline(aes(xintercept=Expectation_unusual),color="red") +
  scale_y_continuous(limits=c(0,1)) +
  facet_wrap(~It)
ggsave(file="graphs/item_variability_dist.pdf",width=20,height=15)

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

# scatterplot of original vs normal vs unusual expectations
head(r)
exps = r %>%
  group_by(Item, responsetype, OriginalExpectation,absMix,diffTheta,bimodality) %>%
  summarise(Expectation=mean(response))
exps = as.data.frame(exps)

ggplot(exps, aes(x=Expectation,y=OriginalExpectation,color=responsetype)) +
  geom_point() +
  geom_smooth() +
  scale_x_continuous(limits=c(0,15)) +
  scale_y_continuous(limits=c(0,15)) +
  geom_abline(intercept=0,slope=1,color="gray50")
ggsave("graphs/correlation_with_original_priors.pdf")

cor(exps[exps$responsetype=="response",]$Expectation,exps[exps$responsetype=="response",]$OriginalExpectation) #.97
cor(exps[exps$responsetype=="response_unusual",]$Expectation,exps[exps$responsetype=="response_unusual",]$OriginalExpectation) #.87

# scatterplot of expectations vs three different measures of bimodality
ggplot(exps, aes(x=Expectation,y=absMix,color=responsetype)) +
  geom_point() +
  geom_smooth() +
  scale_x_continuous(limits=c(0,15)) +
  scale_y_continuous(limits=c(0,1))
ggsave("graphs/exp_by_absmix.pdf")

ggplot(exps, aes(x=Expectation,y=diffTheta,color=responsetype)) +
  geom_point() +
  geom_smooth() +
  scale_x_continuous(limits=c(0,15)) +
  scale_y_continuous(limits=c(0,1))
ggsave("graphs/exp_by_difftheta.pdf")

ggplot(exps, aes(x=Expectation,y=bimodality,color=responsetype)) +
  geom_point() +
  geom_smooth() +
  scale_x_continuous(limits=c(0,15)) +
  scale_y_continuous(limits=c(0,1))
ggsave("graphs/exp_by_bimodality.pdf")

# scatterplot of original vs normal vs unusual allprobs
head(r)
t = as.data.frame(prop.table(table(r$Item,r$response,r$responsetype),mar=c(1,3)))
colnames(t) = c("Item","State","ResponseType","AllProbability")
allprobs = droplevels(t[t$State == 15,])
allprobs$OriginalAllProbability = allprobs_original[as.character(allprobs$Item),]$Probability

ggplot(allprobs, aes(x=AllProbability,y=OriginalAllProbability,color=ResponseType)) +
  geom_point() +
  geom_smooth() +
  scale_x_continuous(limits=c(0,1),breaks=seq(0,1,.2)) +
  scale_y_continuous(limits=c(0,1),breaks=seq(0,1,.2)) +
  geom_abline(intercept=0,slope=1,color="gray50")
ggsave("graphs/correlation_with_original_priors_allprobs.pdf")

cor(allprobs[allprobs$ResponseType=="response",]$AllProbability,allprobs[allprobs$ResponseType=="response",]$OriginalAllProbability) #.95
cor(allprobs[allprobs$ResponseType=="response_unusual",]$AllProbability,allprobs[allprobs$ResponseType=="response_unusual",]$OriginalAllProbability) #.81

# scatterplot of original vs normal vs unusual mode
modes = r %>%
  group_by(Item, responsetype, OriginalMode) %>%
  summarise(Mode=dist_mode(response))
modes = as.data.frame(modes)
modes$Cases =

ggplot(modes, aes(x=Mode,y=OriginalMode,color=responsetype)) +
  geom_point() +
  geom_text(aes(label=Item)) +
  scale_x_continuous(limits=c(0,15)) +
  scale_y_continuous(limits=c(0,15)) +
  geom_abline(intercept=0,slope=1,color="gray50")
ggsave("graphs/correlation_with_original_priors_modes.pdf",height=10,width=13)

modes[modes$Mode > 10 & modes$OriginalMode < 5 & modes$responsetype == "response",]
modes[modes$Mode < 5 & modes$OriginalMode > 10 & modes$responsetype == "response",]


#' Capture the movement of the fixed, single-node walk of the diffusion probability method.
#'
#' Make a movie of the fixed, single-node walk the diffusion probability method makes in search of a given patient's perturbed variables.
#' @param subset.nodes - The subset of variables, S, in a background graph, G.
#' @param ig - The igraph object associated with the background knowledge graph.
#' @param output_filepath - The local directory at which you want still images to be saved.
#' @param movie - If you want to make a movie, set to TRUE. This will produce a set of still images that you can stream together
#'                to make a movie. Default is TRUE. Alternatively (movie=FALSE), you could use this function to get the node
#'                labels returned for each node ranking starting with a perturbed variable.
#' @param zoomIn - Boolean. Delete nodes outside of node subset's order 1 neighborhood?. Default is FALSE.
#' @return ranksByStartNode - a list object of node rankings Each element is based on a different startNode.
#'         Images are also generated in the output_directory specified.
#' @export singleNode.getNodeRanksMovie
#' @examples
#' # Read in any network via its adjacency matrix
#' tmp = matrix(1, nrow=100, ncol=100)
#' for (i in 1:100) {
#'   for (j in 1:100) {
#'     tmp[i, j] = rnorm(1, mean=0, sd=1)
#'   }
#' }
#' colnames(tmp) = sprintf("Compound%d", 1:100)
#' ig = graph.adjacency(tmp, mode="undirected", weighted=TRUE, add.colnames="name")
#' V(ig)$name = tolower(V(ig)$name)
#' adjacency_matrix = list(tmp) # MUST BE GLOBAL VARIABLE
#' # Set other tuning parameters
#' p0=0.1  # 10% of probability distributed uniformly
#' p1=0.9  # 90% of probability diffused based on edge weights in networks
#' thresholdDiff=0.01
#' G = vector(mode="list", length=length(V(ig)$name))
#' names(G) = V(ig)$name
#' subset.nodes = names(G)[sample(1:length(G), 3)]
#' singleNode.getNodeRanksMovie(subset.nodes, ig, output_filepath = getwd())
singleNode.getNodeRanksMovie = function(subset.nodes, ig, output_filepath, num.misses=NULL, zoomIn=FALSE) {
  if (zoomIn) {
    # Experimental feature to "zoom in" on a node neighborhood in very large networks, to better visualize
    # the node rankings instead of a hairball
    ig = delete.vertices(ig, v=V(ig)$name[-which(V(ig)$name %in% names(unlist(neighborhood(ig, nodes=subset.nodes, order=1))))])
    V(ig)$label.cex = 2
    V(ig)$label = rep("", length(V(ig)$name))
    tmp = get.adjacency(ig, attr="weight")
    tmp = abs(tmp)
    igraphTestG = graph.adjacency(tmp, mode="undirected", weighted=TRUE)
  }
  coords = layout.fruchterman.reingold(ig)
  G = vector(mode="list", length=length(V(ig)$name))
  names(G) = V(ig)$name
  G = lapply(G, function(i) i[[1]]=0)
  degs = list(degree(ig))
  adjacency_matrix = list(as.matrix(get.adjacency(ig, attr="weight")))

  # Do node rankings ahead of time for each possible startNode in subGraphS.
  V(ig)$color = rep("white", length(G))
  V(ig)$color[which(V(ig)$name %in% subset.nodes)] = "green"
  V(ig)$label = sprintf("%s:%.2f", V(ig)$name, G)
  current_node_set = NULL
  png(sprintf("%s/diffusionP1Movie%d.png", output_filepath, length(current_node_set)), 500, 500)
  plot.igraph(ig, layout=coords, vertex.color=V(ig)$color, edge.arrow.size=0.01,
              vertex.label=V(ig)$label, edge.width=5*abs(E(ig)$weight),  mark.col="dark red",
              mark.groups = current_node_set)
  title(sprintf("{%s}", paste(as.numeric(current_node_set %in% subset.nodes), collapse="")), cex.main=2)
  legend("topright", legend=c("Jackpot Nodes", "Drawn Nodes"), fill=c("green", "dark red"))
  dev.off()

  # Get all node names, so we know what all possible startNodes are.
  ranksByStartNode = list()
  bitStrings.pt = list()
  for (n in 1:length(subset.nodes)) {
    print(sprintf("Calculating node rankings %d of %d...", n, length(subset.nodes)))
    # Draw all nodes in graph
    current_node_set = NULL
    stopIterating=FALSE;
    startNode = subset.nodes[n]
    hits = startNode
    numMisses = 0
    currentGraph = G
    current_node_set = c(current_node_set, startNode)

    while (stopIterating==FALSE) {
      # Clear probabilities
      currentGraph[1:length(currentGraph)] = 0 #set probabilities of all nodes to 0
      #determine base p0 probability
      baseP = p0/(length(currentGraph)-length(current_node_set))
      #set probabilities of unseen nodes to baseP
      currentGraph[!(names(currentGraph) %in% current_node_set)] = baseP
      # Sanity check. p0_event should add up to exactly p0 (global variable)
      p0_event = sum(unlist(currentGraph[!(names(currentGraph) %in% current_node_set)]))
      currentGraph = graph.diffuseP1(p1, startNode, currentGraph, current_node_set, 1, verbose=FALSE)
      # Sanity check. p1_event should add up to exactly p1 (global variable)
      p1_event = sum(unlist(currentGraph[!(names(currentGraph) %in% current_node_set)]))
      if (abs(p1_event-1)>thresholdDiff) {
        extra.prob.to.diffuse = 1-p1_event
        currentGraph[names(current_node_set)] = 0
        currentGraph[!(names(currentGraph) %in% names(current_node_set))] = unlist(currentGraph[!(names(currentGraph) %in% names(current_node_set))]) + extra.prob.to.diffuse/sum(!(names(currentGraph) %in% names(current_node_set)))
      }
      #Set startNode to a node that is the max probability in the new currentGraph
      maxProb = names(which.max(currentGraph))
      # Break ties: When there are ties, choose the first of the winners.
      startNode = names(currentGraph[maxProb[1]])
      if (!is.null(num.misses)) {
        if (startNode %in% S) {
          numMisses = 0
        } else {
          numMisses = numMisses + 1
        }
        current_node_set = c(current_node_set, startNode)
        if (numMisses>num.misses || length(c(startNode,current_node_set))>=(length(G))) {
          stopIterating = TRUE
        }
      } else {
        # Keep drawing until you've drawn all nodes.
        current_node_set = c(current_node_set, startNode)
        if (length(current_node_set)>=(length(G))) {
          stopIterating = TRUE
        }
      }

      V(ig)$label = sprintf("%s:%.2f", V(ig)$name, G)
      png(sprintf("%s/diffusionP1Movie%d_%d.png", output_filepath, n, length(current_node_set)), 500, 500)
      plot.igraph(ig, layout=coords, vertex.color=V(ig)$color,
                  vertex.label=V(ig)$label, edge.width=5*abs(E(ig)$weight), edge.arrow.size=0.01,
                  vertex.size=5+round(50*unlist(currentGraph), 0), mark.col="dark red",
                  mark.groups = current_node_set)
      title(sprintf("{%s}", paste(as.numeric(current_node_set %in% subset.nodes), collapse="")), cex.main=2)
      legend("topright", legend=c("Jackpot Nodes", "Drawn Nodes"), fill=c("green", "dark red"))
      dev.off()
    }

    ranksByStartNode[[n]] = current_node_set
    bitStrings.pt[[n]] = as.numeric(current_node_set %in% subset.nodes)
  }
  names(ranksByStartNode) = subset.nodes

  return(ranksByStartNode)
}


# --------------------------------------------------------------------------------------
# Programmer: Jason Thorpe
# Date        03/17/2011
# Language:   R (Version 2.12.0)
# Purpose:
# Comments:
# --------------------------------------------------------------------------------------

#' Estimate the PEB parameters
#'
#' Estimate the PEB parameters from a set of marker values (x) from individuals
#'
#' @export
#' @param x observations of the for the variable of intereset
#'
#' @param id a 'factor' with identifiers for the individuals who contributed
#' the observations in \code{x}
#'
#' @param method Either 'ICC1' or 'iterative' (matched via match.arg).
#' If method == 'ICC1' (default) multilevel::ICC1 is used to estimate the
#' within and between group variation. Otherwise an iterative approach is used.
#'
#' @param iterations The number of iterations for estimating the tau
#' squared parameter (and it's error variance) (default = 2)
#'
#' @param conf.level The width of the confidence interval for sigma-squared
#' and tau-squared
#'
#' @family peb
#' @return a list with the following values:
#' s2: sigma quared
#' s2.ev: the error variance for sigma squared
#' t2: tau squared
#' t2.ev: the error variance for tau squared
#' mu: mu
#' mu.ev: the error variance for mu
#' m: the number of individuals contributing to the estimates
#' N: the nubmer so observations contributing to the estimates
#' mu.ci: confidence interval for mu
#' t2.ci: confidence interval for tau squared
#' s2.ci: confidence interval for sigma squared
#' nstar: an average sample size for use in calcualing the CI for tau sauqred
#'
#' @examples
#' n = 10
#' m = 200
#' PEBparams(x = rnorm(m*n) + rep(rnorm(m),each=n), id=gl(m,n,m*n))
#'
#' @importFrom multilevel ICC1

PEBparams <- function(x,
					  id,
					  method='ICC1',
					  iterations =2 ,
					  conf.level = 0.9,
					  verbose=FALSE){

	method = match.arg(method,c('ICC1','iterative'))
	if(method == 'ICC1' && !missing(iterations))
		stop("parameter 'iterations' is not used when method == 'ICC1'")

	stopifnot(all(is.finite(x)))
	if(!inherits(id,'factor'))
		stop("parameter 'id' must be a factor")
	if(!  all(levels(id) %in% id)){
		warning(paste("unused factor levels in 'id':",
					  paste(levels(id)[!levels(id) %in% id],
							collapse = ', ')))
		id <- factor(as.character(id))
	}

	N <- length(id)
	m <- length(levels(id))

	if(method == 'ICC1'){
		tryCatch({
			AOV = aov(formula(x~id))
		},error=function(err){
			stop('Internal call to `aov()` failed with error message: "%s".  \n\nSuggest using: PEBparams( ... , method="iterative")')
		})
		(B1 = multilevel::ICC1(AOV))
		V  <-  var(x)
		out  <-  list(s2 = (1-B1) * V,
						   t2 = B1 * V,
						   mu = mean(x),
						   m = m,
						   N = N,
						   method=method)
		class(out) <- c('PEBparams','list')
		return(out)

	}else{#(method == )
		# --------------------------------------------------
		# part 1: non-iterative calculations
		# --------------------------------------------------

		#calcualte various constants
		nresults <- tapply(id,id,length) # results per person
		ybari <- tapply(x,id,mean)

		#############################################
		# estiamte sigma^2
		#############################################
		s2i 	<- tapply(x,id,var)
#-- 		if(!all(is.na(s2i) == (nresults == 1)))
#-- 			browser()

		stopifnot(is.na(s2i) == (nresults == 1))

		#relative error variances of
		s2i_weights	<- (nresults - 1) / 2
		stopifnot( (s2i_weights ==0) == is.na(s2i))

		s2 <- sum((s2i_weights[!is.na(s2i)])*(s2i[!is.na(s2i)])) / sum(s2i_weights[!is.na(s2i)])
		s2ev <- 2*(s2^2)/(N - m)

		rm(s2i,s2i_weights)

		# --------------------------------------------------
		# --------------------------------------------------
		# part 2: iterative calculations of mu and Tau^2
		# --------------------------------------------------
		# --------------------------------------------------

		# ------------------------------
		# part 2a: fixed parameters for the iterative processes
		# ------------------------------
		tr <- table(nresults)
		uk <- as.numeric(names(tr[tr>1]))
		rm(tr)

		# estimates of the t2k's
		t2k   <- numeric(0)
		for(k in uk)
			t2k 	<- c(t2k, var(ybari[nresults == k] ) - (s2/k) )

		# initialize the variables involved in the iterative process
		t2kev_list  <-  list()
		t2ev  <-  muev  <-  t2  <-  numeric(0)

		# ------------------------------
		# part 2b: initial estiamte of EV(T_k^2) from the tk's
		# ------------------------------
		# Next, estimate the error variances which DOES depend on the estimate for tau^2
		# We use the unweighted average of the t2k's because the t2k's are unbaiased.
		# We cannot weight them according to their value because then underestimates
		# become overweitghted and underestimated become underweighted and the result
		# is a biased estimate of t2k and of it's error variance. we do however weight
		# them according to their m_k's becaue there is not bias there.

		t2kev_temp <- numeric(0)#initialization
		for(k in uk){# this would be more efficient with an apply stmt.
			m_k 		<- sum(nresults == k)
			#in the alternate version we estimate all the t2k's then estimate the t2kev's
			#this estimate DOES depend on the estimate for tau^2
			t2kev_temp 	  <- c(t2kev_temp,
									2*((mean(t2k) + s2/k)^2) / (m_k - 1) + (s2ev/(k^2))
									)
		}
		t2kev_list  <-  list(t2kev_temp)
		rm(k,m_k)

		# ------------------------------
		# part 2c: iterative re-estimation of Tau2 and mu
		# ------------------------------
		t2 <- mu <- t2ev <- muev <- numeric(0)
		# This function nested for lexical scoping
		t2_mu  <-  function(){
			#re-estimate t2 using the latest t2kev estimates
			t2new <- sum((1/(t2kev_list[[j]]))*(t2k))/sum(1/(t2kev_list[[j]]))

			#re-estimate t2_ev using the latest t2 estimates
			t2kev_temp <- numeric(0) #initialize
			for(k in uk){
				m_k 		<- sum(nresults == k)
				t2kev_temp 	<- c(t2kev_temp,
									2*((t2new + s2/k)^2) / (m_k - 1) + (s2ev/(k^2)))
			}
			t2kev_list <<- c(t2kev_list,list(t2kev_temp))

			#############################################
			# estimate mu (which depends on the estimate for tau^2)
			#############################################
			ybari_weights	<- 1/(t2new + (s2/nresults))
			bn <- (t2new)/((t2new) + (s2/nresults))

			# extend the lists of estmates
			t2 <<- c(t2,t2new )
			mu <<- c(mu, sum(ybari_weights*ybari) / sum(ybari_weights))

			t2ev <<- c(t2ev, 1/sum(1/t2kev_temp)) #estimate t2ev from the new t2kev's
			muev <<- c(muev, (t2new)/sum(bn))

		}

		stopifnot(iterations>0)

		probs <- c(((1-conf.level)/2),1-((1-conf.level)/2)) # probabilities for the CI

		for(j in 1:iterations){
			t2_mu()
			if(verbose){
				nstar   <- ((m-length(uk))/sqrt((t2ev[j]) / (2*((t2[j])^2)/(m-length(uk)))))
				cat('iteration:',j,
					'| Tau Squared CI width: ',
					format(diff((t2[j]*(nstar))/qchisq(p=probs[2:1],df = nstar)),8),
					'|  Mu CI width: ',
					format(diff(mu[j] + sqrt(muev[j])*qnorm(p=probs)),8),'\n')
			}
		}

		#############################################
		# return the estimates
		#############################################

		nstar   <- ((m-length(uk))/sqrt((t2ev[j]) / (2*((t2[j])^2)/(m-length(uk)))))

		out <- list(s2 = s2,
				   s2.ev = s2ev,
				   t2 = t2[iterations],
				   t2.ev = t2ev[iterations],
				   mu = mu[iterations],
				   mu.ev = muev[iterations],
				   m = m,
				   N = N,
				   mu.ci = mu[iterations] + sqrt(muev[iterations])*qnorm(p=probs),
				   t2.ci = t2[iterations]*qchisq(p=probs[2:1],df = nstar)/nstar,
				   s2.ci = s2*qchisq(p=probs[2:1],df = N-m  )/(N-m),
				   nstar = nstar,
				   conf.level = conf.level,
				   method=method)
		class(out) <- c('PEBparams','list')
		return(out)

	}

}

#' @export
print.PEBparams <- function(x,digits=4){
	cat('mu:',format(x$mu[1],digits=digits))
	if(x$method == 'iterative')
		cat(' [',format(x$mu.ci[1],digits=digits),
		   	',',format(x$mu.ci[2],digits=digits),']')
	cat('\n')

	cat('sigma^2:',format(x$s2[1],digits=digits))
	if(x$method == 'iterative')
		cat(' [',format(x$s2.ci[1],digits=digits),
		   	',',format(x$s2.ci[2],digits=digits),']')
	cat('\n')

	cat('tau^2:',format(x$t2[1],digits=digits))
	if(x$method == 'iterative')
		cat(' [',format(x$t2.ci[1],digits=digits),
		   	',',format(x$t2.ci[2],digits=digits),']')
	cat('\n')

	cat('Calculated using',x$N,'observations, from ',x$m, 'inidividuals.\n',sep = ' ')
	if(x$method == 'iterative')
		cat('([x,y] indicates the ',format(100*x$conf.level,2),'% confidence interval for each parameter)\n',sep = '')
}

qpeb.alt<-function(p,...,n,ybar,conf.level,details=FALSE)  {
	with(pebVarArgs(...),{
				bn <- bn(n)
				sd_n <<- sqrt(sigma + (tau*(1-bn)))
				mu_n <<- mu*(1-bn) + ybar*bn
				})
	if(length(p) == 1)
		return(qnorm(p,mean = mu_n,sd=sd_n))
	out <- matrix(NA,length(n),length(p))
	for(i in 1:length(p))
		out[,i] <- qnorm(p[i],mean = mu_n,sd=sd_n)
	dimnames(out) <- list(if(!is.null(names(n)))names(N) else seq(length(n)),
						  paste('p =',p))
	return(out)
}


context("Preprocess integrity")

test_that("PCA gives meaningful results", {
  P <- profile.data.dummy()
  P <- pca(P, .80)
  expect_equal(NCOL(feats(P)),7)
})


#' symmetrize
#'
#' Make a matrix-like object symmetric.
#'
#' @details
#' For a matrix input, we use a block algorithm.
#'
#' @param x
#' A matrix-like object.
#' @param triangle
#' A single character, either "u" or "l" for upper or lower, respectively.
#' This determines which triangle is preserved.  The default is the upper
#' triangle.  Case is ignored.
#'
#' @return
#' A matrix-like object of the same type as the input.
#'
#' @export
symmetrize <- function(x, triangle="u") UseMethod("symmetrize", x)

symmetrize_err <- function(x, triangle="u")
{
  if (class(x) == "ZeroMat" || class(x) == "DiagMat" || class(x) == "SymMat")
    stop(paste("a", class(x), "matrix is already symmetric"))
}

#' @export
symmetrize.DiagMat <- symmetrize_err

#' @export
symmetrize.ZeroMat <- symmetrize_err

#' @export
symmetrize.SymMat <- symmetrize_err

### TODO
# #' @export
# symmetrize.GenBandMat <- function(x)
# {
#
# }

#' @export
symmetrize.matrix <- function(x, triangle="u")
{
  if (!is.numeric(x) && !is.logical(x))
    stop("argument 'x' must contain numeric, integer, or logical data")

  check.is.char(triangle)

  triangle <- tolower(triangle)
  if (triangle != "u" && triangle != "l")
    stop("argument 'triangle' must be one of 'u' (upper) or 'l' (lower)")

  .Call(R_symmetrize, x, triangle)
}


# Install my packages
list.of.packages <- c("doParallel","kableExtra", "foreach", "MASS")
new.packages <- list.of.packages[!(list.of.packages %in% installed.packages()[,"Package"])]
if(length(new.packages)) install.packages(new.packages)
lapply(list.of.packages, require, character.only = TRUE)

cl <- makeCluster(2)
registerDoParallel(cl)

setwd("Enrichment-Inference-Supplemental-Materials/simulation_files/confidence_bands/")
source("coverage_probabilities_bands.r")
source("confidence_bands.r")

dist.v <- c("binorm", "binorm",
            "bibeta", "bibeta",
            "unif")

r.vec <- c(2^seq(1, 13), 3^seq(1, 8), 10, 105, 300, 1500, 15000)
r.vec <- r.vec[order(r.vec)]/150000

params.ls <- list(c(1.4, 0), c(.5, 0), list(c(5,2), c(2,5)),
                  list(c(20,1), c(1,20)), list(c(.25,1), c(0,.75)))
method.v <- c("sup-t", "sup-t", "bonf", "bonf", "JZ", "JZ")
correction.v <- c(F, T, F, T, F, T)
simreps <- 5
mc.rep <- 100000

k.ls <- list()
pi.ls <- list()
p <- length(method.v)
i <- 3; j <- 2
for(i in seq_along(dist.v)) {
  for(j in seq_along(method.v)) {
    print(paste(method.v[j]))
    k.ls[[(i-1) * p + j]] <- cov.prob.tab(params= params.ls[[i]], dist = dist.v[i], pi.0.true = 1/501,
                                myseed=567, method = method.v[j], plus = correction.v[j],
                                simreps = simreps, m = 150000, B = 1000, mc.rep = mc.rep,
                                r.vec = r.vec, metric = "k")
  }
  save.image("cp_all_bands_dist.rdata")
}


#!/usr/bin/env Rscript

#########################################################################################
#  __  o  __   __   __  |__   __                                                         #
# |__) | |  ' (__( |  ) |  ) (__(                                                        #
# |                                                                                #
#                                                                                #
# File: 2logeB10.r (Rscript)                                                             #
#  VERSION="v1.2"                                                                        #
# Author: Justin C. Bagley                                                               #
# Date: Created by Justin Bagley on Fri, 19 Aug 2016 00:23:07 -0300.                     #
# Last update: March 6, 2019                                                             #
# Copyright (c) 2016-2021 Justin C. Bagley. All rights reserved.                         #
# Please report bugs to <jbagley@jsu.edu>.                                               #
#                                                                                #
# Description:                                                                           #
#                                                                                #
#########################################################################################

####################################### START ###########################################

cat('INFO      | $(date) |----------------------------------------------------------------\n')
cat('INFO      | $(date) | 2logeB10.r, v1.2 March 2019  (part of PIrANHA v0.3a2)          \n')
cat('INFO      | $(date) | Copyright (c) 2016-2021 Justin C. Bagley. All rights reserved. \n')
cat('INFO      | $(date) |----------------------------------------------------------------\n')

# Load needed library, R code, or package stuff. Install package if not present.
#source("2logeB10.R", chdir = TRUE)
packages <- c("psych")
if (length(setdiff(packages, rownames(installed.packages()))) > 0) {
    install.packages(setdiff(packages, rownames(installed.packages())))
}

library(psych)

########### Read data and output to file
# Read in the data, output from STEP #1 of MLEResultsProc.sh script.
data <- read.table(file="MLE.output.txt", header=TRUE, sep="\t")

sink("2logeB10.output.txt")
cat("############################# MARGINAL-LIKELIHOOD ESTIMATES ##############################\n")
data
cat("\n \n")
sink()

########### Get marginal likelihood values and calculate 2loge B10 Bayes factors (2loge(B10))
# Raw path-sampling (PS) log-marginal likelihood estimates:
PS_vec <- data[,2]
PS_vec

# Raw stepping-stone (SS) sampling log-marginal likelihood estimates:
SS_vec <- data[,3]
SS_vec

# Make matrix of zeros for correcting signs of each BF below:
if(length(PS_vec) > 0){
	zeros <- c()
	for(i in 1:length(PS_vec)){
		zeros[i] <- 0
	}
}
if(length(SS_vec) > 0){
	zeros <- c()
	for(i in 1:length(SS_vec)){
		zeros[i] <- 0
	}
}
zeros
zeros_mat <- 2*(outer(zeros, zeros, '-'))
zeros_mat

# Matrix of 2loge BFs calculated from PS log-marginal likelihood estimates:
PS_2logeB10 = 2*(outer(PS_vec, PS_vec, '-'))
PS_2logeB10 <- zeros_mat - PS_2logeB10

# Matrix of 2loge BFs calculated from SS log-marginal likelihood estimates:
SS_2logeB10 = 2*(outer(SS_vec, SS_vec, '-'))
SS_2logeB10 <- zeros_mat - SS_2logeB10

########### Summarize results and output to file
# Use psych package function to combine the resulting matrices into a single, nice
# output table with Bayes factors (BF) from PS MLEs below the diagonal and BFs from SS
# MLEs above the diagonal:
sink("2logeB10.output.txt", append=TRUE)
cat("##################################### BAYES FACTORS ######################################
Below diagonal: 2loge(B10) values based on path sampling (PS) log-marginal likelihood estimates
Above diagonal: 2loge(B10) values based on stepping-stone (SS) log-marginal likelihood estimates\n")
if(sum(PS_vec) == '0'){
	BF_mat <- lowerUpper(PS_2logeB10, SS_2logeB10, diff=FALSE)
	BF_mat[lower.tri(BF_mat)] <- NA
	rownames(BF_mat) <- 1:length(PS_vec)
	colnames(BF_mat) <- 1:length(PS_vec)
	BF_mat
}
if(sum(SS_vec) == '0'){
	BF_mat <- lowerUpper(PS_2logeB10, SS_2logeB10, diff=FALSE)
	BF_mat[upper.tri(BF_mat)] <- NA
	rownames(BF_mat) <- 1:length(PS_vec)
	colnames(BF_mat) <- 1:length(PS_vec)
	BF_mat
}
if( (sum(PS_vec) != '0') & (sum(SS_vec) != '0') ){
	BF_mat <- lowerUpper(PS_2logeB10, SS_2logeB10, diff=FALSE)
	rownames(BF_mat) <- 1:length(PS_vec)
	colnames(BF_mat) <- 1:length(PS_vec)
	BF_mat
}
cat("\n \n")
sink()

# Next, report PS MLE BFs below the diagonal and report the difference between PS- and
# SS-based BF matrices, placing the results in the above-the-diagonal entries. However,
# we only report the differences if both PS- and SS-based BFs could be calculated; otherwise,
# we do not report the differences at all! If PS MLEs or SS MLEs were missing in the input
# (as is usually the case for BEAST2 MLE runs), then either PS_vec or SS_vec would be filled
# with zeros. If we computed differences in such a case, then we would be left with a square
# matrix in which the above-diagonal elements were the same as the below-diagonal elements,
# only with the opposite sign. Such a table would be equivalent to the Bayes factors table
# already written to file in the step above, and thus would be unnecessary.

sink("2logeB10.output.txt", append=TRUE)
if( (sum(PS_vec) != '0') & (sum(SS_vec) != '0') ){
cat("################################ BAYES FACTOR DIFFERENCES ################################
Below diagonal: 2loge(B10) values based on path sampling (PS) log-marginal likelihood estimates
Above diagonal: differences between PS- and SS-based BF values\n")
	BF_diff_mat <- lowerUpper(PS_2logeB10, SS_2logeB10, diff=TRUE)
	rownames(BF_diff_mat) <- 1:length(PS_vec)
	colnames(BF_diff_mat) <- 1:length(PS_vec)
	BF_diff_mat
}
cat("\n \n")
sink()

######################################## END ############################################


#' Data Fit Assessment
#'
#' Calculates \eqn{R^2} values for correct and incorrect mean reaction times and RMSE values
#' for the proportions of correct answers per reaction times cuantiles.
#' @export
#' @param experim_dat Experimental data in the form produced by \code{\link{experimental_data_processing}}.
#' @param experim_dat Simulated data in the form produced by \code{\link{simulDat}}.
#' @param model_name Optional name for the model to distinguish to which data/model the
#' function was applied to. Default is 'NAME_UNDEFINED'.
#'
#' @return Prints a table with RMSE and \eqn{R^2} values.
fit_quality <- function(experim_dat, simul_dat, model_name='NAME_UNDEFINED'){

    experim_dat$cond <- "Data"

    dat <- rbind(experim_dat, simul_dat$data)

    ##########
    nbins <- 6

    dat_cuants <- quantile(experim_dat$rt, probs = seq(0, 1, length.out = nbins+1))
    dat_cuants[length(dat_cuants)] <- tail(dat_cuants, n=1)+0.1

    sim_cuants <- quantile(simul_dat$data$rt, probs = seq(0, 1, length.out = nbins+1))
    sim_cuants[length(sim_cuants)] <- tail(sim_cuants, n=1)+0.1

    dat$cuants[dat$cond=='Data'] <-  experim_dat %>%
        select(-cond) %>%
        split(experim_dat$suj) %>%  map(c('rt')) %>%
        map(function(x) {cut(x, breaks = dat_cuants, right=FALSE, na.rm = TRUE)}) %>%
        as_tibble() %>% tidyr::pivot_longer(cols=everything(), names_to = 'variable', values_to = 'value') %>%  .$value

    dat$cuants[dat$cond=='Sim'] <-  simul_dat$data %>%
        split(simul_dat$data$suj) %>%  map(c('rt')) %>%
        map(function(x) {cut(x, breaks = sim_cuants, right=FALSE, na.rm = TRUE)}) %>%
        as_tibble() %>% tidyr::pivot_longer(cols=everything(), names_to = 'variable', values_to = 'value') %>%  .$value

    dat$cuants <- unlist(dat$cuants) %>% as.factor()
    dat$cor <- as.numeric(levels(dat$cor))[dat$cor]
    #########

    a <- dat %>% group_by(cond, cuants) %>%
        dplyr::summarise(mean = mean(cor)) %>%
        spread(cond,mean) %>%
        select(-cuants) %>%
        rmse()

    b <- dat %>%
        group_by(suj, cond) %>%
        dplyr::summarize(mean_rt = mean(rt)) %>%
        spread(cond, mean_rt) %>%
        ungroup() %>%
        dplyr::summarise(rmse = rmse(.)) %>%
        pull()

    c <- dat %>%
        group_by(suj, cond) %>%
        dplyr::summarize(mean_rt = mean(rt)) %>%
        spread(cond, mean_rt) %>%
        ungroup() %>%
        dplyr::summarise(r2 = summary(lm(data=., Data~Sim))$adj.r.squared) %>%
        pull()

    d <- dat %>% group_by(cor, cond, suj) %>%
        dplyr::summarise(mean = mean(rt)) %>%
        ungroup() %>%
        spread(cond,mean) %>%
        nest(-cor) %>%
        mutate(data = map(data, ~ rmse(as.data.frame(.x)))) %>%
        mutate(data = unlist(data)) %>%
        pull(data)

    e <- dat %>% group_by(cor, cond, suj) %>%
        dplyr::summarise(mean = mean(rt)) %>%
        ungroup() %>%
        spread(cond,mean) %>%
        nest(-cor) %>%
        mutate(data = map(data, ~ summary(lm(data=as.data.frame(.x), Data~Sim))$adj.r.squared)) %>%
        mutate(data = unlist(data)) %>%
        pull(data)

    stats <- list("RMSE (Correct answers per RT cuantiles)" = a,
                  "RMSE (Overall Means of RTs aggr. by Subj.)" = b,
                  "R2 (Overall Means of RTs aggr. by Subj.)" = c,
                  "RMSE (For Incorrect Mean RTs aggr. by Subj.)" = d[1],
                  "RMSE (For Correct Mean RTs aggr. by Subj.)" = d[2],
                  "R2 (For Incorrect Mean RTs aggr. by Subj.)" = e[1],
                  "R2 (For Correct Mean RTs aggr. by Subj.)" = e[2]
    )

    print(data.frame(stats=unlist(stats)))

}


train.EFSA<-function(train_data,as.train_labels,shapelets,shapelet_length,method="RandomForest",ntree=300,k=1){
	distance_matrix = compute_best_matching_distance(train_data,shapelets,shapelet_length)

	if(method == "RandomForest"){
		model=randomForest(distance_matrix,as.factor(train_labels),ntree=300)
	}
    train_accuracy = 1-as.numeric(model$err.rate[nrow(model$err.rate),1])
	model = structure(list("model"=model,"train_accuracy"=train_accuracy,"shapelets"=shapelets,"shapelet_length"=shapelet_length),class="EFSA")
	return(model)
}


##
## Analyses for "Population structured by witchcraft beliefs" by Mace et al.
##
## Code by Matthew Gwynfryn Thomas (@matthewgthomas)
##
## Packages required:
## - tidyverse
## - dplyr
## - broom
## - readr
## - data.table
## - ggplot2
## - wesanderson
## - igraph
## - MuMIn
## - AICcmodavg
## - lme4
## - geepack
## - survival
## - pscl
## - arm
## - spdep
## - pander
##
source("init.r")

source("assortment and clustering.r")    # Figures 1 and 2
source("ferility of household heads.r")  # Figure 3, Supplementary Figure 3, and Supplementary Tables 6 and 7
source("public goods game analysis.r")   # Table 1

# supplementary materials
source("fig s1.r")

source("ZIP predicting in-degree.r")  # Supplementary Table 1
source("gee.r")                       # Supplementary Table 2
source("contingency table.r")         # Supplementary Table 3 (this will need to be stitched together manually)
source("logistic regression predicting zhu houses.r")  # Supplementary Table 4 and Supplementary Figure 2
rmarkdown::render("zhu_dispersal.Rmd", "word_document", output_dir=results.dir)  # Supplementary Table 5
source("age at first birth.r")        # Supplementary Table 8

# produce the in-text statistics
rmarkdown::render("main text and SI text.r", "word_document", output_dir=results.dir)


### Function to simulate traits with causative markers for GWAS

# need genomic data . A sample of 22k random SNPs from the Arabidopsis 1001G Project is available as example for Arabidopsis traits
# a file with the Information of all 2029 accessions for which genotype data exist is also provided (lat_long_2029.csv). This information has been downloaded from the AraPheno database

#A<-read.csv('~/git/GWAS/data/lat_long_2029.csv')
#If you use own data ensure that the id should be in a column called 'accession_id'
#load('~/git/GWAS/data/X_Mix.rda')
#rownames(X) needs to be the ids of the accessions
# for models with multiple causative markers, it is recommended to have them ordered by the amount of variance explained (ve)

# the simulation create random, but reproducible (seed) phenotypes.
# to simulate only in specific accession provide an integer of accessions ids in sp_acc (length need to be >1).
# to simulate distinct markers, the script can be modified manually.

sim_Y <-
  function(n = 100,
           acc = A,
           sp_acc = 0,
           no_acc = 200,
           fix_acc = TRUE,
           SNPs = X,
           no_snps = 1,
           ve = .1,
           mac = 5,
           h2 = 0.7,
           seed = 42,
           bk = 1000,
           effect_factor = 1) {
    stopifnot(no_snps > 0)
    stopifnot(length(ve) == no_snps)
    set.seed(seed)

    Sim <- list()
    Caus <- list()
    if (length(sp_acc) > 1) {
      a <- sp_acc
      no_acc = length(a)
    } else {
      a <- sample(acc$accession_id, no_acc)
    }

    X_ <- SNPs[rownames(SNPs) %in% a, ]
    af <- apply(X_, 2, sum)
    X_ok <- X_[, which(af > mac & af < (no_acc - mac))]

    for (u in 1:n) {
      set.seed(seed + u)

      if (u>1 && fix_acc == FALSE) {
        a <- sample(A$accession_id, no_acc)
        X_ <- subset(X, rownames(X) %in% a)

        af <- apply(X_, 2, sum)
        X_ok <- X_[, which(af > mac & af < (no_acc - mac))]
      }

      caus <- X_ok[, sample(1:ncol(X_ok), (no_snps + 1))]

      #generating polygenic background
      X3 <- X_ok[, !colnames(X_ok) %in% colnames(caus)]
      back <- X3[, sample(1:ncol(X3), bk)]
      betas <- rnorm(bk, mean = 0, sd = 0.1)
      first <- back %*% betas

      ### adding genetic background to data
      sim <-
        data.frame(ecot_id = as.integer(rownames(back)), value = first)
      ### set heritability
      dat <- var(sim[, 2])

      h_2 <- dat / h2 - dat
      fix1 <- rnorm(nrow(back), 0, sqrt(h_2))
      sim_ <-
        data.frame(ecot_id = as.integer(rownames(back)), value = first + fix1)

      for (t in 1:length(ve)) {
        beta <-
          sqrt((ve[t] / (1 - ve[t])) * (var(sim_[, 2]) / var(caus[, t])))

        cand <- effect_factor * beta * caus[, t]
        sim_$value <- sim_$value + cand

      }
      Sim[[u]] <- sim_
      Caus[[u]] <- colnames(caus)[1:t]
    }

    return(list(Y = Sim, Caus = Caus))
  }


  # ------------------------------
  # extract sex ratios

  sex.ratios = function(x, factors=c("trip", "set")) {

    # sex codes
    male = 0
    female = 1
    sex.unknown = 2

    mi = which(x$sex==male)
    nx = rep(1,dim(x[mi,])[1])
    m = as.data.frame(xtabs( nx ~ as.factor(trip) + as.factor(set), data=x[mi,] ) )
    names(m) = c(factors, "no.male")
    m = factor2character(m, factors)

    fi = which(x$sex==female)
    nx = rep(1,dim(x[fi,])[1])
    f = as.data.frame(xtabs( nx ~ as.factor(trip) + as.factor(set), data=x[fi,] ) )
    names(f) = c(factors, "no.female")
    f = factor2character(f, factors)

    all = merge(x=m, y=f, by=factors, all=T)
    all$no.female[!is.finite(all$no.female)] = 0
    all$no.male[!is.finite(all$no.male)] = 0
    all$sexratio = all$no.female / (all$no.female + all$no.male)
    all$sexratio[!is.finite(all$sexratio)] = NA

    return (all)
  }


#研究f_eject射出次数和频率
#分为eject单次射出，即单脉冲内射出的次数
#还有eject，总体射出频率

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

#读取数据
#q2 <- read.xlsx("f_eject.xls", sheetName = "eject_q15", header = TRUE)
q3 <- read.xlsx("f_eject.xls", sheetName = "eject_q27", header = TRUE)
#q4 <- read.xlsx("f_eject.xls", sheetName = "eject_q54", header = TRUE)
#q5 <- read.xlsx("f_eject.xls", sheetName = "eject_q180", header = TRUE)

#保存数据
#pdf("f_eject_27.pdf")

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

##################################画图--占空比k为0.2#######################
plot(q3$fv, q3$X0.2, xaxs = "i", col = 0, xlab = "Voltage frequency (Hz)", ylab = "Frequency in 1s (Hz)", main = "Eject frequency in Q = 27nl/min", cex.lab = 1.1, cex.main = 1.2, xlim = c(0, 1050), ylim = c(70, 1050))

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

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

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

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

#区域划线

legend("bottomright", c("k = 0.2", "k = 0.3", "k = 0.4", "k = 0.5"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"), pch = c(21, 22, 23, 24), lwd = 2, lty = 2, cex = 1.1, inset = .05, bty = "n")

abline(v=600, lty = 3, col ="red", lwd = 3)
#abline(v=200, lty = 3, col ="red", lwd = 3)
#abline(h = 600, lty = 3, col = "green3", lwd = 3)
text(680, 700, "600Hz", col = "blue", cex = 1.5, font = 2)
#text(1050, 1800, "1000Hz", col = "blue", cex = 1.5, font = 2)

#dev.off()