pdf_file<-"pdf/boxplots_multiple_compare.pdf"
cairo_pdf(bg="grey98", pdf_file,width=7,height=10)

par(omi=c(0.35,0.25,0.75,0.25),mai=c(0.75,1.75,0.55,0),family="Lato Light",las=1)
library(memisc)

# Import data and prepare chart

myDatafile<-"myData/ZA4804_v2-0-0.sav"
ZA4804<-spss.system.file(myDatafile)
myData<-subset(ZA4804,select=c(s002evs,s003,x047d))
attach(myData)
t1<-subset(myData,x047d>0 & s002evs=="1999-2001")
t1_countries<-unique(t1$s003)
t2<-subset(myData,x047d>0 & s002evs=="2008-2010" & is.element(s003,t1_countries))

attach(t1)
a1<-aggregate(as.numeric(x047d),list(as.factor(s003)), quantile,na.rm =T)

attach(t2)
a2<-aggregate(as.numeric(x047d),list(as.factor(s003)), quantile,na.rm =T)

a1.sorted<-a1[order(a1$x[,3]), ]

# Define chart

plot(1:1, type="n",xlim=c(0,4.25),ylim=c(0.5,51.5),axes=F,xlab="",ylab="",yaxs="i")

# Other elements

abline(v=c(0,1,2,3,4), lty="dotted", col="grey70")

myC1<-"gray55"
myC2<-"deeppink"
myBckgrnd<-rgb(191,239,255,70,maxColorValue=255)

for (i in 1:25)
{
rect(0,2*i-0.9,4.25,2*i+0.9, col=myBckgrnd, border=NA)
segments(a1.sorted$x[i,2],2*i-0.2,a1.sorted$x[i,4],2*i-0.2,lwd=4, col=myC1)
segments(a2$x[a2$Group.1==a1.sorted$Group.1[i],2],2*i+0.2,a2$x[a2$Group.1==a1.sorted$Group.1[i],4],2*i+0.2, col=myC2, lwd=4)

par(family="Symbola")
text(a1.sorted$x[i,3],2*i-0.4,"▼",col=myC1, cex=0.8)
text(a2$x[a2$Group.1==a1.sorted$Group.1[i],3],2*i+0.4,"▲",col=myC2,cex=0.8)

par(family="Lato Light")
text(-0.1,2*i,a1.sorted$Group.1[i],adj=1,xpd=T)
}
mtext(c(0, "1.000", "2.000", "3.000", "4.000"),1,at=c(0:4),cex=0.85)
mtext("Monthly Household Income (PPP adjusted) in Euro",1,adj=0.5,line=1.5)

# Titling

mtext("Income Distribution 1999 and 2008",3,line=1.6,adj=0,cex=1.8,family="Lato Black",outer=T)
mtext("European Values Study",3,line=-0.2,adj=0,cex=1.5,font=3,outer=T)
mtext("Source: ZA4804 European Values Study Longitudinal Data File 1981-2008, www.gesis.org",1,line=0,adj=1.0,cex=0.95,font=3,outer=T)

# Legend

par(new=T, omi=c(0,0,0,0), mai=c(8.5,5.5,0.5,0.55))
plot(0:1, xlim=c(0,1),ylim=c(0,1),type="n",axes=F,xlab="",ylab="")
segments(0,0.42,1,0.42,col=myC1,xpd=T,lwd=4)
segments(0,0.57,1,0.58,col=myC2,xpd=T,lwd=4)
text(0,0.75,"25%",adj=0.5,cex=0.7,xpd=T,font=3)
text(1,0.75,"75%",adj=0.5,cex=0.7,xpd=T,font=3)
text(0.5, 0.75,"Median",adj=0.5,cex=0.7,font=3)
text(-0.1, 0.42,"1999-2001",adj=1,cex=0.65,xpd=T,font=3)
text(-0.1, 0.58,"2008-2010",adj=1,cex=0.65,xpd=T,font=3)
par(family="Symbola")
text(0.5,0.6,"▲",col=myC2,cex=0.8)
text(0.5,0.39,"▼",col=myC1,cex=0.8)
dev.off()


# #------VCF file (from 1000 gp) processing------

# extract a list of EUR sample list
# awk '{print $1}' /data/coxvgi/z*/data/kgp/phase3/chr/chr16_eur_nondup.fam > /data/g*/z*/covid19_neanderthals/ld_matrix_projected/genotype_simulation/1000gp/ceu.txt
#
# extract a list of common variants used
# awk '{print $2}' /data/g*/z*/covid19_neanderthals/ld_matrix_projected/geno/chr22.bim > /data/g*/z*/covid19_neanderthals/ld_matrix_projected/genotype_simulation/1000gp/variants.txt
#
#
# ml GCC OpenMPI VCFtools/0.1.15
#
# vcftools --gzvcf /data/coxvgi/z*/data/kgp/phase3/chr/ALL.chr22.phase3_shapeit2_mvncall_integrated_v5a.20130502.genotypes.vcf.gz \
# --keep /data/g*/z*/covid19_neanderthals/ld_matrix_projected/genotype_simulation/1000gp/ceu.txt \
# --maf 0.01 \
# --chr 22 \
# --snps /data/g*/z*/covid19_neanderthals/ld_matrix_projected/genotype_simulation/1000gp/variants.txt \
# --from-bp 20000000 \
# --to-bp 25000000 \
# --recode \
# --out /data/g*/z*/covid19_neanderthals/ld_matrix_projected/genotype_simulation/1000gp/chr22

#args=as.numeric(commandArgs(TRUE))

library('sim1000G')
library('MASS')
library('Matrix')
library('RiskPortfolios')
.libPaths("~/R/rlib-3.4_new")
library('data.table')
library('pdist')
library('corpcor')
library('Matrix')

library(foreach)
library(doParallel)

segment_length = as.integer(50000)
sample_size = 500

i = 1 #FOR TEST

#set up parallele
registerDoParallel(cores = detectCores())

#generate random segments on chr 22
all_geno = foreach(i = seq(1,500,50)) %dopar% {

  #segment start and end position
  set.seed(i)
  start_point = as.integer(sample(seq(20000000,24000000,by=1000000),1,replace = F))
  end_point = as.integer(start_point + segment_length)

  #load vcf file
  vcf_file = '/data/g*/z*/covid19_neanderthals/ld_matrix_projected/genotype_simulation/1000gp/chr22.recode.vcf'
  vcf = readVCF(vcf_file, maxNumberOfVariants = 300 ,
                min_maf = 0.05, max_maf = 1,
                region_start = start_point, region_end = end_point)
  set.seed(i)

  #simulate genetype for 50k samples based on the empirical data (1000gp EUR)
  startSimulation(vcf, totalNumberOfIndividuals = 50000)
  ids = generateUnrelatedIndividuals(50000)

  genotype = retrieveGenotypes(ids)
  all_geno = as.data.frame(genotype)

  #scale to ~N(0,1)
  all_geno = apply(all_geno, MARGIN = 2, function(x) scale(x)) #scale to ~N(0,1)
  all_geno
}

#output datafrome
output = data.frame(seed = seq(1,500))

asso = function(x){
  ans = lm(outcome ~ x)
  as.numeric(ans$coefficients[2])
}

h2_est = function(cov_matrix, beta_gwas){
  #Moore-Penrose pseudoinverse
  inverse_c<-pseudoinverse(cov_matrix)
  #q=rank(C)  the maximum number of linearly independent vectors in rows or columns
  q=rankMatrix(inverse_c)
  q=as.numeric(q)
  h2 = (sample_size * t(beta_gwas) %*% inverse_c %*% beta_gwas - q) / (sample_size - q)
}

#500 times simulation
for(i in 1:500){
  print(i)

  #load all genotype
  set.seed(i)
  all = all_geno[[sample(length(all_geno),1)]]
  #take a random sample
  set.seed(i)
  sampled = all[sample(nrow(all),sample_size,replace = F),]

  #estimate cov matrix
  projected = covEstimation(as.matrix(sampled), control = list(type = 'cor'))
  observed = cov(as.matrix(sampled))
  true = cov(as.matrix(all))

  output[i,'sample_size'] = sample_size
  output[i,'segment_length'] = segment_length
  output[i,'n_snps'] = ncol(all)
  output[i,'distance_true_observed'] <- sqrt(sum(as.numeric(true - observed))^2)
  output[i,'distance_true_projected'] <- sqrt(sum(as.numeric(true - projected))^2)

  for (h2 in c(0.01,0.02,0.03)){

    #define a sample set for beta (GWAS) estimation
    set.seed(i+2021)
    df_beta_est = all[sample(nrow(all),sample_size,replace = F),]
    #define a causal snp
    set.seed(i+100)
    causal_snp_pos = sample(ncol(df_beta_est),1)
    beta = sqrt(h2*1/var(df_beta_est[,causal_snp_pos])) #var(y) = 1
    #generate the outcome
    set.seed(i)
    outcome = beta*df_beta_est[,causal_snp_pos] + rnorm(nrow(df_beta_est),0,sqrt(1-h2))

    #estimate beta (GWAS)
    beta_gwas = apply(df_beta_est, MARGIN = 2, function(x) asso(x))

    #estimate h2 for the segment using beta_gwas and LD-matrix
    output[i,paste0('h2_',h2,'_projected')] = h2_est(projected, beta_gwas)
    output[i,paste0('h2_',h2,'_observed')] = h2_est(observed, beta_gwas)

  }

}

stopImplicitCluster()

write.table(output,paste0('/data/g*/z*/covid19_neanderthals/ld_matrix_projected/results/projected_observed_h2.txt'),quote = F,sep='\t',row.names = F)

#---generate the figure----

library(ggplot2)

#load the results (the same df a few lines above)
df = read.table(paste0('/data/g*/z*/covid19_neanderthals/ld_matrix_projected/results/projected_observed_h2.txt'),header = T,stringsAsFactors = F)

p = list()
i=1
for(i in 1:3){
  h2 = c(0.01,0.02,0.03)[i]
  tmp = data.frame(h2 = c(df[,paste0('h2_',h2,'_projected')],
                          df[,paste0('h2_',h2,'_observed')]),
                   group = c(rep('Projected',nrow(df)), rep('Observed',nrow(df))))
  tmp$group = as.factor(tmp$group)
  p[[letters[i]]] = ggplot(tmp, aes(x=group, y=h2)) +

    geom_violin(data=tmp, aes(x=group, y=h2, fill=group), position=position_dodge(0.6),bw=0.005)+
    geom_boxplot(width=0.2,data=tmp, aes(x=group, y=h2, fill=group), position=position_dodge(0.6))+

    #geom_boxplot(outlier.shape = NA)+
    ylim(0,0.15)+
    theme(axis.title.x = element_blank(),
          panel.grid =element_blank(),
          panel.background = element_blank(),
          axis.line = element_line(colour = "black"),
          legend.position = 'none')+
    ylab(bquote({h^2})) +
    geom_hline(yintercept = h2,linetype = 'dashed',color = 'red', size=1)+
    labs(tage=letters[i])

}

library(grid)
lay_out = function(...) {
  x <- list(...)
  n <- max(sapply(x, function(x) max(x[[2]])))
  p <- max(sapply(x, function(x) max(x[[3]])))
  grid::pushViewport(grid::viewport(layout = grid::grid.layout(n, p)))

  for (i in seq_len(length(x))) {
    print(x[[i]][[1]], vp = grid::viewport(layout.pos.row = x[[i]][[2]],
                                           layout.pos.col = x[[i]][[3]]))
  }
}

pdf('/data/g*/z*/covid19_neanderthals/ld_matrix_projected/results/h2_comparison.pdf',height = 5,width = 8)
output<-lay_out(list(p$a,1,1),
                list(p$b,1,2),
                list(p$c,1,3))
print(output)

dev.off()


#!/usr/bin/env Rscript

library(docopt)
library(ggplot2)

# -------------------------------------------------------------------------------------------------
script_version = '0.1.0\n'

# -------------------------------------------------------------------------------------------------
doc = '
Usage:
  svconfound.r [--csv] [--prefix=PREFIX] [--fixed=VAR]... [--model=MODEL] <input_file>
  svconfound.r -h
  svconfound.r --version

Options:
  -c, --csv  Input file is in csv format.
  -p PREFIX, --prefix=PREFIX  Set output report identifier to NAME.
  -f VAR, --fixed=VAR  Sets a variable as fixed by the experimentalist.
  -m MODEL, --model=MODEL  Sets the model to be used by the SVA step.
  -h, --help  Show this message.
  --version  Print the version.
'

# -------------------------------------------------------------------------------------------------
perform_analysis = function(values, pdata, model, fixed_vars = NULL) {
  library(sva)
  library(svconfound)

  results = list()

  # Step 1. SVD analysis.
  results$svd_results = svd_analysis(values, pdata)

  # Step 2. ComBat (optional).
  if (!is.null(fixed_vars)) {
    batch_variable = Reduce(function(xx, yy) paste(xx, yy, sep = '_'),
                            pdata[, fixed_vars, drop = FALSE])

    if (any(table(batch_variable) <= 1)) {
      warning('Some batches do not have at least two samples. Bypassing ComBat execution.')
      fixed_values = values
    } else {
      fixed_values = ComBat(values, batch_variable)
      results$fixed_svd_results = svd_analysis(fixed_values, pdata)
    }
  } else {
    fixed_values = values
  }

  # Step 3. SVA analysis.
  results$sva_results = sva_analysis(fixed_values, pdata, as.formula(model))

  return(results)
}

# -------------------------------------------------------------------------------------------------
if(!interactive()) {
  args = docopt(doc, version = script_version)

  if (is.null(args$prefix)) {
    args$prefix = strsplit(basename(args$input_file), split = '\\.')[[1]][1]
  }
  message(paste('Setting prefix to', args$prefix))

  if (is.null(args$model)) {
    args$model = '~ 1'
  }
  message(paste('Setting model to', args$model))

  if (args$csv) {
    stop('Not implemented yet!')
  } else {
    rds_object = tryCatch(readRDS(args$input_file),
                          error = function(e) {
                            stop('Input file is not a valid RDS file.')
                          })

    if (!inherits(rds_object, c('MethylSet', 'GenomicMethylSet', 'RatioSet', 'GenomicRatioSet'))) {
      stop('Input file must contain a minfi methylation object.')
    }

    values = getM(rds_object)
    pheno_data = pData(rds_object)
  }

  analysis_results = perform_analysis(values, pheno_data, args$model, args$fixed)

  write.table(analysis_results$svd_results$variance_explained,
              file = paste0(args$prefix, '.variance_explained.tsv'),
              sep = '\t', dec = '.', quote = FALSE, col.names = TRUE, row.names = FALSE)

  write.table(analysis_results$svd_results$significance,
              file = paste0(args$prefix, '.svd_significance.tsv'),
              sep = '\t', dec = '.', quote = FALSE, col.names = TRUE, row.names = FALSE)

  if (!is.null(analysis_results$fixed_svd_results)) {
    write.table(analysis_results$fixed_svd_results$variance_explained,
                file = paste0(args$prefix, '.fixed.variance_explained.tsv'),
                sep = '\t', dec = '.', quote = FALSE, col.names = TRUE, row.names = FALSE)

    write.table(analysis_results$fixed_svd_results$significance,
                file = paste0(args$prefix, '.fixed.svd_significance.tsv'),
                sep = '\t', dec = '.', quote = FALSE, col.names = TRUE, row.names = FALSE)
  }

  write.table(analysis_results$sva_results$significance,
              file = paste0(args$prefix, '.sva_significance.tsv'),
              sep = '\t', dec = '.', quote = FALSE, col.names = TRUE, row.names = FALSE)

  svg(paste0(args$prefix, '.variance_explained.svg'), width = 7, height = 7)
  plot(plot_svd_scree(analysis_results$svd_results))
  dev.off()

  svg(paste0(args$prefix, '.svd_significance.svg'), width = 7, height = 7)
  plot(plot_significance(analysis_results$svd_results))
  dev.off()

  if (!is.null(analysis_results$fixed_svd_results)) {
    svg(paste0(args$prefix, '.fixed.variance_explained.svg'), width = 7, height = 7)
    plot(plot_svd_scree(analysis_results$fixed_svd_results))
    dev.off()

    svg(paste0(args$prefix, '.fixed.svd_significance.svg'), width = 7, height = 7)
    plot(plot_significance(analysis_results$fixed_svd_results))
    dev.off()
  }

  svg(paste0(args$prefix, '.sva_significance.svg'), width = 7, height = 7)
  plot(plot_significance(analysis_results$sva_results))
  dev.off()
}


#!/usr/bin/env Rscript

args = commandArgs(TRUE)
input = args[1]
output = gsub("csv", "png", input)

nums = regmatches(input, gregexpr("[0-9]+", input))
sims = nums[[1]][1]
pop = nums[[1]][2]
prob = nums[[1]][3]
div = nums[[1]][4]
title = paste("Average Trials by Initial Group, ", sims, " Simulations\nN = ", pop,
              ", P = ", prob, "%, Divisor: ", div, sep='')

data <- read.csv(input, header=FALSE)

x11()
plot(data$V1, data$V3, type="n", main=title, xlab="Initial Group Size", ylab="Average Trials")
lines(data$V1, data$V3, type="o")

dev.print(png, output, width=1080, height=600)

Sys.sleep(1000)


library(tidyverse)
library(future.apply)

plan(multiprocess, workers = 12)

vectorized_gsea <- function(x1,x2,thres) {
  library(GeneExpressionSignature)
  x1 <- as.matrix(rank(-x1,ties.method ="random"))
  colnames(x1) <- "q"
  x2 <- apply(X = -x2, MARGIN = 2, FUN = rank, ties.method ="random")
  final_dist <- NULL
  for (j in 1:ncol(x2)) {
    ### create expression set
    merged_table <- cbind(x1,x2[,j])
    colnames(merged_table) <- c(colnames(x1),colnames(x2)[j])
    pheno <- as.data.frame(colnames(merged_table))
    rownames(pheno) <- colnames(merged_table)
    pheno_new <- new("AnnotatedDataFrame",data=pheno)
    expr_set <- new("ExpressionSet",exprs = merged_table, phenoData=pheno_new)
    ### calculate distances
    distances <- ScoreGSEA(expr_set , thres,"avg")
    final_dist[j] <-distances[1,2] #or (2,1) just not the primary diagonal
  }
  #print("lol")
  return(final_dist)
}

go_cpd_nes <- readRDS("data/GOterms/compounds/all_compounds_go.rds")
go_kd_nes <- readRDS("data/GOterms/kd/go_nes_results_kd.rds")

data <- readRDS("data/screening hits/initial_signatures_with_mycranks.rds")
kd <- readRDS("data/knockdowns/tf_kd_cgs.rds")

thresholds <- c(5,10,15,20,25,35,45,60,70) ### change for each line

go_cpd_line <- go_cpd_nes[,as.character(data$sig_id[which(data$cell_id == "A375")])] ### change for each line
go_kd_line <- go_kd_nes[,as.character(kd$sig_id[which(kd$cell_id == "A375")])] ### change for each line

distances <- NULL

for (i in 1:length(thresholds)) {
  distances[[i]] <- future_apply(go_cpd_line,MARGIN = 2,FUN = vectorized_gsea,go_kd_line,thresholds[i])
  rownames(distances[[i]]) <- colnames(go_kd_line) ### added rownames
  print(i)
}

saveRDS(distances,"distances/goterms/A375_go.rds") ### change for each line


#preamble (options, installs, imports & custom functions) ----

options(warn=1) #really should be default in R
`%!in%` = Negate(`%in%`) #should be in base R!

# specify the packages used:
required_packages = c(
	'github.com/mike-lawrence/aria/aria' # for Stan stuff
	, 'tidyverse' #for all that is good and holy
)

#load the helper functions:
# load the helper functions:
for(file in fs::dir_ls('r')){
	cat('Loading function: ',fs::path_ext_remove(fs::path_file(file)),'()\n',sep='')
	source(file)
}

#install any required packages not already present
install_if_missing(required_packages)

#load packages
library(tidyverse)
library(aria)

#import & toss too-fast
#  Demo note: just data I had on hand for this
(
	readRDS('rds/00_imported_and_cleaned.rds')
	%>% filter(!str_detect(experiment,'ANTI_Poder_Legitimidad')) #no error data in this experiment
	%>% filter(flanker!='neutral') # for demo
	%>% filter(rt>150)
	%>% mutate(lrt=log(rt))
	%>% rename(id=participant)
	%>% filter(id %in% unique(id)[1:30]) #just a few Ss for this demo
) ->
	a

# quick viz:
(
	a
	# %>% filter(lrt<6)
	%>% ggplot()
	+ facet_wrap(
		~error
		, ncol = 1
		, scales = 'free_y'
	)
	+ geom_histogram(
		mapping = aes(
			x = lrt
		)
	)
)

#set factor level order for interpretability of helmert contrasts
(
	a
	%>% mutate(
		alertness = factor(alertness,levels=c('tone','no tone'))
		, orienting = factor(orienting,levels=c('valid','invalid','none'))
		, flanker = factor(flanker,levels=c('congruent','incongruent'))
	)
) -> a

# Compute inputs to model ----

(
	a
	#add the contrast matrix columns
	%>% mutate(
		contrasts = get_contrast_matrix_rows_as_list(
			data = .
			, formula = ~ flanker # Demo note: we could do `~alertness*orienting*flanker`, but that'll take a long time to sample
			, contrast_kind = halfhelmert_contrasts
		)
	)
) -> a

#first get the unique contrasts (will serve as input to Stan)
(
	a
	%>% distinct(contrasts)
	%>% arrange(contrasts) #important
) ->
	unique_contrasts

#now cross with unique subjects
(
	unique_contrasts
	%>% expand_grid(
		tibble(id = unique(a$id))
	)
	%>% arrange(contrasts,id) #important
	# add a column containing the row index
	%>% mutate(
		row = 1:n()
	)
	#join with dat_summary
	%>% right_join(
		a
		, by = c('contrasts','id')
	)
) -> a

#now get the unique contrast matrix
(
	unique_contrasts
	%>% unnest(contrasts)
	%>% as.matrix()
) -> uw

(
	a
	%>% group_by(row)
	%>% summarise(
		cell_count_total = n()
		, cell_count_errors = sum(error)
	)
	%>% arrange(row)
) -> err_stats

# package for stan & sample ----

data_for_stan = lst( #lst permits later entries to refer to earlier entries

	####
	# Entries we need to specify ourselves
	####

	# uw: unique within predictor matrix
	w = uw

	# lrt: lrt observations
	, lrt = a$lrt[!a$error]

	# lrt_row: lrt row indicator
	, lrt_row = a$row[!a$error]

	# err_num_total: number of observations in each subject/condition
	, err_cell_count_total = err_stats$cell_count_total

	# err_num_successes: number of 1's in each subject/condition
	, err_cell_count_errors = err_stats$cell_count_errors

	# err_row: err row indicator
	, err_row = err_stats$row

	####
	# Entries computable from the above
	####

	, k = ncol(uw)
	, n = length(unique(a$id))
	, m_lrt = length(lrt_row)
	, m_err = length(err_row)
	, is_intercept = guess_if_intercept(uw)

)

#quick view
glimpse(data_for_stan)

stan_code_path = 'stan/err_lrt_loc_scale_trimvn_ncp.stan'

#take a look at the model
file.edit(stan_code_path)
#when you click save, aria will syntax check and compile

#alternatively:
aria:::check_syntax_and_maybe_compile(stan_code_path)

# compose
aria::compose(
	data = data_for_stan
	, code_path = stan_code_path
	, out_path = 'nc/samples.nc'
)

# Check & viz posterior ----

post = aria::coda('nc/samples.nc')

# Check treedepth, divergences, & rebfmi
(
	post$draws(group='sample_stats')
	%>% posterior::as_draws_df()
	%>% group_by(.chain)
	%>% summarise(
		max_treedepth = max(treedepth)
		, num_divergent = sum(divergent)
		, rebfmi = var(energy)/(sum(diff(energy)^2)/n()) #n.b. reciprocal of typical EBFMI, so bigger=bad, like rhat
	)
)

# gather summary for core parameters (inc. r̂ & ess)
(
	post$draws(groups='parameters')
	%>% posterior::summarise_draws(.cores=parallel::detectCores())
) ->
	par_summary

# show the ranges of r̂/ess's
(
	par_summary
	%>% select(rhat,contains('ess'))
	%>% summary()
)

#View those with suspect r̂
(
	par_summary
	%>% filter(rhat>1.01)
	%>% View()
)

# Viz means
(
	post$draws(variables=c('err_m','mrt_m','srt_m'))
	%>% posterior::as_draws_array()
	%>% bayesplot::mcmc_intervals()
)

# Viz condition expectations for mean log-RT
(
	post$draws(variables='lrt_emean')
	%>% posterior::as_draws_array()
	%>% bayesplot::mcmc_intervals()
)


#!/usr/bin/env Rscript
#
# Randomly draw distributions of fitness effects for variants and use those
# to simulate S&R evolution.
#
# Can either specify "all" to draw fitness effects from an exponential
# distribution, or a number to specify the number of SNPs that will have
# an effect (all others set to zero).
#

library(boot)
library(data.table)
library(dplyr)
library(dtplyr)

## Program options:
cargs = commandArgs(trailingOnly=TRUE)
genotype_file = cargs[1]
n_snps = cargs[2]
n_generations = as.numeric(cargs[3])
min_maf = as.numeric(cargs[4])
max_miss = as.numeric(cargs[5])
output_prefix = cargs[6]

## Probability that the reference allele is more fit than the alternate
ref_allele_more_fit = 0.8
if(length(cargs) > 6) {
    ref_allele_more_fit = as.numeric(cargs[7])
}

## Read in data
genotypes = fread(genotype_file, header=TRUE) %>%
    select(-pos, -contig, -rs) %>%
    as.matrix()

genotype_names = fread(genotype_file, header=TRUE) %>%
    select(pos, contig, rs)

initial_allele_freqs = apply(genotypes, 1, function(x) {
                             ref = sum(!(is.na(x)) & x == 1)
                             alt = sum(!(is.na(x)) & x == 0)
                             ref / (ref + alt)
})

## Filter data
maf = ifelse(initial_allele_freqs < 0.5, initial_allele_freqs,
             1 - initial_allele_freqs)
missingness = apply(genotypes, 1, function(x) sum(is.na(x)) / length(x))

keep = maf > min_maf & missingness < max_miss
genotypes = genotypes[keep, ]
genotype_names = genotype_names[keep, ]
initial_allele_freqs = initial_allele_freqs[keep]
maf = maf[keep]
missingness = missingness[keep]

## Draw fitness effects
if(!is.na(as.numeric(n_snps))) {
    ## Set a few SNPs to fitness effect of 1, all others = 0
    ns = as.numeric(n_snps)
    x = rep(0, nrow(genotypes))
    x[sample(1:nrow(genotypes), ns, FALSE)] = sample(c(1, -1), ns, TRUE,
                                                     prob=c(1-ref_allele_more_fit, ref_allele_more_fit))
    snp_fitness_effects = x
} else {
    ## Draw from exponential distribution for all SNPs
    snp_fitness_effects = rexp(nrow(genotypes)) * ifelse(sample(c(TRUE, FALSE), nrow(genotypes), TRUE,
                                                                prob=c(1-ref_allele_more_fit, ref_allele_more_fit)),
                                                         -1, 1)
}

## Simulate fitness of strains and calculate allele frequency and
## allele frequency change. Takes fitness effects as Wrightian (average
## number of offspring).

## 1) Column-by-column, multiply the fitness_effect of the alternate
##    allele by whether the alternate allele is present. Do this in
##    a way that doesn't give any negative numbers (if alternate allele
##    effect is negative, make it a positive effect of the ref. allele).
## 2) Row-by-row, set missing genotypes to have the average effect
## 3) Add up all the fitness effects in a strain and divide by the
##    mean across strains.
## Note that in the genotype input file 1 = reference, 0 = alternate
snp_effects =
    apply(genotypes, 2, function(x) {
          snp_fitness_effects * ifelse(snp_fitness_effects < 0, -x, 1-x)
         }) %>%
    apply(., 1, function(x) {
          mw = mean(x, na.rm=TRUE)
          ifelse(is.na(x), mw, x)
         }) %>%
    t()
fitnesses = colSums(snp_effects) / mean(colSums(snp_effects))

## Calculate final strain frequencies assuming equal starting frequencies.
## Uses Wrightian fitness (fitness = average number of offspring).
initial_strain_freqs = rep(1/length(fitnesses), length(fitnesses))
n_inds = (fitnesses^n_generations)
strain_freqs = n_inds / sum(n_inds)
stopifnot(all(strain_freqs >= 0))
relative_fitnesses = log2(strain_freqs / initial_strain_freqs)
## If fitness = 0, need to do a rough correction:
relative_fitnesses[is.na(relative_fitnesses) | is.infinite(relative_fitnesses)] =
    min(relative_fitnesses[!is.na(relative_fitnesses) & !(is.infinite(relative_fitnesses))]) - 2

## Calculate final allele frequencies
stopifnot(all(names(strain_freqs) == colnames(genotypes)))
allele_freqs = apply(genotypes, 1, function(x) {
                     ref = sum(strain_freqs[!(is.na(x)) & x == 1])
                     alt = sum(strain_freqs[!(is.na(x)) & x == 0])
                     ref / (ref + alt)
         })
stopifnot(all(allele_freqs >= 0 & allele_freqs <= 1))

## Calculate LD groups from final strain frequencies for the top 2000
## snps (by allele frequency change); note groups with ties may not
## be completely included in the top 5000. Order of ties is arbitrary.
n_ld = 5000
af_change = abs(allele_freqs - initial_allele_freqs)
af_order = order(order(af_change, decreasing=TRUE))
ld_groups_95 = numeric(length(af_change)) * NaN
grp = -1
for(i in 1:(n_ld-1)) {
    ii = which(af_order == i)
    if(!is.na(ld_groups_95[ii])) next
    grp = grp + 1
    ld_groups_95[ii] = grp
    for(j in (i+1):n_ld) {
        jj = which(af_order == j)
        if(!is.na(ld_groups_95[jj])) next
        g = cbind(genotypes[ii, ], genotypes[jj, ])
        r2 = (corr(g[!(is.na(g[, 1])) & !(is.na(g[, 2])), ],
                   w=strain_freqs[!(is.na(g[, 1])) & !(is.na(g[, 2]))]))^2
        if(is.na(r2)) {
           warning(paste('R^2 is NA at', genotype_names[['rs']][i],
                         genotype_names[['rs']][j]))
           next
         }
        if(r2 >= 0.95) {
            ld_groups_95[jj] = grp
        }
    }
}
i = n_ld
ii = which(af_order == i)
if(is.na(ld_groups_95[ii])) {
    grp = grp + 1
    ld_groups_95[ii] = grp
}

ld_groups_80 = numeric(length(af_change)) * NaN
grp = -1
for(i in 1:(n_ld-1)) {
    ii = which(af_order == i)
    if(!is.na(ld_groups_80[ii])) next
    grp = grp + 1
    ld_groups_80[ii] = grp
    for(j in (i+1):n_ld) {
        jj = which(af_order == j)
        if(!is.na(ld_groups_80[jj])) next
        g = cbind(genotypes[ii, ], genotypes[jj, ])
        r2 = (corr(g[!(is.na(g[, 1])) & !(is.na(g[, 2])), ],
                   w=strain_freqs[!(is.na(g[, 1])) & !(is.na(g[, 2]))]))^2
        if(is.na(r2)) {
           warning(paste('R^2 is NA at', genotype_names[['rs']][i],
                         genotype_names[['rs']][j]))
           next
         }
        if(r2 >= 0.80) {
            ld_groups_80[jj] = grp
        }
    }
}
i = n_ld
ii = which(af_order == i)
if(is.na(ld_groups_80[ii])) {
    grp = grp + 1
    ld_groups_80[ii] = grp
}

## Write output:

##  1. Phenotype file for Plink with fitness of strains
##     (for external association testing)
write.table(cbind(names(fitnesses), names(fitnesses), fitnesses),
            file=paste0(output_prefix, '.fitness.txt'),
            sep='\t', col.names=FALSE, row.names=FALSE, quote=FALSE)

##  2. Phenotype file with relative fitness
write.table(cbind(names(relative_fitnesses), names(relative_fitnesses), relative_fitnesses),
            file=paste0(output_prefix, '.relative_fitness.txt'),
            sep='\t', col.names=FALSE, row.names=FALSE, quote=FALSE)

##  3. Table of fitness effects and allele frequency start and end for
##     each SNP
write.table(data.frame(genotype_names, 'effect'=snp_fitness_effects,
                       'initial'=initial_allele_freqs,
                       'final'=allele_freqs,
                       'ld_95'=ld_groups_95,
                       'ld_80'=ld_groups_80),
            file=paste0(output_prefix, '.snp_effects.txt'),
            sep='\t', col.names=TRUE, row.names=FALSE, quote=FALSE)

##  4. Table of strain frequencies and fitnesses
write.table(data.frame(strain=names(fitnesses), 'fitness'=fitnesses,
                       'relative_fitness'=relative_fitnesses,
                       'initial'=initial_strain_freqs,
                       'final'=strain_freqs),
            file=paste0(output_prefix, '.strain_frequencies.txt'),
            sep='\t', col.names=TRUE, row.names=FALSE, quote=FALSE)

## 5. Phenotype file with change in strain frequency
write.table(cbind(names(strain_freqs), names(strain_freqs),
                  strain_freqs - initial_strain_freqs),
            file=paste0(output_prefix, '.strain_freqs.txt'),
            sep='\t', col.names=FALSE, row.names=FALSE, quote=FALSE)


toKilo <- function(x) (x/1024)
toMega <- function(x) (toKilo(toKilo(x)))
toGiga <- function(x) (toMega(toKilo(x)))
fromKilo <- function(x) (x*1024)
fromMega <- function(x) (fromKilo(fromKilo(x)))
fromGiga <- function(x) (fromMega(fromKilo(x)))


#' Markov Chain Monte Carlo
#'
#' A flexible implementation of the Metropolis-Hastings MCMC algorithm.
#'
#' @param fun A function. Returns the log-likelihood.
#' @param initial Either a numeric matrix or vector, or an object of class [coda::mcmc]
#' or [coda::mcmc.list] (see details).
#' initial values of the parameters for each chain (See details).
#' @param nsteps Integer scalar. Length of each chain.
#' @param nchains Integer scalar. Number of chains to run (in parallel).
#' @param cl A `cluster` object passed to [parallel::clusterApply].
#' @param thin Integer scalar. Passed to [coda::mcmc].
#' @param kernel An object of class [fmcmc_kernel].
#' @param burnin Integer scalar. Length of burn-in. Passed to
#' [coda::mcmc] as \code{start}.
#' @param multicore Logical. If `FALSE` then chains will be executed in serial.
#' @param ... Further arguments passed to \code{fun}.
#' @param conv_checker A function that receives an object of class [coda::mcmc.list],
#' and returns a logical value with `TRUE` indicating convergence.
#'
#' @details This function implements MCMC using the Metropolis-Hastings ratio with
#' flexible transition kernels. Users can specify either one of the available
#' transition kernels or define one of their own (see [kernels]). Furthermore,
#' it allows easy parallel implementation running multiple chains in parallel. In
#' addition, we incorporate a variety of convergence diagnostics, alternatively
#' the user can specify their own (see [convergence-checker]).
#'
#' We now give details of the various options included in the function.
#'
#' @section Starting point:
#'
#' By default, if `initial` is of class `mcmc`, `MCMC` will take the last `nchains`
#' points from the chain as starting point for the new sequence. If `initial` is
#' of class `mcmc.list`, the number of chains in `initial` must match the `nchains`
#' parameter.
#'
#' If `initial` is a vector, then it must be of length equal to the number of
#' parameters used in the model. When using multiple chains, if `initial` is not
#' an object of class `mcmc` or `mcmc.list`, then it must be a numeric matrix
#' with as many rows as chains, and as many columns as parameters in the model.
#'
#' @section Multiple chains:
#'
#' When \code{nchains > 1}, the function will run multiple chains. Furthermore,
#' if \code{cl} is not passed, \code{MCMC} will create a \code{PSOCK} cluster
#' using [parallel::makePSOCKcluster] with
#' [parallel::detectCores]
#' clusters and attempt to execute using multiple cores. Internally, the function does
#' the following:
#'
#' \preformatted{
#'   # Creating the cluster
#'   ncores <- parallel::detectCores()
#'   ncores <- ifelse(nchains < ncores, nchains, ncores)
#'   cl     <- parallel::makePSOCKcluster(ncores)
#'
#'   # Loading the package and setting the seed using clusterRNGStream
#'   invisible(parallel::clusterEvalQ(cl, library(fmcmc)))
#'   parallel::clusterSetRNGStream(cl, .Random.seed)
#' }
#'
#' When running in parallel, objects that are
#' used within \code{fun} must be passed through \code{...}, otherwise the cluster
#' will return with an error.
#'
#' The user controls the initial value of the parameters of the MCMC algorithm
#' using the argument `initial`. When using multiple chains, i.e., `nchains > 1`,
#' the user can specify multiple starting points, which is recommended. In such a
#' case, each row of `initial` is use as a starting point for each of the
#' chains. If `initial` is a vector and `nchains > 1`, the value is recycled, so
#' all chains start from the same point (not recommended, the function throws a
#' warning message).
#'
#' @section Automatic stop:
#'
#' By default, no automatic stop is implemented. If one of the functions in
#' [convergence-checker] is used, then the MCMC is done by bulks as specified
#' by the convergence checker function, and thus the algorithm will stop if,
#' the `conv_checker` returns `TRUE`. For more information see [convergence-checker].
#'
#' @return An object of class [coda::mcmc] from the \CRANpkg{coda}
#' package. The \code{mcmc} object is a matrix with one column per parameter,
#' and \code{nsteps} rows. If \code{nchains > 1}, then it returns a [coda::mcmc.list].
#'
#' @export
#' @examples
#' # Univariate distributed data with multiple parameters ----------------------
#' # Parameters
#' set.seed(1231)
#' n <- 1e3
#' pars <- c(mean = 2.6, sd = 3)
#'
#' # Generating data and writing the log likelihood function
#' D <- rnorm(n, pars[1], pars[2])
#' fun <- function(x) {
#'   x <- log(dnorm(D, x[1], x[2]))
#'   sum(x)
#' }
#'
#' # Calling MCMC, but first, loading the coda R package for
#' # diagnostics
#' library(coda)
#' ans <- MCMC(
#'   fun, initial = c(mu=1, sigma=1), nsteps = 2e3,
#'   kernel = kernel_reflective(scale = .1, ub = 10, lb = 0)
#'   )
#'
#' # Ploting the output
#' oldpar <- par(no.readonly = TRUE)
#' par(mfrow = c(1,2))
#' boxplot(as.matrix(ans),
#'         main = expression("Posterior distribution of"~mu~and~sigma),
#'         names =  expression(mu, sigma), horizontal = TRUE,
#'         col  = blues9[c(4,9)],
#'         sub = bquote(mu == .(pars[1])~", and"~sigma == .(pars[2]))
#' )
#' abline(v = pars, col  = blues9[c(4,9)], lwd = 2, lty = 2)
#'
#' plot(apply(as.matrix(ans), 1, fun), type = "l",
#'      main = "LogLikelihood",
#'      ylab = expression(L("{"~mu,sigma~"}"~"|"~D))
#' )
#' par(oldpar)
#'
#' \dontrun{
#' # In this example we estimate the parameter for a dataset with ----------------
#' # With 5,000 draws from a MVN() with parameters M and S.
#'
#' # Loading the required packages
#' library(mvtnorm)
#' library(coda)
#'
#' # Parameters and data simulation
#' S <- cbind(c(.8, .2), c(.2, 1))
#' M <- c(0, 1)
#'
#' set.seed(123)
#' D <- rmvnorm(5e3, mean = M, sigma = S)
#'
#' # Function to pass to MCMC
#' fun <- function(pars) {
#'   # Putting the parameters in a sensible way
#'   m <- pars[1:2]
#'   s <- cbind( c(pars[3], pars[4]), c(pars[4], pars[5]) )
#'
#'   # Computing the unnormalized log likelihood
#'   sum(log(dmvnorm(D, m, s)))
#' }
#'
#' # Calling MCMC
#' ans <- MCMC(
#'   initial = c(mu0=5, mu1=5, s0=5, s01=0, s2=5),
#'   fun,
#'   kernel  = kernel_reflective(
#'     lb    = c(-10, -10, .01, -5, .01),
#'     ub    = 5
#'     scale = 0.01
#'   ),
#'   nsteps  = 1e5,
#'   thin    = 20,
#'   burnin  = 5e3
#' )
#'
#' # Checking out the outcomes
#' plot(ans)
#' summary(ans)
#'
#' # Multiple chains -----------------------------------------------------------
#'
#' # As we want to run -fun- in multiple cores, we have to
#' # pass -D- explicitly (unless using Fork Clusters)
#' # just like specifying that we are calling a function from the
#' # -mvtnorm- package.
#'
#' fun <- function(pars, D) {
#'   # Putting the parameters in a sensible way
#'   m <- pars[1:2]
#'   s <- cbind( c(pars[3], pars[4]), c(pars[4], pars[5]) )
#'
#'   # Computing the unnormalized log likelihood
#'   sum(log(mvtnorm::dmvnorm(D, m, s)))
#' }
#'
#' # Two chains
#' ans <- MCMC(
#'   initial = c(mu0=5, mu1=5, s0=5, s01=0, s2=5),
#'   fun,
#'   nchains = 2,
#'   kernel  = kernel_reflective(
#'     lb    = c(-10, -10, .01, -5, .01),
#'     ub    = 5
#'     scale = 0.01
#'   ),
#'   nsteps  = 1e5,
#'   thin    = 20,
#'   burnin  = 5e3,
#'   D       = D
#' )
#'
#' summary(ans)
#' }
#'
#' @aliases Metropolis-Hastings
MCMC <- function(
  initial,
  fun,
  nsteps,
  ...,
  nchains      = 1L,
  burnin       = 0L,
  thin         = 1L,
  kernel       = kernel_normal(),
  multicore    = FALSE,
  conv_checker = NULL,
  cl           = NULL
) UseMethod("MCMC")

#' @export
#' @rdname MCMC
MCMC.mcmc <- function(
  initial,
  fun,
  nsteps,
  ...,
  nchains      = 1L,
  burnin       = 0L,
  thin         = 1L,
  kernel       = kernel_normal(),
  multicore    = FALSE,
  conv_checker = NULL,
  cl           = NULL
) {

  MCMC.default(
    initial      = utils::tail(initial, nchains - 1L),
    fun          = fun,
    nsteps       = nsteps,
    ...,
    nchains      = nchains,
    burnin       = burnin,
    thin         = thin,
    kernel       = kernel,
    multicore    = multicore,
    conv_checker = conv_checker,
    cl           = cl
  )

}

#' @export
#' @rdname MCMC
MCMC.mcmc.list <- function(
  initial,
  fun,
  nsteps,
  ...,
  nchains      = 1L,
  burnin       = 0L,
  thin         = 1L,
  kernel       = kernel_normal(),
  multicore    = FALSE,
  conv_checker = NULL,
  cl           = NULL
) {

  if (nchains != length(initial))
    stop(
      "The parameter `nchains` must equal the number of chains passed by ",
      "`initial`.", call. = FALSE
      )

  MCMC.default(
    initial      = do.call(rbind, utils::tail(initial, 0)),
    fun          = fun,
    nsteps       = nsteps,
    ...,
    nchains      = nchains,
    burnin       = burnin,
    thin         = thin,
    kernel       = kernel,
    multicore    = multicore,
    conv_checker = conv_checker,
    cl           = cl
  )

}

#' @export
#' @rdname MCMC
MCMC.default <- function(
  initial,
  fun,
  nsteps,
  ...,
  nchains      = 1L,
  burnin       = 0L,
  thin         = 1L,
  kernel       = kernel_normal(),
  multicore    = FALSE,
  conv_checker = NULL,
  cl           = NULL
  ) {

  # # if the coda package hasn't been loaded, then return a warning
  # if (!("package:coda" %in% search()))
  #   warning("The -coda- package has not been loaded.", call. = FALSE, )

  # Checking initial argument
  initial <- check_initial(initial, nchains)

  if (multicore && nchains == 1L)
    stop("When `multicore = TRUE`, `nchains` should be greater than 1.",
         call. = FALSE)

  if (nchains < 1L)
    stop("`nchains` must be an integer greater than 1.", call. = FALSE)

    # Checkihg burnins
  if (burnin >= nsteps)
    stop("-burnin- (",burnin,") cannot be >= than -nsteps- (",nsteps,").", call. = FALSE)

  # Checking thin
  if (thin >= nsteps)
    stop("-thin- (",thin,") cannot be > than -nsteps- (",nsteps,").", call. = FALSE)

  if (thin < 1L)
    stop("-thin- should be >= 1.", call. = FALSE)

  # Filling the gap on parallel
  if (multicore && !length(cl)) {

    # Creating the cluster
    ncores <- parallel::detectCores()
    ncores <- ifelse(nchains < ncores, nchains, ncores)
    cl     <- parallel::makePSOCKcluster(ncores)

    # Loading the package and setting the seed using clusterRNGStream
    invisible(parallel::clusterEvalQ(cl, library(fmcmc)))
    parallel::clusterSetRNGStream(cl, .Random.seed)

    on.exit(parallel::stopCluster(cl))
  }

  if (nchains > 1L) {

    # Preparing the call for multicore
    fmcmc_call <- as.call(
      c(
        if (multicore)
          list(quote(parallel::clusterApply), cl=quote(cl), x = quote(1L:nchains))
        else
          list(quote(lapply), X = quote(1L:nchains)),
        list(
          FUN = quote(function(
            i, fun., initial., nsteps., thin., kernel., burnin., ...) {

          MCMC(
            fun          = fun.,
            ...,
            initial      = initial.[i, , drop = FALSE],
            nsteps       = nsteps.,
            burnin       = burnin.,
            thin         = thin.,
            kernel       = kernel.,
            nchains      = 1L,
            multicore    = FALSE,
            cl           = NULL,
            conv_checker = NULL
            )

        }),
        fun.     = quote(fun),
        initial. = quote(initial),
        nsteps.  = quote(nsteps),
        burnin.  = quote(burnin),
        thin.    = quote(thin),
        kernel.  = quote(kernel),
        quote(...)
        )
      )
    )

    # updating names
    if (multicore)
      names(fmcmc_call)[names(fmcmc_call) == "FUN"] <- "fun"

    fmcmc_call <- as.call(list(quote(do.call),quote(coda::mcmc.list), fmcmc_call))

  } else if (!is.null(conv_checker)) {

    # If not multicore, still we need to make sure that we are passing some
    # variables as symbols and not as constants. As in the convergence checker
    # function we modify the current environment in order to adapt the algorithm.
    fmcmc_call              <- match.call()
    fmcmc_call$fun          <- quote(fun)
    fmcmc_call$nsteps       <- quote(nsteps)
    fmcmc_call$thin         <- quote(thin)
    fmcmc_call$burnin       <- quote(burnin)
    fmcmc_call$conv_checker <- enquote(NULL)

  }

  # If conv_checker, we run it with the conv checker and return. Notice that
  # we already adapted the code for the case in which we are runing multiple
  # chains
  if (!is.null(conv_checker)) {

    fmcmc_call <- call(
      "with_autostop",
      fmcmc_call,
      conv_checker = quote(conv_checker)
      )

    ans <- eval(fmcmc_call)
    return(ans)

  # If we are not using conv_checker, but still have multiple chains, then
  # we still have to run this somewhat recursively.
  } else if (nchains > 1L) {
    ans <- eval(fmcmc_call)
    return(ans)
  }

  # Adding names
  initial <- initial[1,,drop=TRUE]
  cnames  <- names(initial)

  # Wrapping function. If ellipsis is there, it will wrap it
  # so that the MCMC call only uses a single argument
  passedargs <- names(list(...))
  # print(match.call())
  funargs    <- methods::formalArgs(eval(fun))

  # Compiling
  # cfun <- compiler::cmpfun(fun)

  # ... has extra args
  if (length(passedargs)) {
    # ... has stuff that fun doesnt
    if (any(!(passedargs %in% funargs))) {

      stop("The following arguments passed via -...- are not present in -fun-:\n - ",
           paste(setdiff(passedargs, funargs), collapse=",\n - "),".\nThe function",
           "was expecting:\n - ", paste0(funargs, collapse=",\n - "), ".", call. = FALSE)

    # fun has stuff that ... doesnt
    } else if (length(funargs) > 1 && any(!(funargs[-1] %in% passedargs))) {

      stop("-fun- requires more arguments to be passed via -...-.", call. = FALSE)

    # Everything OK
    } else {

      f <- function(z) {
        fun(z, ...)
      }

    }
  # ... doesnt have extra args, but funargs does!
  } else if (length(funargs) > 1) {

    stop("-fun- has extra arguments not passed by -...-.", call. = FALSE)

  # Everything OK
  } else {

    f <- function(z) fun(z)

  }

  # MCMC algorithm -----------------------------------------------------------

  theta0 <- initial
  theta1 <- theta0
  f0     <- f(theta0)
  f1     <- f(theta1)

  # The updates can be done jointly or sequentially
  klogratio <- kernel$logratio(environment())
  if (length(klogratio) > 1L) {
    joint_rate <- FALSE
    R   <- matrix(stats::runif(nsteps * length(initial)), nrow = nsteps)
    R[] <- log(R)
  } else {
    joint_rate <- TRUE
    R <- matrix(log(stats::runif(nsteps)), nrow = nsteps)
  }

  ans <- matrix(ncol = length(initial), nrow = nsteps,
                dimnames = list(1:nsteps, cnames))

  for (i in 1L:nsteps) {
    # Step 1. Propose
    theta1[] <- kernel$proposal(environment())
    f1       <- f(theta1)

    # Checking f(theta1) (it must be a number, can be Inf)
    if (is.nan(f1) | is.na(f1) | is.null(f1))
      stop(
        "fun(par) is undefined (", f1, ")",
        "Check either -fun- or the -lb- and -ub- parameters.",
        call. = FALSE
      )

    # Step 2. Hastings ratio
    klogratio <- kernel$logratio(environment())
    if (joint_rate) {

      if (R[i] < klogratio) {
        theta0 <- theta1
        f0     <- f1
      }

    } else {

      klogratio <- (R[i, ] < klogratio)
      theta0[klogratio] <- theta1[klogratio]

    }

    # Step 3. Saving the state
    ans[i,] <- theta0

  }

  # Thinning the data
  if (burnin) ans <- ans[-c(1:burnin), , drop = FALSE]
  if (thin)   ans <- ans[(1:nrow(ans) %% thin) == 0, , drop = FALSE]

  # Returning an mcmc object from the coda package
  return(
    coda::mcmc(
      ans,
      start = as.integer(rownames(ans)[1]),
      end   = as.integer(rownames(ans)[nrow(ans)]),
      thin  = thin
      )
    )

}


# Carregando os dados
diabetes = read.csv(file = 'C:/Users/Makson/Documents/GitHub/Aprendendo-R/ENAP Analise de Dados/diabetes.csv')
head(diabetes)

# Preparacao dos dados
str(diabetes)

# Verificando NaN
colSums(is.na(diabetes))

# Explorando os dados
diabetes$Outcome = as.factor(diabetes$Outcome)

summary(diabetes$Insulin) # Media, Mediana, Min e Max
boxplot(diabetes$Insulin) #bloxplot

# Analise exploratoria
boxplot(diabetes)

hist(diabetes$Pregnancies)
hist(diabetes$Age)
hist(diabetes$BMI)

library(dplyr)
diabetes2 = diabetes %>% filter(Insulin <= 250)
boxplot(diabetes2$Insulin)

# Construcao do modelo
install.packages('caTools')
library(caTools) # Pacote para dividir entre treino e teste

set.seed(123)
index = sample.split(diabetes2$Pregnancies, SplitRatio = .70) # Dividindo o pacote entre treino e teste
index

# Criando novos conjuntos de dados Train e Test
train = subset(diabetes2, index == TRUE)
test = subset(diabetes2, index == FALSE)

# Verificando as dimensoes dos datasets
dim(diabetes2)
dim(train)
dim(test)

# Instalando pacote para criacao do modelo
install.packages('caret')
install.packages('e1071')

# Carregando os pacotes
library(caret)
library(e1071)

# Criacao do modelo baseado no algoritmo KNN
modelo = train(Outcome ~., data = train, method = 'knn')

# Verificando as metricas
modelo$results
modelo$bestTune

# Testando outros valores de K
modelo2 = train(Outcome ~., data = train, method = 'knn', tuneGrid = expand.grid(k = c(1:20)))
modelo2$results
modelo2$bestTune

plot(modelo2)

# Criando outro modelo
modelo3 = train(Outcome ~., data = train, method = 'naive_bayes')
modelo3$results
modelo3$bestTune

# Testando o modelo SVM
sed.seed(100)
modelo4 = train(Outcome ~., data = train, method = 'svmRadialSigma', preProcess = c('center'))
modelo4$results
modelo3$bestTune

# Avaliando o modelo, predicao
predicoes = predict(modelo4, test)
predicoes

# Comparacao com o conjunto de treino na matriz de confusao
confusionMatrix(predicoes, test$Outcome)

# Realizando predicoes
novos.dados = data.frame(Pregnancies = c(3),
    Glucose = c(111.50),
    BloodPressure = c(70),
    SkinThickness = c(20),
    Insulin = c(47.09),
    BMI = c(30.80),
    DiabetesPedigreeFunction = c(0.34),
    Age = c(28))
novos.dados

# Previsao
previsao = predict(modelo4, novos.dados)
resultado = ifelse(previsao == 1, 'Positivo', 'Negativo')
print(paste('Resultado', resultado))

# Visualizacao dos resultados
write.csv(predicoes, 'resultado.csv')


####################################################################
#
# process and analyze geochemistry data from California's
# Groundwater Ambient and Monitoring Assessment (GAMA) program
#
# by Walt McNab, Ph.D.
#
# functionality includes quantifying relationships between parameters
# including principal components analysis and analysis of spatial
# correlation
#
####################################################################

### environment ###

setwd("D:/GAMA")
require(compiler)
enableJIT(3)
library(reshape)
library(corrplot)
library(ncf)

### supporting functions ###

Definitions <- function(){
  # assign general definitions in a function ###
	analytes <- c("CA","CL","K","MG","MN","NO3N","SO4","SODIUM")
	attribs <- c("WELL.NAME","APPROXIMATE.LATITUDE","APPROXIMATE.LONGITUDE", "DATE", "COUNTY", "CHEMICAL","CONC", "DATASET_CAT")
	well_features <- attribs[(attribs!="DATE") & (attribs!="CHEMICAL") & (attribs!="CONC")]
	sources <- c("DDW", "ENVIRONMENTAL MONITORING (WELLS)", "WATER SUPPLY (WELLS)")
	loc_dlat <- 0.004           # latitude wiggle (water supply well locations are imprecise and sometimes overlap)
	loc_dlong <- 0.006           # longitude wiggle
	col_names <- c(well_features, c("DATE"), analytes)
	return(list(analytes, attribs, well_features, sources, loc_dlat, loc_dlong, col_names))
	}

WellProps <- function(gama_data, well_features, sources, loc_dlat, loc_dlong){
  # generate a dataframe summarizing well characteristics
  gama_subset <- subset(gama_data, select=well_features)
  well_data <- unique(gama_subset, well_features=FALSE)
  # slightly randomize locations for water supply wells (to make them visible on a map)
  dlat <- runif(nrow(well_data),-0.5*loc_dlat,loc_dlat)
  dlong <- runif(nrow(well_data),-0.5*loc_dlong,loc_dlong)
  ws_match <- (well_data$DATASET_CAT != "ENVIRONMENTAL MONITORING (WELLS)")
  well_data$APPROXIMATE.LATITUDE <- ws_match*dlat + well_data$APPROXIMATE.LATITUDE
  well_data$APPROXIMATE.LONGITUDE <- ws_match*dlong + well_data$APPROXIMATE.LONGITUDE
  return (well_data)
  }

FillMissing <- function(data_set, full_set_names){
  # fill in missing parameters as NAs so that each county data set is compatible
  missing_names <- setdiff(full_set_names, colnames(data_set))
  data_set[,missing_names] <- NA
  return(data_set)
  }

Correlogram <- function(data_set, z_set, w_set=NULL){
  # compute and plot selected (cross-)correlograms (nothing is returned; plots are simply generated)
  cat("Computing correlogram ...\n")
  correl <- correlog(x=data_set$APPROXIMATE.LONGITUDE,
                     y=data_set$APPROXIMATE.LATITUDE,
                     z=z_set,
                     w=w_set,
                     increment=5,   # a 5-km distance class seems to work with this set
                     resamp=50,
                     latlon=TRUE,
                     quiet=TRUE)
  plot(correl)
  }

### input and output functions ###

GetGama <- function(file_name, analytes, attribs, well_features, sources, loc_dlat, loc_dlong, col_names){
  # read in GAMA data set for an indivudal county
  data_set <- read.csv(file=file_name, sep='\t', header=TRUE, stringsAsFactors=FALSE)
  data_set$CHEMICAL[is.na(data_set$CHEMICAL)] <- "SODIUM"               # rename "NA" as "SODIUM"
  data_set$CHEMICAL <- as.character(data_set$CHEMICAL)
  data_set <- subset(data_set, (data_set$CHEMICAL %in% analytes)==TRUE)
  data_set$DATE <- as.Date(data_set$DATE, "%m/%d/%Y")   								# convert date column to date data type
  u_match_1 <- (data_set$UNITS == "UG/L")  												# convert micrograms/L to milligrams/L, if present
  data_set$RESULT <- u_match_1*0.001*data_set$RESULT + (1-u_match_1)*data_set$RESULT
  nd_match_1 <- (data_set$QUALIFIER == "<") 											# process non-detects
  data_set$CONC <- nd_match_1*0.5*data_set$RESULT + (1-nd_match_1)*data_set$RESULT
  data_set <- subset(data_set, CONC > 0) 												# remove rows with reported conc = 0 (or CONC < 0)
  data_set$CONC <-log10(data_set$CONC)                # assume all parameter distributions are lognormal
  data_set <- data_set[attribs]
  well_data <- WellProps(data_set, well_features, sources, loc_dlat, loc_dlong)   # create separate table of unique well properties

  # for water supply wells (assumed to have unique names; need consistent locations)
  ws_data_set <- data_set[(data_set$DATASET_CAT != "ENVIRONMENTAL MONITORING (WELLS)"),]
  ws_data_set <- cast(ws_data_set, WELL.NAME + DATE ~ CHEMICAL, value = "CONC", fun.aggregate=mean)        # pivot the data
  ws_data_set <- merge(ws_data_set, well_data, by = c("WELL.NAME"))   # merge well properties and chemical concentration data
  ws_data_set <- FillMissing(ws_data_set, col_names)

  # for environmental monitoring wells (names may be non-unique, but coordinates are ...)
  em_data_set <- data_set[(data_set$DATASET_CAT == "ENVIRONMENTAL MONITORING (WELLS)"),]
  em_data_set <- cast(em_data_set, WELL.NAME + APPROXIMATE.LATITUDE + APPROXIMATE.LONGITUDE + COUNTY + DATASET_CAT + DATE ~ CHEMICAL, value = "CONC", fun.aggregate=mean)        # pivot the data
  em_data_set <- FillMissing(em_data_set, col_names)

  # combine both sets and return
  full_data_set <- rbind(ws_data_set, em_data_set)
  return(full_data_set)
  }

GetCounties <- function(){
  # read in list of county GAMA data files and return
  county_data <- read.table("counties.txt", colClasses=c("character"))
  county_files <- county_data$V1
  return(county_files)
  }

### main script ###

GamaGeochem <- function(d_mode){

  def_output <- Definitions() 			# basic problem definitions (analayte list, data sources, etc.)
  analytes <- def_output[[1]]
  attribs <- def_output[[2]]
  well_features <- def_output[[3]]
  sources <- def_output[[4]]
  loc_dlat <- def_output[[5]]
  loc_dlong <- def_output[[6]]
  col_names <- def_output[[7]]

  if (d_mode==1){
    county_files <- GetCounties()           # read county GAMA data files
    for (i in 1:length(county_files)){ 					# read and process county GAMA data files, turn all of it into one composite pivot table
      # read in data by county
      cat("Processing ", county_files[i], "\n")
      county_data <- GetGama(county_files[i], analytes, attribs, well_features, sources, loc_dlat, loc_dlong, col_names)
      # append to composite data set
      if (i==1) {gama_data <- county_data}
      else {gama_data <- rbind(gama_data, county_data)}
      }
    write.csv(gama_data, file = "all_data.csv", row.names = FALSE)
    }
  else {gama_data <- read.csv(file="all_data.csv", sep=',', header=TRUE)}

  # filter out all NAs and note ratios
  gama_data <- na.omit(gama_data)

  # plot histograms for Cl-normalized concentrations
  hist(gama_data$CA-gama_data$CL, main="Calcium/Chloride", xlab="log(Ca/Cl)", col="red", breaks=40)
  hist(gama_data$K-gama_data$CL, main="Potassium/Chloride", xlab="log(K/Cl)", col="orange", breaks=40)
  hist(gama_data$MG-gama_data$CL, main="Magnesium/Chloride", xlab="log(Mg/Cl)", col="yellow", breaks=40)
  hist(gama_data$NO3N-gama_data$CL, main="Nitrate/Chloride", xlab="log(NO3N/Cl)", col="green", breaks=40)
  hist(gama_data$SO4-gama_data$CL, main="Sulfate/Chloride", xlab="log(SO4/Cl)", col="blue", breaks=40)
  hist(gama_data$SODIUM-gama_data$CL, main="Sodium/Chloride", xlab="log(Na/Cl)", col="violet", breaks=40)
  hist(gama_data$MN-gama_data$CL, main="Manganese/Chloride", xlab="log(Mn/Cl)", col="red", breaks=40)

  # conduct principal components analysis
  M1 <- cor(gama_data[analytes])
  corrplot.mixed(M1)
  pca_set <- gama_data[analytes]
  pca_object <- prcomp(pca_set)
  print(summary(pca_object))
  print(pca_object$rotation)
  gama_data <- cbind(gama_data, pca_object$x)
  M2 <- cor(cbind(gama_data[analytes], pca_object$x))
  corrplot.mixed(M2)

  # write all (time-dependent) results to summary output files
  gama_data$PC2 <--gama_data$PC2
  gama_data$PC3 <--gama_data$PC3
  gama_data$PC5 <--gama_data$PC5
  write.csv(gama_data, file = "gama_data.csv", na = "", row.names = FALSE)

  # note standard deviationsin temporal data in each well
  sd_data <- aggregate(gama_data[colnames(pca_object$x)],
                        by=list(gama_data$WELL.NAME,
                                gama_data$APPROXIMATE.LATITUDE,
                                gama_data$APPROXIMATE.LONGITUDE,
                                gama_data$COUNTY,
                                gama_data$DATASET_CAT),
                        FUN=sd)
  colnames(sd_data)[1:5] = well_features
  sd_data <- na.omit(sd_data)
  write.csv(sd_data, file = "gama_sd.csv", na = "", row.names = FALSE)

  # create time-averaged PCA data frame for a subset of counties
  short_list <- c("SAN JOAQUIN", "STANISLAUS", "MERCED", "MADERA", "FRESNO", "KINGS", "TULARE",
                  "CALAVERAS", "TUOLUMNE", "MARIPOSA")
  agg_data <- aggregate(gama_data[colnames(pca_object$x)],
                        by=list(gama_data$WELL.NAME,
                                gama_data$APPROXIMATE.LATITUDE,
                                gama_data$APPROXIMATE.LONGITUDE,
                                gama_data$COUNTY,
                                gama_data$DATASET_CAT),
                        FUN=sd)
  colnames(agg_data)[1:5] = well_features
  agg_data <- subset(agg_data, (agg_data$COUNTY %in% short_list)==TRUE)
  write.csv(agg_data, file = "agg_data.csv", na = "", row.names = FALSE)

  # plot selected correlograms
  for (i in 1:3){Correlogram(agg_data, agg_data[,colnames(pca_object$x)[i]])}
  Correlogram(agg_data, agg_data$PC1, agg_data$PC2)
  Correlogram(agg_data, agg_data$PC1, agg_data$PC3)
  Correlogram(agg_data, agg_data$PC2, agg_data$PC5)

  # plot local indicators of spatial association (LISA) for PCs
  for (i in 1:5){
    cat("LISA calcs ...", i, "\n")
    lisa_plot <- lisa(agg_data$APPROXIMATE.LONGITUDE,
                agg_data$APPROXIMATE.LATITUDE,
                agg_data[,colnames(pca_object$x)[i]],
                neigh=50, resamp=50,  latlon = TRUE, quiet = TRUE)
    plot(lisa_plot)
    }

  print ("Done.")

}

### run script ###

data_mode <- 2 						# data mode=1 --> read GAMA data from individual state files; data_mode=2 --> read from single .csv file
GamaGeochem(data_mode)


#!/usr/bin/env R
#
# longest_branch_alive.R
#
# author = thomas huber
# mail = thomas.huber@evobio.eu
#
# script to infer the branch lengths and topologies for given snp set
# input: (1) folder, which has SNP fasta files of replicates
#
# output: nexus files of bionj trees of hamming distances for dataset
#

# setwd('/Users/Thomsn/Downloads')

library(ape)
library(phangorn)
library(stringr)

##### constants #####
ARGS = commandArgs(trailingOnly = TRUE)

setwd(ARGS[1])
# setwd('/Users/Thomsn/Desktop/Studium/MEME Programme [current]/Universite de Montpellier [Sem2]/internship_scornavacca_lab/git_lab/phylogenetto/data/real_data/vitis/phylonet/2020_04_vitis_USA_2_summary_20_reps')
all_dirs = list.dirs()
rep_dirs = all_dirs[grep('rep_', all_dirs)]
for (rep_dir in rep_dirs){
  for (s_file in c('/rep_std_asgnmt.fasta', '/rep_new_asgnmt.fasta')){
    sp_file = paste(rep_dir,s_file, sep = '')
    x = read.phyDat(sp_file, format = "fasta", type = "DNA")
    mat = dist.hamming(x, ratio = TRUE, exclude = "none")
    tree = bionj(mat)

    ## the headers need to be adjusted! ##
    splits = sapply(tree$tip.label, function(e) strsplit(e, '[|]'))
    new_labels = c()
    for (spl in splits){
      #  --- taxa not neccessary for label --- #
      # pasta = strsplit(spl[1], '[.]')
      # tax = tolower(paste(pasta[[1]], collapse = ''))

      rasta = strsplit(spl[2], '[_]')
      ind = str_sub(tolower(paste(rasta[[1]], collapse = ''))[1], -10, -1)
      new_labels = c(new_labels, ind)
    }
    tree$tip.label = new_labels

    ## save nexus file ##
    nex_file = paste(strsplit(sp_file, 'rep_')[1],'_topo.nex', sep = '')
    write.nexus(tree, file = nex_file, translate = FALSE)
  }
}


# Use filter to create a new data frame no_south

no_south <- filter(murders, region != "South") #this is case sensitive and will not work properly as "south"

# Use nrow() to calculate the number of rows

nrow(no_south)


library(xcms)
directory <- "F:/Jian_Guo/IPA_paper_ver2_20210421/Response_20210805/EICexampleformetaboliteSTD"
setwd(directory)
input.file <- list.files(pattern = ".mzXML")
csv.file <- list.files(pattern = ".csv")
featureTable <- read.csv(csv.file[1], header = T, stringsAsFactors = F)
xraw <- xcmsRaw(input.file[1],profstep=0, mslevel = 1)
plot.matrix <- featureTable
if(nrow(plot.matrix)!=0){
  for(k in 1:nrow(plot.matrix)){
    rt.lower.limit <- plot.matrix$rt[k] - 60
    rt.upper.limit <- plot.matrix$rt[k] + 60
    mass.lower.limit <- plot.matrix$mz[k] - 0.01
    mass.upper.limit <- plot.matrix$mz[k] + 0.01
    mzRange <- as.double(cbind(mass.lower.limit, mass.upper.limit))
    RTRange <- as.integer(cbind(rt.lower.limit, rt.upper.limit))
    eeic <- rawEIC(xraw, mzrange=mzRange, rtrange=RTRange) #extracted EIC object
    points <- cbind(xraw@scantime[eeic$scan], eeic$intensity)
    png(file = paste0(rownames(plot.matrix)[k], ".png"),
        width = 480, height = 480)
    eic <- plot(points, type="l", main= plot.matrix$name[k], xlab="Seconds",
                ylab="Intensity", xlim=RTRange)
    dev.off()
  }
}


library(qdapTools)
library(tidyverse)
library(dplyr)

#if (!requireNamespace("BiocManager", quietly=TRUE))
#  install.packages("BiocManager")
#BiocManager::install("ComplexHeatmap")
#library(ComplexHeatmap)
#install.packages("FactoMineR")

rm(list=ls())

cat("\014")

# Import all hits of all devices with dependent issue
``
setwd("D:/nils/projects/dissertation")

dependent_issue <- 'long_cpu_hog_prod126'

file_in <- paste('./', dependent_issue, '.csv', sep = '')

file_out <- './dataset_cpu_hog-exp2.csv'

df0 <- read_csv(file_in)

#df0 <- read_csv('./data1k.csv')

df <- head(df0, 10000000)

# keeps hits of the same issue where the severity changes (so removes duplicates)
#df <- df0 %>% arrange(hit_issue_id, hit_date) %>%
#              filter(hit_issue_id != lag(hit_issue_id, default = 0) |
#              hit_severity != lag(hit_severity) &
#              hit_issue_id == lag(hit_issue_id))

df0

# add dependent variable y
df <- df %>% mutate(y = ifelse(hit_module == 'long_cpu_hog_Prod126' &
                        hit_severity >= 2, 1, 0))

# Sort by device_id and hit_date - make y an integer
df <- arrange(df, device_id, hit_date)

df$y <- as.numeric(df$y)

summary(df$y)

sum(df$y)

glimpse(df)

head(df)

df <- df %>%
  select(hit_date, device_id, hit_module, hit_severity, y)

df <- df %>%
  filter(str_detect(hit_module, 'memory|cpu'))

# Remove hit_severity=0
# df <- df  %>% filter(hit_severity!=0)

df %>%
  count(hit_module)

glimpse(df)
View(df)
#df1 <- cbind(df, dummy(df$hit_module, sep = "_"))

#glimpse(df1)

#df1 <- aggregate(hit_module ~ ., df, toString)

df1 <- df %>%
  group_by(hit_date,device_id,hit_severity,y) %>%
  summarise(hit_module=paste(hit_module, collapse = ":"))

View(df1)

xy0 <- mtabulate(strsplit(df1$hit_module, ':'))

View(xy0)

xy0 <- xy0 %>%
  mutate_if(~is.integer(.) && any(. > 0, na.rm = TRUE),
            ~ if_else(.x>0,1L,.x))

#Removing labels/features with less than 500 hits
xy0 <- xy0[, colSums(xy0) > 500]

xy <- xy0 %>%
  #add_column(df$device_id, .before = 1) %>%
  add_column(df1$hit_severity) %>%
  add_column(df1$y)

xy <- xy %>% rename(
  #device_id = 'df$device_id',
  hit_severity = 'df1$hit_severity',
  y = 'df1$y'
)

xy <- xy %>%
  select(y, everything()) # %>% # move the Y variable to the "front"
  #rename_at(vars(2:ncol(.)), ~ paste("X", 1:length(.), sep = ""))

#Removing 00000 rows

zero_rows <- xy %>%
  select(-hit_severity) %>%
  rowSums() > 0

xy <- xy %>%
  filter(zero_rows)

# Remove hit_severity=0
#xy <- xy  %>% filter(hit_severity!=0)

names(xy)
colSums(xy)
summary(xy)
head(xy)

View(xy)

write_csv(xy, file_out)


model_plotR <- function(Result = NULL, mcmc_pars = NULL, T_predict = NULL, T_simu = NULL, n_period, data,
                        data_test = NULL, data_initial, call, save_plots = TRUE, trace_plot.common_axis = FALSE, model = "Multinomial", ...){

  if(call == "estimateR"){
    ## Trace plot
    pars_estimate = mcmc_pars
    pars_estimate_df = data.frame(value = as.vector(pars_estimate),
                                  variable_name = rep(c("beta", "r", "R0"), each = nrow(pars_estimate)*ncol(pars_estimate)/3),
                                  variable_index = rep(rep(as.character(1:(ncol(pars_estimate)/3)), each = nrow(pars_estimate)), times = 3),
                                  iteration = rep(1:nrow(pars_estimate), times = ncol(pars_estimate)))

    library(ggplot2)

    trace_plot_theme <-   theme_minimal() +
      theme(
        plot.title         = element_text(size = 18, face = "bold"),
        plot.subtitle      = element_text(size = 16, color = "#36454f"),
        plot.caption       = element_text(hjust = 0, size = 16, lineheight = 1.1),
        axis.text.x        = element_text(size = 16, color = "#36454f", angle = 45),
        axis.text.y        = element_text(size = 16, color = "#36454f"),
        axis.title         = element_text(size = 16, face = "italic"),
        strip.text.x       = element_text(size = 16, color = "white"),
        strip.text.y       = element_text(size = 16, color = "white"),
        legend.title       = element_blank() ,
        legend.text        = element_text(size = 16) ,
        panel.grid.major.x = element_line(),
        panel.grid.major.y = element_line(),
        panel.grid.minor.x = element_line(),
        panel.grid.minor.y = element_line(),
        legend.position = "none",
        strip.background = element_rect(fill = "grey", color = "grey")
      )
    trace_plot_colors <- c("#3CAEA3", "#0472cf", "#173F5F")
    trace_plot <- ggplot(pars_estimate_df, aes(x = iteration, y=value)) +
      geom_line(aes(col = variable_name) ) +
      facet_wrap(variable_name ~ variable_index,  scales='free_y', labeller = label_parsed,
                 dir = "h", ncol = ncol(pars_estimate)/3, nrow = 3) +
      trace_plot_theme +
      scale_color_manual(values = trace_plot_colors) +
      scale_x_continuous(breaks = seq(0,nrow(pars_estimate), length = 3))

    trace_plot <- ggplot(pars_estimate_df %>% mutate(group = paste(variable_name,variable_index, sep="")),
                         aes(x = iteration, y=value)) +
      geom_line(aes(col = variable_name) ) +
      facet_wrap(~ group,  scales='free_y', labeller = label_parsed,
                 dir = "h", ncol = ncol(pars_estimate)/3, nrow = 3) +
      trace_plot_theme +
      scale_color_manual(values = trace_plot_colors) +
      scale_x_continuous(breaks = round(seq(0,nrow(pars_estimate), length = 3)))
    if(trace_plot.common_axis == TRUE)
      trace_plot = trace_plot + facet_grid(variable_name ~ variable_index, scale = "free",labeller = label_parsed)

    if(save_plots == TRUE)
      ggsave("trace_plot.png", trace_plot, width = 2*ncol(mcmc_pars), height = 15, dpi = 300, limitsize = FALSE)

    ## Plot - Reproduction number

    R0_pred = mcmc_pars[ , 2*n_period + 1:n_period]
    data_R0 <- data.frame(value = as.vector(as.matrix(R0_pred)),
                          phase = rep(unlist(lapply(1:n_period, function(x) paste0("Period ", x))), each = nrow(R0_pred)))

    fun_color_range <- colorRampPalette(c( "#00A972", "#007FA9"))
    library(DescTools)
    my_colors <- fun_color_range(n_period)

    R0_theme <-   theme_minimal() +
      theme(
        plot.title         = element_text(size = 18, face = "bold"),
        plot.subtitle      = element_text(size = 14, color = "#36454f"),
        plot.caption       = element_text(hjust = 0, size = 10, lineheight = 1.1),
        axis.text          = element_text(size = 16, color = "#36454f"),
        axis.title         = element_text(size = 16, face = "italic"),
        legend.title       = element_blank() ,
        legend.text        = element_text(size = 16) ,
        panel.grid.major.x = element_blank(),
        panel.grid.major.y = element_blank(),
        panel.grid.minor.x = element_blank(),
        panel.grid.minor.y = element_blank(),
        legend.position = "bottom"
      )

    library("patchwork")
    boxplot_R0 <- ggplot(data_R0, aes(x = phase, y=value, fill = phase, color = phase)) +
      geom_boxplot(alpha = 0.8, outlier.alpha = 0.2) +
      stat_summary(aes(fill = phase), fun =mean, geom="point", shape=18, size=4,show.legend = FALSE) +
      R0_theme +
      labs(title="Basic reproduction number : 95% CI",x="", y = "value") +
      theme(legend.position = "none") +
      scale_color_manual(values = MixColor(my_colors, "#000000", 0.75)) +
      scale_fill_manual(values = my_colors) +
      plot_annotation(caption = "* The diamond shapes indicate mean of the estimates",
                      theme = theme(plot.caption = element_text(size = 14)))

    if(save_plots == TRUE)
      ggsave("boxplot_R0.png", boxplot_R0, width = 8, height = 10, dpi = 300)

    print(trace_plot)
    print(boxplot_R0)
    return(list("trace_plot" = trace_plot, "boxplot_R0" = boxplot_R0))

  }

  if(call == "predictR"){
    ## Panel plot - check fit

    prediction = Result$prediction
    prediction_mean = rowMeans(prediction)
    P_current_pred_mean = prediction_mean[3 * T_simu + 1:T_simu]
    RR_current_pred_mean = prediction_mean[6 * T_simu + 1:T_simu]
    DR_current_pred_mean = prediction_mean[8 * T_simu + 1:T_simu]
    P_total_pred_mean = P_current_pred_mean + RR_current_pred_mean + DR_current_pred_mean

    prediction_2.5 = apply(prediction, 1, function(x) quantile(x, probs = 0.025))
    P_current_pred_2.5 = prediction_2.5[3 * T_simu + 1:T_simu]
    RR_current_pred_2.5 = prediction_2.5[6 * T_simu + 1:T_simu]
    DR_current_pred_2.5 = prediction_2.5[8 * T_simu + 1:T_simu]
    P_total_pred_2.5 = P_current_pred_2.5 + RR_current_pred_2.5 + DR_current_pred_2.5

    prediction_97.5 = apply(prediction, 1, function(x) quantile(x, probs = 0.975))
    P_current_pred_97.5 = prediction_97.5[3 * T_simu + 1:T_simu]
    RR_current_pred_97.5 = prediction_97.5[6 * T_simu + 1:T_simu]
    DR_current_pred_97.5 = prediction_97.5[8 * T_simu + 1:T_simu]
    P_total_pred_97.5 = P_current_pred_97.5 + RR_current_pred_97.5 + DR_current_pred_97.5

    T_train = nrow(data)
    T_test = ifelse(!is.null(data_test), nrow(data_test), 0)

    P_total_obs = data_initial[1] + cumsum(c(0, data$Confirmed[2:T_train], data_test$Confirmed))
    if(model == "Multinomial"){
      RR_current_obs = data_initial[2] + cumsum(c(0, data$Recovered[2:T_train], data_test$Recovered))
      DR_current_obs = data_initial[3] + cumsum(c(0, data$Deceased[2:T_train], data_test$Deceased))
      P_current_obs = P_total_obs - RR_current_obs - DR_current_obs
    }
    data_type = c(rep("data_train", T_train), rep("data_test", T_test))

    date_pred = 1:T_simu
    date_obs = 1:(T_train + T_test)

    panel_theme <-   theme_minimal() +
      theme(
        plot.title         = element_text(size = 18, face = "bold"),
        plot.subtitle      = element_text(size = 14, color = "#36454f"),
        plot.caption       = element_text(hjust = 0, size = 10, lineheight = 1.1),
        axis.text          = element_text(size = 16, color = "#36454f"),
        axis.title         = element_text(size = 16, face = "italic"),
        legend.title       = element_blank() ,
        legend.text        = element_text(size = 16) ,
        panel.grid.major.x = element_blank(),
        panel.grid.major.y = element_blank(),
        panel.grid.minor.x = element_blank(),
        panel.grid.minor.y = element_blank(),
        legend.position = "bottom"
      )

    if(model == "Multinomial"){
      data_plot_current_case = data.frame("values_mean" = c(P_current_pred_mean, P_current_obs),
                                        "values_2.5" = c(P_current_pred_2.5, P_current_obs),
                                        "values_97.5" = c(P_current_pred_97.5, P_current_obs),
                                        "pred_data" = c(rep("predicted", times = T_simu), rep("data", times = (T_train + T_test))),
                                        "date" = c(date_pred, date_obs),
                                        "test_train_pred" = c(rep("95% CI train", T_train), rep("95% CI test", T_test), rep("95% CI prediction", T_predict - T_test), rep("95% CI train", T_train), rep("95% CI test", T_test)),
                                        "test_train_pred_data" = c(rep("train", T_train), rep("test", T_test), rep("prediction", T_predict - T_test), rep("data", T_train + T_test)))

    plot_current_case <- ggplot(data = data_plot_current_case, aes(x = date)) +
      geom_ribbon(aes(ymin = values_2.5, ymax = values_97.5, fill = test_train_pred),alpha = 0.3, subset(data_plot_current_case, pred_data %in% c("predicted"))) +
      geom_line(aes(y = values_mean, col = test_train_pred_data), size = 1.2) +
      panel_theme +
      labs(title="Current cases",x="days from onset", y = "cases") +
      scale_y_continuous(labels = scales::comma ) +
      scale_fill_manual(values = c("#3CAEA3", "#0472cf", "#173F5F")) +
      scale_color_manual(values = c("#C32900", "#3CAEA3", "#0472cf", "#173F5F"))
    }

    data_plot_total_case = data.frame("values_mean" = c(P_total_pred_mean, P_total_obs),
                                      "values_2.5" = c(P_total_pred_2.5, P_total_obs),
                                      "values_97.5" = c(P_total_pred_97.5, P_total_obs),
                                      "pred_data" = c(rep("predicted", times = T_simu), rep("data", times = (T_train + T_test))),
                                      "date" = c(date_pred, date_obs),
                                      "test_train_pred" = c(rep("95% CI train", T_train), rep("95% CI test", T_test), rep("95% CI prediction", T_predict - T_test), rep("95% CI train", T_train), rep("95% CI test", T_test)),
                                      "test_train_pred_data" = c(rep("train", T_train), rep("test", T_test), rep("prediction", T_predict - T_test), rep("data", T_train + T_test)))
    plot_total_case <- ggplot(data = data_plot_total_case, aes(x = date)) +
      geom_ribbon(aes(ymin = values_2.5, ymax = values_97.5, fill = test_train_pred),alpha = 0.3, subset(data_plot_total_case, pred_data %in% c("predicted"))) +
      geom_line(aes(y = values_mean, col = test_train_pred_data), size = 1.2) +
      panel_theme +
      labs(title="Total cases",x="days from onset", y = "cases") +
      scale_y_continuous(labels = scales::comma ) +
      scale_fill_manual(values = c("#3CAEA3", "#0472cf", "#173F5F")) +
      scale_color_manual(values = c("#C32900", "#3CAEA3", "#0472cf", "#173F5F"))

    if(model == "Multinomial"){
      data_plot_recovery = data.frame("values_mean" = c(RR_current_pred_mean, RR_current_obs),
                                    "values_2.5" = c(RR_current_pred_2.5, RR_current_obs),
                                    "values_97.5" = c(RR_current_pred_97.5, RR_current_obs),
                                    "pred_data" = c(rep("predicted", times = T_simu), rep("data", times = (T_train + T_test))),
                                    "date" = c(date_pred, date_obs),
                                    "test_train_pred" = c(rep("95% CI train", T_train), rep("95% CI test", T_test), rep("95% CI prediction", T_predict - T_test), rep("95% CI train", T_train), rep("95% CI test", T_test)),
                                    "test_train_pred_data" = c(rep("train", T_train), rep("test", T_test), rep("prediction", T_predict - T_test), rep("data", T_train + T_test)))

    plot_recovery <- ggplot(data = data_plot_recovery, aes(x = date)) +
      geom_ribbon(aes(ymin = values_2.5, ymax = values_97.5, fill = test_train_pred),alpha = 0.3, subset(data_plot_recovery, pred_data %in% c("predicted"))) +
      geom_line(aes(y = values_mean, col = test_train_pred_data), size = 1.2) +
      panel_theme +
      labs(title="Total recoveries",x="days from onset", y = "recoveries") +
      scale_y_continuous(labels = scales::comma ) +
      scale_fill_manual(values = c("#3CAEA3", "#0472cf", "#173F5F")) +
      scale_color_manual(values = c("#C32900", "#3CAEA3", "#0472cf", "#173F5F"))

    data_plot_death = data.frame("values_mean" = c(DR_current_pred_mean, DR_current_obs),
                                 "values_2.5" = c(DR_current_pred_2.5, DR_current_obs),
                                 "values_97.5" = c(DR_current_pred_97.5, DR_current_obs),
                                 "pred_data" = c(rep("predicted", times = T_simu), rep("data", times = (T_train + T_test))),
                                 "date" = c(date_pred, date_obs),
                                 "test_train_pred" = c(rep("95% CI train", T_train), rep("95% CI test", T_test), rep("95% CI prediction", T_predict - T_test), rep("95% CI train", T_train), rep("95% CI test", T_test)),
                                 "test_train_pred_data" = c(rep("train", T_train), rep("test", T_test), rep("prediction", T_predict - T_test), rep("data", T_train + T_test)))

    plot_death <- ggplot(data = data_plot_death, aes(x = date)) +
      geom_ribbon(aes(ymin = values_2.5, ymax = values_97.5, fill = test_train_pred),alpha = 0.3, subset(data_plot_death, pred_data %in% c("predicted"))) +
      geom_line(aes(y = values_mean, col = test_train_pred_data), size = 1.2) +
      panel_theme +
      labs(title="Total deaths",x="days from onset", y = "deaths") +
      scale_y_continuous(labels = scales::comma ) +
      scale_fill_manual(values = c("#3CAEA3", "#0472cf", "#173F5F")) +
      scale_color_manual(values = c("#C32900", "#3CAEA3", "#0472cf", "#173F5F"))

    library(ggpubr)
    panel_plot_fit <- ggarrange(plot_current_case + theme(legend.position = "none"),
                                plot_total_case + theme(legend.position = "none"),
                                plot_recovery + theme(legend.position = "none"),
                                plot_death + theme(legend.position = "none"),
                                nrow = 2, ncol = 2,
                                labels = c("A", "B", "C", "D"), common.legend = TRUE, legend="bottom")
    } else{
      panel_plot_fit <- plot_total_case
    }

    if(save_plots == TRUE)
      ggsave("panel_plot_fit.png", panel_plot_fit, width = 12, height = 12, units = "in", dpi = 300)

    ## Plot - Undetected, Detected and False Negatives

    prediction_mean = rowMeans(prediction)
    U_current_pred = prediction_mean[2 * T_simu + 1:T_simu]
    P_current_pred = prediction_mean[3 * T_simu + 1:T_simu]
    F_current_pred = prediction_mean[4 * T_simu + 1:T_simu]

    data_detected_undetected_plot = data.frame("date" = rep(1:T_simu, times = 3),
                                               "count" = c( U_current_pred, F_current_pred, P_current_pred),
                                               "type" = factor(rep(c("Untested", "False Negative", "Confirmed"), each = T_simu), levels = c("Untested", "False Negative", "Confirmed")))

    detected_undetected_theme <-   theme_minimal() +
      theme(
        plot.title         = element_text(size = 18, face = "bold"),
        plot.subtitle      = element_text(size = 14, color = "#36454f"),
        plot.caption       = element_text(hjust = 0, size = 10, lineheight = 1.1),
        axis.text          = element_text(size = 16, color = "#36454f"),
        axis.title         = element_text(size = 16, face = "italic"),
        legend.title       = element_blank() ,
        legend.text        = element_text(size = 16) ,
        panel.grid.major.x = element_blank(),
        panel.grid.major.y = element_blank(),
        panel.grid.minor.x = element_blank(),
        panel.grid.minor.y = element_blank(),
        legend.position = "bottom"
      )

    plot_detected_undetected <- ggplot(data_detected_undetected_plot, aes(x = date, y = count)) +
      geom_col(aes(fill = type), alpha = 1) +
      detected_undetected_theme +
      scale_fill_manual(values = c("#173F5F", "#0472cf", "#3CAEA3")) +
      labs(title="Current Cases - Untested, Detected and False Negatives", x = "days from onset", y = "cases") +
      scale_y_continuous(labels = scales::comma)

    if(save_plots == TRUE)
      ggsave("plot_detected_undetected.png", plot_detected_undetected, width = 12, height = 10, units = "in", dpi = 300)

    print(panel_plot_fit)
    print(plot_detected_undetected)

    return(list("panel_plot_fit" = panel_plot_fit, "plot_detected_undetected" = plot_detected_undetected))

  }

}


membership_plotdata <- read.csv("results_membership.tsv",
                                header = TRUE, sep = "\t")

membership_plotdata$precision <- membership_plotdata$true_pos /
  ( membership_plotdata$true_pos + membership_plotdata$false_pos)

membership_plotdata$sensitivity <- membership_plotdata$true_pos /
  ( membership_plotdata$true_pos + membership_plotdata$false_neg)

plotMembershipMetric <- function(membership_plotdata, what) {
  ylim <- c(0,1)

  par(mfrow = c(4,1), mar = c(4, 5, 4, 2))
  modeltypes <- sort(toupper(unique(membership_plotdata$modeltype)))
  ndistances <- 7
  atarg <- unlist(Map(function(i) {((i-1)*ndistances+i):(i*ndistances+(i-1))}, 1:5))
  boxplotforsite <- function(nsites, title, what) {
    ylablogor <- paste(toupper(substring(what, 1,1)), substring(what, 2),
                       sep="", collapse=" ")
    boxplot(as.formula(paste0(what, " ~  distance + modeltype")),
            data = membership_plotdata[membership_plotdata$nsites == nsites, ],
            ylab = ylablogor, xlab = "", ylim = ylim, at = atarg,
            names = as.character(rep(c(0, 2, 3, 5, 6, 8, 10), 5)),
            yaxt = 'n',
            cex.lab = 1.5)
    axis(side = 2, at = c(0, 0.25, 0.5, 0.75, 1),
         labels = c("0", "", "0.5", "", "1"))

    for (i in 1:length(modeltypes)) {
      mtext(modeltypes[i], line = 0,
            at = 3 + (i-1) * ndistances + i,
            cex = 1)
    }
    title(title, line = 2, cex.main = 1.5)
  }

  boxplotforsite(1, "One site", what)
  boxplotforsite(2, "Two sites", what)
  boxplotforsite(5, "5 sites", what)
  boxplotforsite(20, "20 sites", what)

}

pdf(file = "membership_precision.pdf", width = 8.8, height = 7.5)
plotMembershipMetric(membership_plotdata, "precision")
dev.off()

pdf(file = "membership_sensitivity.pdf", width = 8.8, height = 7.5)
plotMembershipMetric(membership_plotdata, "sensitivity")
dev.off()


#!/usr/bin/env Rscript
# Plots the Photon Map

library(rgl)

args <- commandArgs(trailingOnly=TRUE)
data <- read.csv(args[1], header=TRUE)
bg3d(color=c("darkgrey", "darkgrey"))
with(data, plot3d(x, z, y, col=rgb(r, g, b, 1,
                  maxColorValue=1.0),
                  size=4, alpha=0.7))
while (rgl.cur() > 0) Sys.sleep(0.5)


library(readr)
library(stringr)
library(base)
library(readxl)

directories=Sys.glob('/path/to/multiple/numerical50/tab/delimited/data/[0-9]*/txt/tab.txt')
columns=c("data","variables","n","n1","n2","n3","n4","n5","n6","n7")
excel=read_excel('/path/to/data/excel.xlsx')
# N
remove=excel[N]

#####

numextract <- function(string){
str_extract(string, "\\-*\\d+\\.*\\d*")
}
Numextract <- function(string){
  unlist(regmatches(string,gregexpr("[[:digit:]]+\\.*[[:digit:]]*",string)))
}
multmerge = function(mypath){
filenames= list.files(path=mypath, full.names=TRUE,pattern='*.csv')
datalist = lapply(filenames, function(x){read.csv(file=x,header=T)})
Reduce(function(x,y) {merge(x,y)}, datalist)}

#####

data=read.table(directories[1],sep='\t',header=TRUE)
data=data[,columns]
data=data[grep(paste(remove,collapse="|"),data[n]),] # n
	colnames(data)[which(colnames(data) %in% c("data","variables","n"))] <- c(paste("data",Numextract(directories[i])[3],sep='.'),paste("variables",Numextract(directories[i])[3],sep='.'),paste("n",Numextract(directories[i])[3],sep='.'))
	for (ii in 4:10){
		colnames(data)[ii] <- paste(grep('n*',colnames(data)[ii],perl=TRUE,value=TRUE),Numextract(directories[i])[3],sep='.')
}
DC <- data
#####

for (i in 2:length(directories)) {
	data=read.table(directories[i],sep='\t',header=TRUE)
	data=data[,columns]
	data=data[grep(paste(remove,collapse="|"),data[n]),]
	colnames(data)[which(colnames(data) %in% c("data","variables","n"))] <- c(paste("data",Numextract(directories[i])[3],sep='.'),paste("variables",Numextract(directories[i])[3],sep='.'),paste("n",Numextract(directories[i])[3],sep='.'))
	for (ii in 4:10){
		colnames(data)[ii] <- paste(grep('n*',colnames(data)[ii],perl=TRUE,value=TRUE),Numextract(directories[i])[3],sep='.')
	}
	DC <-merge(DC,data,by="n",all=T)
}
write.table(DC,"data.csv",row.names=F)


library(ggvis)

set.seed(1233)
cocaine <- cocaine[sample(1:nrow(cocaine), 500), ]
cocaine$id <- seq_len(nrow(cocaine))

shinyServer(function(input, output, session) {

  lb <- linked_brush(keys = cocaine$id, "red")

  cocaine %>%
    ggvis(~weight, ~price, key := ~id) %>%
    layer_points(fill := lb$fill, fill.brush := "red", opacity := 0.3) %>%
    lb$input() %>%
    set_options(width = 300, height = 300) %>%
    bind_shiny("plot1") # Very important!

  # A subset of cocaine, of only the selected points
  selected <- lb$selected
  cocaine_selected <- reactive({
    cocaine[selected(), ]
  })

  cocaine %>%
    ggvis(~potency) %>%
    layer_histograms(width = 5, boundary = 0) %>%
    add_data(cocaine_selected) %>%
    layer_histograms(width = 5, boundary = 0, fill := "#dd3333") %>%
    set_options(width = 300, height = 300) %>%
    bind_shiny("plot2")
})


install.packages(c("dplyr","effects", "ggpubr", "ggthemes", "interactions", "psych", "plyr", "rstatix",
"RColorBrewer", "report", "sjPlot", "sjstats", "skimr", "stargazer", "tidyverse", "pwr"))

libary(dplyr)
library(effects)
library(ggpubr)
library(ggthemes)
library(interactions)
library(psych)
library(plyr)
library(rstatix)
library(RColorBrewer)
library(report)
library(sjPlot)
library(sjstats)
library(skimr)
library(stargazer)
library(tidyverse)


dyn.load('/Library/Java/JavaVirtualMachines/jdk1.8.0_131.jdk/Contents/Home/jre/lib/server/libjvm.dylib')
library(rJava)

setwd("/Users/mengmengjiang/all datas/print")

library(xlsx)

# reading ux and sy

k1<-read.xlsx("doty.xlsx",sheetName="600",header=TRUE)
k2<-read.xlsx("doty.xlsx",sheetName="1khz",header=TRUE)
k3<-read.xlsx("doty.xlsx",sheetName="2khz",header=TRUE)

# par

par(mfrow = c(2,1), mar = c(2,2.4,0.8,1), oma = c(1,1,1,1))
layout(matrix(c(1,2), 2, 1,byrow = TRUE))

# errorbar
error.bar <- function(x, y, upper, coll,lower=upper, length=0.05,...){
if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper))
stop("vectors must be same length")
arrows(x,y+upper, x, y-lower,col=coll, angle=90, code=3, length=length, ...)
}

# color setting

yan<-c("red","blue","black")
pcc<-c(0,1,2)
uy<-c(50,100,150)

z1<-k1$syeva/uy
z2<-k2$syeva/uy
z3<-k3$syeva/uy

e1<-k1$systd/uy
e2<-k2$systd/uy
e3<-k3$systd/uy

plot(uy,z1, col=0,xlab = expression(italic(U["y"]) (um)),ylab = expression(italic(Sy/Uy)), mgp=c(1.1, 0, 0),tck=0.02,main = "", xlim = c(50,150),ylim=c(-0.5,1))

mtext("Sy/Uy",3,line=-1,font=2,cex=1)

lines(uy,z1,col=yan[1],pch=pcc[1],lwd=1.5,lty=2,type="b")
lines(uy,z2,col=yan[2],pch=pcc[2],lwd=1.5,lty=2,type="b")
lines(uy,z3,col=yan[3],pch=pcc[3],lwd=1.5,lty=2,type="b")

error.bar(uy,z1,e1/2,col=yan[1])
error.bar(uy,z2,e2/2,col=yan[2])
error.bar(uy,z3,e3/2,col=yan[3])

leg<-c("600Hz","1KHz","2KHz")

legend("topleft",legend=leg,col=yan,pch=pcc,lwd=1.5,lty=2,inset=.02,bty="n",cex=0.9)

# plot2,Sy+D

r1<-(k1$syeva+k1$deva)/uy
r2<-(k2$syeva+k2$deva)/uy
r3<-(k3$syeva+k3$deva)/uy

q1<-(k1$systd+k1$stdd)/uy
q2<-(k2$systd+k2$stdd)/uy
q3<-(k3$systd+k3$stdd)/uy

plot(uy,r1, col=0,xlab = expression(italic(U["y"]) (um)),ylab = expression(italic(Sy+D/Uy)), mgp=c(1.1, 0, 0),tck=0.02,main = "", xlim = c(50,150),ylim=c(0.5,1))

mtext("Line space/Uy",3,line=-1,font=2,cex=1)

lines(uy,r1,col=yan[1],pch=pcc[1],lwd=1.5,lty=2,type="b")
lines(uy,r2,col=yan[2],pch=pcc[2],lwd=1.5,lty=2,type="b")
lines(uy,r3,col=yan[3],pch=pcc[3],lwd=1.5,lty=2,type="b")

error.bar(uy,r1,q1/2,col=yan[1])
error.bar(uy,r2,q2/2,col=yan[2])
error.bar(uy,r3,q3/2,col=yan[3])

abline(h=0.7,col="green3",lwd=1,lty=2)
text(110,0.8,"ratio=0.7",font=2,col="black")
abline(h=0.65,col="green3",lwd=1,lty=2)
text(70,0.62,"ratio=0.65",font=2,col="black")

leg<-c("600Hz","1KHz","2KHz")

legend("topright",legend=leg,col=yan,pch=pcc,lwd=1.5,lty=2,inset=.02,bty="n",cex=0.9)


\name{print.PA_result}
\alias{print.PA_result}
%- Also NEED an '\alias' for EACH other topic documented here.
\title{
  Printing information of the estimated attachment function
}
\description{
  This function outputs simple information of the estimated attachment function from the corrected Newman's method or the Jeong's method.
}
\usage{
  \method{print}{PA_result}(x,
                              ...)
}
%- maybe also 'usage' for other objects documented here.
\arguments{
  \item{x}{
    An object of class \code{PA_result}, containing the estimated attachment function and the estimated attachment exponenet from either \code{\link{Newman}} or \code{\link{Jeong}} functions.
  }
  \item{\dots}{
    Additional parameters to pass onto the \code{plot} function.
  }
}
\value{
  Simple information of the estimated attachment function.
}
\author{
  Thong Pham \email{thongphamthe@gmail.com}
}
\examples{
  library("PAFit")
  net        <- generate_net(N = 1000 , m = 1 , mode = 1 , alpha = 1 , s = 0)
  net_stats  <- get_statistics(net)
  result     <- Newman(net, net_stats)
  print(result)
}


figure.crab.groundfish.survey <- function(species , outdir=file.path(project.datadirectory('bio.snowcrab'),
	"assessments",p$year.assessment)) {
		require(latticeExtra)
    require(boot)
      areas.crab = c("cfa4x", "cfasouth", "cfanorth" )
      areas.groundfish = list(cfa4x = c(470,483),cfasouth = c(443,467),cfanorth=c(440,442))
      regions = c("4X", "S-ENS", "N-ENS")
      n.regions = length(regions)
      n.areas = length(areas.crab)
	      ft2m = 0.3048
	      m2km = 1/1000
	      nmi2mi = 1.1507794
	      mi2ft = 5280
	      sakm2 = (41 * ft2m * m2km ) * ( 1.75 * nmi2mi * mi2ft * ft2m * m2km )  # surface area sampled in km^2

#	      species = c( "cod", "skates", "thornyskate", "northernshrimp",
#	                   "brittlestar", "basketstar",
#	                   "hermitcrab", "jonahcrab",
#	                   "lessertoadcrab", "northernstonecrab", "porcupinestonecrab", "portlyspidercrab",
#	                   "redcrab", "atlanticrockcrab", "toadcrab", "snowcrab",'atlanticwolffish','halibut','smoothskate','winterskate')
	      #cod, halibut, thornyskate, wolfish, lessertoadcrab, jonahcrab, smoothskate, winterskate, northernshrimp,
	      species = c(10, 30, 201, 50, 2521, 2511, 202, 204, 2211)
 set = snowcrab.db( DS="set.biologicals")
 set = set[which(set$yr>2003),]
 ii  = names(set)[grep(paste("^ms.mass.",species,"$",sep=""),names(set))]

    if(length(ii)==1){
		 set = set[,c('yr','cfa',ii)]
		 names(set)[3] = 'mass'
		 ou = unique(set[,c('yr','cfa')])
		 ou = ou[order(ou$cfa,ou$yr),]
		 ou$mean = ou$upper = ou$lower = 0
		 boot.mean <- function(x,i){mean(x[i])}
     #get the bs estimates for snowcrab

		 for(j in 1:nrow(ou)) {
  	  lp = set[which(set$yr==ou[j,'yr'] & set$cfa==ou[j,'cfa']),'mass']
      if(all(lp==0)) next()
 	    ir = boot(lp,statistic=boot.mean,R=1000)
 	    irr = boot.ci(ir,type='bca')
 	    ou[j,c('lower','upper','mean')] = c(irr$bca[c(4,5)],ir$t0)
      }
      } else {
      ou = NULL
      }

 gr.dir = project.datadirectory('aegis','analysis')
 gr.list = list()

 for(i in 1:n.regions) {
 		io = paste('stratified',species,'summer.strata',areas.groundfish[[c(i,1)]],areas.groundfish[[c(i,2)]],sep=".")
 		ioi = grep(io,dir(gr.dir))
 		if(length(ioi)==0) stop(paste(paste(gr.dir,io,sep="/"),'not found'))
 		if(length(ioi)>1) stop(paste(paste(gr.dir,io,sep="/"),'has multiple entries'))
 		load(paste(gr.dir,dir(gr.dir)[ioi],sep="/"))
 		out = out[,c('yr','w.yst','w.ci.yst.l','w.ci.yst.u')]
 		names(out) = c('yr','mean','lower','upper')
 		out$cfa = areas.crab[i]
 		out$mean = out$mean / sakm2
 		out$lower = out$lower / sakm2
 		out$upper = out$upper / sakm2
 		gr.list[[i]] = out
 		}
gr.list = do.call(rbind,gr.list)
gr.list$grp = 'groundfish'
ou$grp = 'snowcrab'

xlim=c(1968,p$year.assessment+2)
oi = gr.list
 if(!is.null(ou)) oi =rbind(ou,gr.list)

###TO DO## this figure is not working properly but can run through one at a time.  AMC Feb2015

for(l in areas.crab) {

ooi = oi[oi$cfa==l,]
     fn = file.path( outdir, paste( "groundfish.snowcrab.survey.species.one.axis",species,l, "png", sep="." ) )

    plot.new()
    browser()
    panel.ci <- function(x, y, ly, uy, subscripts, pch = 20, col=c('black','red'), ...)   {
        x <- as.numeric(x)
        y <- as.numeric(y)
        ly <- as.numeric(ly[subscripts])
        uy <- as.numeric(uy[subscripts])
        panel.arrows(x, ly, x, uy, col = col,
                 length = 0.25, unit = "native",
                 angle=90,code=3)
        panel.xyplot(x, y, pch = pch, col= col,, ...)
        }
xyplot(mean ~ yr,
        groups=grp,
        data=ooi,
        ly = ooi$lower,
        uy = ooi$upper,
        prepanel = function(x,y,uy)
         list(ylim=c(0,max(uy)*0.75))
        ,ylab=expression("kg per km"^2),
        xlab='Year',
        main=unique(ooi$cfa),
        panel = panel.superpose,
        panel.groups = panel.ci,
        type="b",col=c('black','red'),pch=20,lwd=3
       )
  # savePlot(fn,type='png')
   print(fn)
 }
 }