library(edgeR)
library(ggplot2)
library(ggpubr)
library(Seurat)

sumcount<-function(ct_count, names, sample_df){
  result<-lapply(names, function(x){
    res<-ct_count[,sample_df$Cell[sample_df$Sample ==x],drop=F]
    apply(res, 1, sum)
  })
  rescount<-do.call(cbind, result)
  colnames(rescount)<-names
  return(rescount)
}

cts_cluster<-read.csv(parFile1)
cts_folder<-dirname(parFile1)

cts_unique<-rev(unique(cts_cluster$DE))

sampleGroups<-read.table(parSampleFile1, stringsAsFactors = F)
colnames(sampleGroups)<-c("Sample","Group")

comparisons<-read.table(parSampleFile2, stringsAsFactors = F)
colnames(comparisons)<-c("Group", "Comparison")
comparisonNames<-unique(comparisons$Comparison)

ct<-cts_unique[1]
cts_name<-paste0(outFile, ".")

result<-NULL
for(ct in cts_unique){
  ct_file_name<-paste0(cts_folder, "/", cts_name, ct, ".count")
  rds_file = paste0(ct_file_name,".rds")
  sample_file = paste0(ct_file_name,".sample.csv")
  sample_df<-read.csv(sample_file, stringsAsFactors = F)
  colnames(sample_df)<-c("Cell","Sample")

  de_obj<-readRDS(rds_file)
  ct_count<-as.matrix(de_obj[["RNA"]]@counts)

  comp <-comparisonNames[1]
  for (comp in comparisonNames){
    prefix<-paste0(cts_name, ct, ".", comp , ".edgeR")
    comp_groups<-comparisons[comparisons$Comparison==comp,]

    controlGroup<-comp_groups$Group[1]
    sampleGroup<-comp_groups$Group[2]

    control_names<-sampleGroups$Sample[sampleGroups$Group==controlGroup]
    sample_names<-sampleGroups$Sample[sampleGroups$Group==sampleGroup]

    allsamples<-unique(sample_df$Sample)

    control_names<-control_names[control_names %in% allsamples]
    sample_names<-sample_names[sample_names %in% allsamples]

    if(DE_by_cell){
      cell_control<-ct_count[,sample_df$Cell[sample_df$Sample %in% control_names]]
      cell_control_group<-rep("control", ncol(cell_control))

      cell_sample<-ct_count[,sample_df$Cell[sample_df$Sample %in% sample_names]]
      cell_sample_group<-rep("sample", ncol(cell_sample))
    }else{
      cell_control<-sumcount(ct_count, control_names, sample_df)
      cell_control_group<-rep("control", ncol(cell_control))

      cell_sample<-sumcount(ct_count, sample_names, sample_df)
      cell_sample_group<-rep("sample", ncol(cell_sample))
    }

    cells<-cbind(cell_control, cell_sample)
    groups<-c(cell_control_group, cell_sample_group)

    dge_filename <-paste0(prefix, ".csv")

    #filter genes with zero count
    cells<-cells[rowSums(cells)>0,]

    #filter genes by tpm
    tpm = sweep(cells, 2, colSums(cells)/1e6, "/")
    min_sample<-filter_cellPercentage * ncol(cells)
    keep_rows <- rowSums(tpm > filter_minTPM) >= min_sample

    cells<-cells[keep_rows,]
    tpm<-tpm[keep_rows,]

    designdata<-data.frame("Group"=groups, "Cell"=colnames(cells))
    if(bComparingCluster){
      designdata$Sample=samples
    }

    write.csv(designdata, file=paste0(prefix, ".design"), row.names=F, quote=F)

    cat(prefix, "\n")

    dge<-DGEList(cells, group=groups)
    cat("  calcNormFactors", "\n")
    dge<-calcNormFactors(dge)

    cdr <- scale(colMeans(cells > 0))
    if(bComparingCluster){
      design <- model.matrix(~ cdr + samples + groups)
    }else{
      design <- model.matrix(~ cdr + groups)
    }
    rownames(design)<-colnames(cells)
    write.csv(design, file=paste0(prefix, ".design_matrix.csv"), quote=F)

    cat("  estimateDisp", "\n")
    dge<-estimateDisp(dge,design=design)

    cat("  glmQLFit", "\n")
    fitqlf<-glmQLFit(dge,design=design,robust=TRUE)
    qlf<-glmQLFTest(fitqlf)
    out<-topTags(qlf, n=Inf)
    outTpm<-tpm[rownames(out$table),]
    write.csv(cbind(out$table, outTpm), file=dge_filename, quote=F)

    if(useRawPvalue){
      sigout<-out$table[(out$table$PValue<=pvalue) & (abs(out$table$logFC)>=log2(foldChange)),]
    }else{
      sigout<-out$table[(out$table$FDR<=pvalue) & (abs(out$table$logFC)>=log2(foldChange)),]
    }
    sigTpm<-tpm[rownames(sigout),]
    sigFile<-paste0(prefix, "_sig.csv")
    write.csv(cbind(sigout, sigTpm), file=sigFile, quote=F)

    siggenes<-data.frame(gene=rownames(sigout), stringsAsFactors = F)
    sigGenenameFile<-paste0(prefix, "_sig_genename.txt")
    write.table(siggenes, file=sigGenenameFile, row.names=F, col.names=F, sep="\t", quote=F)

    if (nrow(siggenes) > 0){
      cell_obj=de_obj[,colnames(cells)]
      geneexps=FetchData(cell_obj,vars=siggenes$gene)
      geneexps=t(geneexps)
      geneexps<-geneexps[siggenes$gene,colnames(cells)]
      sigFile<-paste0(prefix, "_sig_exp.csv")
      write.csv(cbind(sigout, geneexps), file=sigFile, quote=F)

      coords<-data.frame(cell_obj@reductions$umap@cell.embeddings)
      xlim<-c(min(coords$UMAP_1-0.1), max(coords$UMAP_1+0.1))
      ylim<-c(min(coords$UMAP_2-0.1), max(coords$UMAP_2+0.1))

      ddata<-designdata
      rownames(ddata)<-ddata$Cell
      cell_obj$Group=ifelse(ddata[colnames(cells), "Group"]=="control", controlGroup, sampleGroup)
      pdf(file=paste0(prefix, ".sig_genename.pdf"), onefile = T, width=21, height=7)
      siggene<-siggenes$gene[1]
      for (siggene in siggenes$gene){
        logFC<-sigout[siggene, "logFC"]
        FDR<-sigout[siggene,"FDR"]

        geneexp=FetchData(cell_obj,vars=c(siggene))
        colorRange<-c(min(geneexp), max(geneexp))
        fix.sc <- scale_color_gradientn(colors=c("lightgrey", "blue"), limits = colorRange)

        title<-paste0(siggene, ' : logFC = ', round(logFC, 2), ", FDR = ", formatC(FDR, format = "e", digits = 2))
        p0<-VlnPlot(cell_obj, feature=siggene, group.by ="Group") + NoLegend()
        if(bComparingCluster){
          p1<-DimPlot(cell_obj, reduction = "umap", label=T, group.by="seurat_clusters") + NoLegend() + ggtitle("Cluster") + theme(plot.title = element_text(hjust=0.5)) + xlim(xlim) + ylim(ylim)
          p2<-FeaturePlot(object = cell_obj, features=as.character(siggene), order=T)
        }else{
          subcells<-colnames(cell_obj)[cell_obj$Group == controlGroup]
          subobj<-subset(cell_obj, cells=subcells)
          p1<-FeaturePlot(object = subobj, features=siggene, order=T) + ggtitle(paste0("Control: ", controlGroup))
          p1<-suppressMessages(expr = p1 + xlim(xlim) + ylim(ylim) + fix.sc)

          subcells<-colnames(cell_obj)[cell_obj$Group == sampleGroup]
          subobj<-subset(cell_obj, cells=subcells)
          p2<-FeaturePlot(object = subobj, features=siggene, order=T) + ggtitle(paste0("Sample: ", sampleGroup))
          p2<-suppressMessages(expr = p2  + xlim(xlim) + ylim(ylim) + fix.sc)

        }
        p<-ggarrange(plotlist=list(p0,p1,p2),nrow =1)
        g<-ggpubr::annotate_figure(
          p = p,
          top = ggpubr::text_grob(label = title, face = 'bold', size=20)
        )
        print(g)
        #break
      }
      dev.off()
    }

    gseaFile<-paste0(prefix, "_GSEA.rnk")
    rankout<-data.frame(gene=rownames(out), sigfvalue=sign(out$table$logFC) * out$table$F)
    write.table(rankout, file=gseaFile, row.names=F, col.names=F, sep="\t", quote=F)

    #cat("  heatmap", "\n")
    #y <- cpm(dge, log=TRUE)
    #conditionColors<-as.matrix(data.frame(Group=c("red", "blue")[group]))
    #gnames<-c(control_name, sample_name)
    #drawHCA(prefix, y, FALSE, NULL, conditionColors, gnames, "png", usePearsonInHCA=TRUE)

    curDF<-data.frame("celltype"=ct, "comparison"=comp, "sigFile"=sigFile, "sigGenenameFile"=sigGenenameFile, "gseaFile"=gseaFile)
    if(is.null(result)){
      result<-curDF
    }else{
      result<-rbind(result, curDF)
    }
  }
}

write.csv(result, file=paste0(outFile, ".edgeR.files.csv"), quote=F)


#' plot gene/feature statistics
#'
#' @param gstat_id id of gene state object
#' @param gset_id optional gene set, will be used to mark select genes if specified
#' @param fig_dir optional base dir (default is to use the std fig dir)
#'
#' @export
#'
mcell_plot_gstats = function(gstat_id, gset_id = NULL, fig_dir = NULL, max_vm=4)
{
	gstat = scdb_gstat(gstat_id)
	if(is.null(gstat)) {
		stop("MC-ERR non existing gstats in mcell_plot_gstats, id ", gstat_id)
	}
	if(!is.null(gset_id)) {
		gset = scdb_gset(gset_id)
		if(is.null(gset)) {
			stop("MC-ERR non existing gset id ", gset_id, " when calling plot gstat")
		}
		marks = names(gset@gene_set)

		set_cols = rep(RColorBrewer::brewer.pal(n=max(3, min(length(gset@set_names), 9)) , 'Set1'), times=length(gset@set_names))[1:length(gset@set_names)]
		names(set_cols) = gset@set_names

		cols = unlist(set_cols[gset@gene_set])

	}
	if(is.null(fig_dir)) {
		vm_fn = scfigs_fn(gstat_id, "varmin")
		szcor_fn = scfigs_fn(gstat_id, "szcor")
		top3_fn = scfigs_fn(gstat_id, "top3")
	} else {
		vm_fn = sprintf("%s/%s_varmin.png", fig_dir, gstat_id)
		szcor_fn = sprintf("%s/%s_szcor.png", fig_dir, gstat_id)
		top3_fn = sprintf("%s/%s_top3.png", fig_dir, gstat_id)
	}
	png(vm_fn, w=1200, h=1200, pointsize=7, res=300)
	vm = pmin(gstat$ds_log_varmean, ifelse(is.null(max_vm), max(gstat$ds_log_varmean), max_vm))
	names(vm) = rownames(gstat)
   plot(log2(gstat$ds_mean), gstat$ds_log_varmean, cex=0.8, pch=19,
		 ylim = c(min(vm), max(vm)+0.25),
       xlab = "log(downsampled mean)", ylab="log2(var/mean downsampled)");
	if(!is.null(gset_id)) {
		points(log2(gstat[marks,"ds_mean"]),
				 vm[marks],
				 cex=0.8, pch=19, col=cols);
	  legend("topleft", legend=names(set_cols), pch=19, cex=0.8, col=set_cols, bty='n')
	}
	dev.off()

	png(szcor_fn, w=1200, h=1200, pointsize=7, res=300)
   plot(log2(gstat$ds_mean), gstat$sz_cor, cex=0.8, pch=19,
       xlab = "log(downsampled mean)", ylab="sz correlation");
	if(!is.null(gset_id)) {
		points(log2(gstat[marks,"ds_mean"]),
				 gstat[marks, "sz_cor"],
				 cex=0.8, pch=19, col=cols);
	  legend("topleft", legend=names(set_cols), pch=19, cex=0.8, col=set_cols, bty='n')
	}
	dev.off()

	png(top3_fn, w=1200, h=1200, pointsize=7, res=300)
   plot(log2(gstat$ds_mean), log2(1+gstat$ds_top3), cex=0.8, pch=19,
       xlab = "log(downsampled mean)", ylab="log third highest umi (downsamp)");
	if(!is.null(gset_id)) {
		points(log2(gstat[marks,"ds_mean"]),
				 log2(1+gstat[marks, "ds_top3"]),
				 cex=0.8, pch=19, col=cols);
	  legend("topleft", legend=names(set_cols), pch=19, cex=0.8, col=set_cols, bty='n')
	}
	dev.off()
}
#


##############################################################################################################################################
###   AMM   -- R script for GWAS corecting for population structure (similar to EMMAX and P3D)
###
#######
#
##
##
##
#

##REQUIRED DATA & FORMAT

#library(doMC) # only required for multi-core
#library(gaston) # only required if AI algorithm is used

#requires functions from the original emma function (Kang et al. 2008, Genetics) to calculate the exact p-value if update.top_snps=TRUE or if AI=FALSE
# source ('emma.r')  needs to be sourced before.
#PHENOTYPE - Y: a n by m matrix, where n=number of individuals and the rownames(Y) contains the individual names

#GENOTYPE - X: a n by m matrix, where n=number of individuals, m=number of SNPs, with rownames(X)=individual names, and colnames(X)=SNP names
#KINSHIP - K: a n by n matrix, with rownames(K)=colnames(K)=individual names, you can calculate K as IBS matrix using the emma package K<-emma.kinship(t(X))
# or use the vanRaden Kinship matrix from the function G.matrix in the R-package snpReady
#each of these data being sorted in the same way, according to the individual name
#
#
#SNP INFORMATION - SNP_INFO: a data frame having at least 3 columns:
# - 1 named 'SNP', with SNP names (same as colnames(X)),
# - 1 named 'Chr', with the chromosome number to which belong each SNP
# - 1 named 'Pos', with the position of the SNP onto the chromosome it belongs to.
#######
###WARNINGS####

# mc enabled to use on linux

amm_gwas<-function(Y,X,K,p=0.001,m=2,run=TRUE,AI=FALSE,calculate.effect.size=FALSE,include.lm=FALSE,include.kw=FALSE,use.SNP_INFO=FALSE,update.top_snps=FALSE,report=TRUE,plot_h=FALSE, mc = FALSE, cores ='all') {

    stopifnot(is.numeric(Y[,1]))
    Y_ <- Y[order(Y[,1]),]
    Y <- as.matrix(Y_[,m])
    rownames(Y) <- as.integer(Y_[,1])
    Y <- na.omit(Y)
    XX <- X[rownames(X) %in% rownames(Y),]
    XX<-XX[order(as.numeric(rownames(XX))),]
    if(report == TRUE) {
        cat ('GWAS performed on', length(which(rownames(Y)%in%rownames(X))),'ecotypes, ', nrow(Y)-length(which(rownames(Y)%in%rownames(X))),'values excluded','\n')
    }

    if(use.SNP_INFO == FALSE) {
        options(stringsAsFactors = FALSE)
        if(report == TRUE) {
            cat('SNP_INFO file created','\n')
        }
        SNP_INFO<-data.frame(cbind(colnames(X),matrix(nrow=ncol(X),ncol=2,data=unlist(strsplit(colnames(X),split='- ')),byrow=TRUE)))
        colnames(SNP_INFO) <-c('SNP','Chr','Pos')
        SNP_INFO[,2]<-as.numeric(SNP_INFO[,2])
        SNP_INFO[,3]<-as.numeric(SNP_INFO[,3])
    } else {
        if(report == TRUE) { cat('User definied SNP_INFO file is used','\n')}}

    Y1 <- as.matrix(Y[rownames(Y) %in% rownames(XX),])
    colnames(Y1) <- colnames(Y)
    rownames(Y1) <- rownames(Y)[rownames(Y)%in%rownames(XX)]
    ecot_id <- as.integer(rownames(Y1))

    K1 <- K[rownames(K) %in% ecot_id,]
    K2 <- K1[,colnames(K1) %in% ecot_id]
    K_ok <- as.matrix(K2)
    K_ok<-K_ok[order(as.numeric(rownames(K_ok))),order(as.numeric(colnames(K_ok)))]

    a <- rownames(K_ok)

    n <- length(a)
    K_stand <- (n-1)/sum((diag(n)-matrix(1,n,n)/n)*K_ok)*K_ok

    Y <- Y1[which(rownames(Y1)%in%a),]
    X_ <- XX[which(rownames(XX)%in%a),]

    rm(X,XX)
    gc()

    AC_1 <- data.frame(colnames(X_),apply(X_,2,sum))
    colnames(AC_1) <- c('SNP','AC_1')
    MAF_1 <- data.frame(AC_1,AC_0=nrow(X_)-AC_1$AC_1)
    MAF_2 <- data.frame(MAF_1,MAC=apply(MAF_1[,2:3],1,min))
    MAF_3 <- data.frame(MAF_2,MAF=(MAF_2$MAC/nrow(X_)))
    MAF_ok <- merge(SNP_INFO,MAF_3,by='SNP')
    rm(AC_1,MAF_1,MAF_2,MAF_3)

#Filter for MAF

    MAF <- subset(MAF_ok,MAF<p)[,1]
    X_ok <- X_[,!colnames(X_) %in% MAF]
    rm(MAF,X_)

# REML

if (AI==TRUE) {
  require(gaston)
    null <-lmm.aireml(Y,K=K_stand)
    herit<-null$tau/(null$tau+null$sigma2)
    M <- solve(chol(null$tau*K_stand+null$sigma2*diag(dim(K_stand)[1])))
    H2 <- seq(0,1,length=101)
    lik <- lmm.diago.likelihood(h2 = H2, Y = Y, eigenK = eigen(K_stand))
   minh<-min(H2[which(exp(lik$likelihood-max(lik$likelihood))>0.9)])
   maxh<-max(H2[which(exp(lik$likelihood-max(lik$likelihood))>0.9)])
   # covH1<-matrix(nrow=2,ncol=2,data=c(null$vg,null$ve,null$ve,null$vg))
  #  se_h1<-deltamethod( ~ x1/(x1+x2),c(null$vg,null$ve),covH1)

      if (report==TRUE) {
        cat('pseudo-heritability estimate is',round(herit,digits=3),'with a 90% CI between',minh,'and',maxh,'.\n')
      }
   if(plot_h==TRUE) {
     pdf(file='heritability_likelihood.pdf')
         plot(H2, exp(lik$likelihood-max(lik$likelihood)), type="l", ylab="relative likelihood")
        points(herit,exp(null$logL-max(lik$likelihood)),pch=16,col='red')
        abline(h=0.90,lty=2,col='red')
        cat('A heritability likelihood plot is generated','\n')
      dev.off()
   }
} else {
  Xo<-rep(1,nrow(X_ok))
  ex<-as.matrix(Xo)
  null<-emma.REMLE(Y,ex,K_stand)

  herit<-null$vg/(null$vg+null$ve)
  M <- solve(chol(null$vg*K_stand+null$ve*diag(dim(K_stand)[1])))

    if (report==TRUE) {
      cat('pseudo-heritability estimate is',round(herit,digits=3),'\n')
    }

}
      if (run==FALSE&AI==TRUE) {

        cat('no GWAS performed','\n')

        return(c(herit,minh,maxh))
      }
if (run==FALSE&AI==FALSE) {
       return(herit)}
   if (run==TRUE) {

        Y_t <- crossprod(M,Y)
        int_t <- crossprod(M,(rep(1,length(Y))))

        if(calculate.effect.size == TRUE) {
            models1 <- apply(X_ok,2,function(x){summary(lm(Y_t~0+int_t+crossprod(M,x)))$coeff[2,]})
            bet <- models1[1,]
            se <- models1[2,]
### variance explained from betas veb
                                        # bet^2*var(X_ok[,t])/var(Y[,n]) =  veb/(1-veb)
            veb <- bet[1]^2*var(X_ok[,1])/var(Y)/(1+bet[1]^2*var(X_ok[,1])/var(Y))
            for( t in 2:ncol(X_ok)) {
                veb <- c(veb,bet[t]^2*var(X_ok[,t])/var(Y)/(1+bet[t]^2*var(X_ok[,t])/var(Y)))
            }

# similar (but slightly different) to RSS method below or to adjusted R2 from lm call
            out_models<-data.frame(SNP=colnames(models1),Pval=models1[4,],variance_explained=veb,beta=bet,se_beta=se)

        } else {
             #EMMAX SCAN
            RSS_env <- rep(sum(lsfit(int_t,Y_t,intercept = FALSE)$residuals^2),ncol(X_ok))

            if(mc == FALSE) {

                R1_full <- apply(X_ok,2,function(x){sum(lsfit(cbind(int_t,crossprod(M,x)),Y_t,intercept = FALSE)$residuals^2)})

            } else {
                require(doMC)
                if(cores == "all") {
                    registerDoMC(system("cat /proc/cpuinfo  | grep processor  | wc -l", intern = TRUE))
                } else {
                    registerDoMC(cores)
                }
                    R1_full <- foreach(i = 1:ncol(X_ok), .combine = "c") %dopar%
                    sum(lsfit(cbind(int_t,crossprod(M,X_ok[,i])),Y_t,intercept = FALSE)$residuals^2)

            }

            pa<-nrow(Y1)

            F_1 <- ((RSS_env-R1_full)/1)/(R1_full/(pa-3))
            pval_Y1 <- pf(F_1,1,(pa-2),lower.tail=FALSE)

            snp <- colnames(X_ok)
            out_models <- data.frame(SNP=snp,Pval=pval_Y1,variance_explained=1-R1_full/RSS_env)
        }

        output <- merge(MAF_ok,out_models,by='SNP')

        if(include.lm == TRUE) {
            RSS_env_ <- rep(sum(lsfit(rep(1,length(Y)),Y,intercept = FALSE)$residuals^2),ncol(X_ok))
            R1_full_ <- apply(X_ok,2,function(x){sum(lsfit(x,Y,intercept = TRUE)$residuals^2)})
            pa<-nrow(Y1)

            F_1_ <- ((RSS_env_-R1_full_)/1)/(R1_full_/(pa-3))
            pval_Y1_lm <- pf(F_1_,1,(pa-3),lower.tail=FALSE)

            snp <- colnames(X_ok)
            out_models_lm <- data.frame(SNP=snp,Pval_lm=pval_Y1_lm)
            output <- merge(output,out_models_lm,by='SNP')
        }

        if(include.kw == TRUE) {
            kw <- apply(X_ok,2,function(x){kruskal.test(Y,x)$p.value})
            KW <- cbind(names(kw),kw)
            colnames(KW) <- c('SNP','Pval_kw')
            output <- merge(output,KW,by='SNP')

        }

        ## update tp SNPs with correct model
        if(update.top_snps == FALSE) {
            return(output)
        } else {
            oi <- output[order(output[,8]),][1:update.top_snps,1]
            xs <- t(X_ok[,colnames(X_ok)%in%oi])
            auto <- emma.ML.LRT (Y, xs, K_ok)
            up <- data.frame(SNP=rownames(xs),update=auto$ps[,1])

            for(i in 1:update.top_snps) {
                output[which(output[,1]==up[i,1]),]$Pval <- up[i,2]
            }
            return(output)
        }
    }

}


create_output_files <- function(JOBID, max_date) {
  three_panel <- readRDS(paste0("usa/results/", "three-panel-data-",JOBID,".RDS"))
  infectious <- readRDS(paste0("usa/results/", "infectious-individuals-out-",JOBID,".RDS"))
  model_output <- merge(three_panel, infectious, by = c('state','date'))
  write.csv(model_output, paste0("usa/results/", "model-output-",max_date,".csv"), row.names = FALSE)

  death_scenario <- readRDS(paste0('usa/results/deaths-scenario-out-',JOBID,'.RDS'))
  mobzero <- death_scenario[death_scenario$key=='Constant mobility',]
  mob20 <- death_scenario[death_scenario$key=='Increased mobility 20%',]
  mob40 <- death_scenario[death_scenario$key=='Increased mobility 40%',]
  mobzero <- mobzero[,c("state", "date","estimated_deaths","deaths_min","deaths_max")]
  mob20 <- mob20[,c("state", "date","estimated_deaths","deaths_min","deaths_max")]
  mob40 <- mob40[,c("state", "date","estimated_deaths","deaths_min","deaths_max")]
  colnames(mobzero) <- c("state", "date","constant_mobility_estimated_deaths_mean","constant_mobility_estimated_deaths_lower_CI_95","constant_mobility_estimated_deaths_higher_CI_95")
  colnames(mob20) <- c("state", "date","mobility_increase_20_estimated_deaths_mean","mobility_increase_20_estimated_deaths_lower_CI_95","mobility_increase_20_estimated_deaths_higher_CI_95")
  colnames(mob40) <- c("state", "date","mobility_increase_40__estimated_deaths_mean","mobility_increase_40__estimated_deaths_lower_CI_95","mobility_increase_40_estimated_deaths_higher_CI_95")
  deaths_scenarios <- merge(mobzero, mob20,by = c('state', 'date'))
  deaths_scenarios <- merge(deaths_scenarios, mob40,by = c('state', 'date'))
  deaths_scenarios <- deaths_scenarios[deaths_scenarios$date > max_date,]
  write.csv(deaths_scenarios, file = paste0('usa/results/deaths-scenarios-',max_date,'.csv'), row.names = FALSE)

  cases_scenario <- readRDS(paste0('usa/results/cases-scenario-out-',JOBID,'.RDS'))
  mobzero <- cases_scenario[cases_scenario$key=='Constant mobility',]
  mob20 <- cases_scenario[cases_scenario$key=='Increased mobility 20%',]
  mob40 <- cases_scenario[cases_scenario$key=='Increased mobility 40%',]

  mobzero <- mobzero[,c("state", "date","predicted_cases","cases_min","cases_max")]
  mob20 <- mob20[,c("state", "date","predicted_cases","cases_min","cases_max")]
  mob40 <- mob40[,c("state", "date","predicted_cases","cases_min","cases_max")]

  colnames(mobzero) <- c("state", "date","constant_mobility_estimated_infections_mean","constant_mobility_estimated_infections_lower_CI_95","constant_mobility_estimated_infections_higher_CI_95")
  colnames(mob20) <- c("state", "date","mobility_increase_20_estimated_infections_mean","mobility_increase_20_estimated_infections_lower_CI_95","mobility_increase_20_estimated_infections_higher_CI_95")
  colnames(mob40) <- c("state", "date","mobility_increase_40__estimated_infections_mean","mobility_increase_40__estimated_infections_lower_CI_95","mobility_increase_40_estimated_infections_higher_CI_95")
  cases_scenarios <- merge(mobzero, mob20,by = c('state', 'date'))
  cases_scenarios <- merge(cases_scenarios, mob40,by = c('state', 'date'))
  cases_scenarios <- cases_scenarios[cases_scenarios$date > max_date,]
  write.csv(cases_scenarios, file = paste0('usa/results/infections-scenarios-',max_date,'.csv'), row.names = FALSE)

  rt_scenario <- readRDS(paste0('usa/results/rt-scenario-out-',JOBID,'.RDS'))
  mobzero <- rt_scenario[rt_scenario$key=='Constant mobility',]
  mob20 <- rt_scenario[rt_scenario$key=='Increased mobility 20%',]
  mob40 <- rt_scenario[rt_scenario$key=='Increased mobility 40%',]

  mobzero <- mobzero[,c("state", "date","rt","rt_min","rt_max")]
  mob20 <- mob20[,c("state", "date","rt","rt_min","rt_max")]
  mob40 <- mob40[,c("state", "date","rt","rt_min","rt_max")]

  colnames(mobzero) <- c("state", "date","constant_mobility_mean_time_varying_reproduction_number_R(t)","constant_mobility_time_varying_reproduction_number_R(t)_lower_CI_95","time_varying_reproduction_number_R(t)_Higher_CI_95")
  colnames(mob20) <- c("state", "date","mobility_increase_20_mean_time_varying_reproduction_number_R(t)","mobility_increase_20_time_varying_reproduction_number_R(t)_lower_CI_95","mobility_increase_20_time_varying_reproduction_number_R(t)_Higher_CI_95")
  colnames(mob40) <- c("state", "date","mobility_increase_20_mean_time_varying_reproduction_number_R(t)","mobility_increase_40_time_varying_reproduction_number_R(t)_lower_CI_95","mobility_increase_40_time_varying_reproduction_number_R(t)_Higher_CI_95")
  rt_scenarios <- merge(mobzero, mob20,by = c('state', 'date'))
  rt_scenarios <- merge(rt_scenarios, mob40,by = c('state', 'date'))
  rt_scenarios <- rt_scenarios[rt_scenarios$date > max_date,]
  write.csv(rt_scenarios, file = paste0('usa/results/time-varying-reproduction-number-scenarios-',max_date,'.csv'), row.names = FALSE)

}


context("twomeans parameters")

# test_that("effect size or sample size", {
  # expect_equal(twomeans(kappa = 1),
  #                "Must specify means (m1 and m2) or sample sizes of the groups (n1 and n2)")
  # expect_error(twomeans(m1 = 3, n1 = 1, n2 = 2),
  #                "Must specify means (m1 and m2) or sample sizes of the groups (n1 and n2)")
# })

test_that("non-negative values", {
  expect_error(twomeans(n1 = 0, n2 = 2, sd = 5),
               "n1, n2, and nratio must be positive")
  expect_error(twomeans(n1 = 0, n2 = 2, sd = 5),
               "n1, n2, and nratio must be positive")
  expect_error(twomeans(m1 = 12, m2 = 16, sd = 0),
               "sd must be positive")
})

test_that("valid intervals", {
  expect_error(twomeans(m1 = 12, m2 = 16, sd = 5, sig.level = 3),
               "sig.level and power must fall between 0 and 1")
  expect_error(twomeans(m1 = 12, m2 = 16, sd = 5, power = 3),
               "sig.level and power must fall between 0 and 1")
})

test_that("specify standard errors", {
  expect_error(twomeans(m1 = 12, m2 = 16, sd = 5, sd1 = 5),
               "must specific either just sd or sd1 and sd2")
  expect_error(twomeans(m1 = 12, m2 = 16, sd1 = 5),
               "must specific either just sd or sd1 and sd2")
  expect_error(twomeans(m1 = 12, m2 = 16),
               "must specific either just sd or sd1 and sd2")
})


library(Seurat)

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

# Remove the clusters that we found to contain mostly doublet cells

i.rm = h1@meta.data$p3_dist_4 %in% c("34","36","38","39")
sum(i.rm)
h1f = SubsetData(h1, cells.use = h1@cell.names[!i.rm])

fn.new = sub(".rds", "_filtered.rds", fn)
saveRDS(h1f, fn.new)


## FILE: population-classification.r
## EXPERIMENT:  equifinality-5
## PROJECT:  experiment-ctmixtures
## AUTHOR:  Mark E. Madsen
## DATE:  5.20.15

# Purpose:  To take simulated output from the CTMixtures simulation, which is time averaged and sampled,
# and perform gradient boosted classification to measure our ability to distinguish between neutral,
# conformist, and anticonformist cultural transmission given the availability of 26 predictor variables.
# The models are fit using the Caret package to find the optimal model tuning (via 5 repeated of 10-fold CV),
# and the final model assessed using a 20% test hold-out sample.  Test sample results are given by a
# confusion matrix and ROC analysis, which are saved into a set of results objects and saved as binary
# images to the filesystem for later use in paper preparation.
# mmadsenr brings in GBM and other crucial analytic libraries

library(randomForest)
library(caret)
library(doMC)
library(mmadsenr)
library(futile.logger)
library(dplyr)
library(ggthemes)

# Overall timing
ptm <- proc.time()

################# Training and Tuning Parameters #############
## Caret training and tuning parameter grid
gbm_grid <- expand.grid(interaction.depth = (1:6)*2,
                        n.trees = (2:10)*50,
                        shrinkage = 0.05,
                        n.minobsinnode = 10)
training_control <- trainControl(method="repeatedcv",
                                 number=10, repeats=5)
# make this repeatable - comment this out or change it to get a fresh analysis result
seed_value <- 58132133
set.seed(seed_value)
# Set up sampling of train and test data sets
training_set_fraction <- 0.8
test_set_fraction <- 1.0 - training_set_fraction

#log_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5", filename = "population-classification.log")
log_file <- "/mnt/experiment-ctmixtures/equifinality-5/population-classification.log"
flog.appender(appender.file(log_file), name='cl')

clargs <- commandArgs(trailingOnly = TRUE)
if(length(clargs) == 0) {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5", filename = "equifinality-5-population-data.rda")
} else {
  pop_data_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5", filename = "equifinality-5-population-data.rda", args = clargs)
}
pop_data_file <- "/mnt/experiment-ctmixtures/equifinality-5/equifinality-5-population-data.rda"
load(pop_data_file)

flog.info("Loaded data file: %s", pop_data_file, name='cl')

flog.info("Beginning classification analysis of equifinality-5 data sets", name='cl')

# set up parallel processing - use all the cores (unless it's a dev laptop under OS X) - from mmadsenr
num_cores <- get_parallel_cores_given_os(dev=FALSE)
flog.info("Number of cores used in analysis: %s", num_cores, name='cl')
registerDoMC(cores = num_cores)

flog.info("RNG seed to replicate this analysis: %s", seed_value, name='cl')

# set up popsampled_results data frames
experiment_names <- c("Population Census: Neutral vs Conformist","Population Census: Neutral vs Anticonformist", "Population Census: Neutral vs All Biased")
pop_results <- data.frame()

pop_results_roc <- NULL
pop_results_model <- NULL
pop_results_cm <- NULL

# prepare data

# To Test, uncomment this
# test_indices <- createDataPartition(eq5_pop_df$model_class_label, p = 0.005, list=FALSE)
# eq5_pop_df <- eq5_pop_df[test_indices,]
# flog.info("Test downsample to %.0f rows", nrow(eq5_pop_df), name='cl')

eq5_neutral_conformist_df <- subset(eq5_pop_df, eq5_pop_df$model_class_label == "neutral" | eq5_pop_df$model_class_label == "conformist")
eq5_neutral_conformist_df$two_class_label <- factor(eq5_neutral_conformist_df$model_class_label, levels=unique(eq5_neutral_conformist_df$model_class_label))
eq5_neutral_anticonformist_df <- subset(eq5_pop_df, eq5_pop_df$model_class_label == "neutral" | eq5_pop_df$model_class_label == "anticonformist")
eq5_neutral_anticonformist_df$two_class_label <- factor(eq5_neutral_anticonformist_df$model_class_label, levels=unique(eq5_neutral_anticonformist_df$model_class_label))
eq5_pop_df$two_class_label <- factor(ifelse(eq5_pop_df$model_class_label == 'neutral', 'neutral', 'biased'))

############### Neutral vs Conformist Data #####################

flog.info("Starting analysis of population census data", name='cl')

# first row of results
i <- 1
exp_name <- experiment_names[i]

# remove fields from analysis that aren't predictors, and the detailed label with 3 classes
exclude_columns <- c("simulation_run_id", "innovation_rate", "model_class_label")

# fit GBM model
model <- train_gbm_classifier(eq5_neutral_conformist_df, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

pop_results_model[["population_census_conformist"]] <- model$tunedmodel

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(model$tunedmodel, newdata=model$test_data)
cm <- confusionMatrix(predictions, model$test_data$two_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- model$elapsed
pop_results_cm[["population_census_conformist"]] <- cm

# calculate a ROC curve
population_roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", exp_name)
results$auc <- unlist(population_roc$auc@y.values)
pop_results_roc[["population_census_conformist"]]  <- population_roc

pop_results <- rbind(pop_results, results)

################ Neutral vs Anticonformist ##################

# first row of results
i <- 2
exp_name <- experiment_names[i]

# remove fields from analysis that aren't predictors, and the detailed label with 3 classes
exclude_columns <- c("simulation_run_id", "innovation_rate", "model_class_label")

# fit GBM model
model <- train_gbm_classifier(eq5_neutral_anticonformist_df, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

pop_results_model[["population_census_anticonformist"]] <- model$tunedmodel

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(model$tunedmodel, newdata=model$test_data)
cm <- confusionMatrix(predictions, model$test_data$two_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- model$elapsed
pop_results_cm[["population_census_anticonformist"]] <- cm

# calculate a ROC curve
population_roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", exp_name)
results$auc <- unlist(population_roc$auc@y.values)
pop_results_roc[["population_census_anticonformist"]]  <- population_roc

pop_results <- rbind(pop_results, results)

################ Neutral vs Both Biased Models ##################

# first row of results
i <- 3
exp_name <- experiment_names[i]

# remove fields from analysis that aren't predictors
exclude_columns <- c("simulation_run_id", "model_class_label", "innovation_rate")

# fit GBM model
model <- train_gbm_classifier(eq5_pop_df, training_set_fraction, "two_class_label", gbm_grid, training_control, exclude_columns, verbose=FALSE)

pop_results_model[["population_census_biased"]] <- model$tunedmodel

# use the test data split by the train_randomforest function and calculate tuned model predictions
# and then get the confusion matrix and fitting metrics
predictions <- predict(model$tunedmodel, newdata=model$test_data)
cm <- confusionMatrix(predictions, model$test_data$two_class_label)
results <- get_parsed_binary_confusion_matrix_stats(cm)
results$experiments <- exp_name
results$elapsed <- model$elapsed
pop_results_cm[["population_census_biased"]] <- cm

# calculate a ROC curve
population_roc <- calculate_roc_binary_classifier(model$tunedmodel, model$test_data, "two_class_label", exp_name)
results$auc <- unlist(population_roc$auc@y.values)
pop_results_roc[["population_census_biased"]]  <- population_roc

pop_results <- rbind(pop_results, results)

############## Complete Processing and Save pop_results ##########3

# we can now use plot_multiple_roc() to plot all the ROC curves on the same plot, etc.
# as well as graph various of the metrics as they vary across sample size and TA duratio
#plot_multiple_roc_from_list(popsampled_pop_results_roc)

if(length(clargs) == 0) {

  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5",
                              filename = "classification-population-results-gbm.RData")
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5",
                                      filename = "classification-population-results-gbm-dfOnly.RData")

} else {

  image_file <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5",
                              filename = "classification-population-results-gbm.RData", args = clargs)
  image_file_results <- get_data_path(suffix = "experiment-ctmixtures/equifinality-5",
                                      filename = "classification-population-results-gbm-dfOnly.RData", args = clargs)
}

flog.info("Saving results of analysis to R environment snapshot: %s", image_file, name='cl')
save(pop_results, pop_results_model, pop_results_roc, pop_results_cm, file=image_file)

flog.info("Saving just data frame of results of analysis to R environment snapshot: %s", image_file_results, name='cl')
save(pop_results, file=image_file_results)

flog.info("Analysis complete", name='cl')
total_time <- proc.time() - ptm
flog.info("Elapsed time in analysis: %.3f", total_time[3],name='cl')


library(tidyverse) #General purpose data wrangling
library(rvest) #Parsing of HTML/XML files
library(stringr) #String manipulation
library(rebus) #Verbose regular expressions
library(lubridate) #Eases DateTime manipulation

#okay, what are the problems with the scraped angband set?
#1)race and class occupy one column
#2)experience and turncount are comma formatted character vectors and not numerics
#3)comments is character and should just contain the number of comments
#4)updated is a character vector but should be POSIXct date

load(file = "main_df.RData") #load from the angScrape.r save's output

clean_df <- main_df

#1)split `race class`
  clean_df <- separate(clean_df, col = "race class", into = c("race", "class"), sep = " ")
  #this produces a warning about rows [2577, 3338, 4482]
  #the origin of these warning is that the dumps are inappropriate (wrong angband variant dumped as angband)
  remove_rows <- c(2577, 3338, 4482)
  clean_df <- clean_df[-remove_rows, ]

#2)convert experience and turncount into numerics
  clean_df$experience <- clean_df$experience %>%
    str_replace_all(pattern = ",", replacement = "") %>%
    as.numeric()
  clean_df$turncount <- clean_df$turncount %>%
    str_replace_all(pattern = ",", replacement = "") %>%
    as.numeric()

#3) turn comments into a numeric
  #turn empty strings into 0's, because an empty string means no comments
  clean_df$comments[which(clean_df$comments == "")] <- "0"

  #replace " comments" and " comment" with "" in that order and then coerce into numeric
  clean_df$comments <- clean_df$comments %>%
    str_replace_all(pattern = " comments", replacement = "") %>%
    str_replace_all(pattern = " comment", replacement = "") %>%
    as.numeric()

#4) coerce updated column into date type.
    clean_df$updated <- dmy_hm(clean_df$updated)

#todo: Look for and remove cheaters (low turn count high exp, e.t.c.)
#      Look for and remove classes not in the base game (these are probably incorrect dumps)
#      Look for and remove bad version numbers (version numbers that contain letters e.t.c.)

save(clean_df, file = "clean_df.RData")


library(rtracklayer)
library(GenomicRanges)

intersect.bw.with.bed <- function(bw.file, bed.file, stat='mean', keep.name=T) {
  bed <- import(bed.file)
  bw <- BigWigFile(bw.file)
  # summarize over bed regions using stat
  scored.gr <- unlist(summary(bw, bed, type=stat))
  if (keep.name == TRUE) {
    scored.gr$name <- bed$name
  }
  scored.gr
}

summarize.by.bed <- function (bw.file, bed.file, stat='mean', drop.name.col=T) {
  values <- intersect.bw.with.bed(bw.file, bed.file, keep.name=T)
  df <- data.frame(mcols(values))
  result <- aggregate(.~name, data=df, mean)
  colnames(result) <- c('name', basename(bw.file))
  if (drop.name.col == TRUE) {
    rownames(result) <- result$name
    result$name <- NULL
  }
  result
}


#' Extract
#'
#' Extract subsets of a float vector/matrix.
#'
#' @param x
#' A float vector/matrix.
#' @param i,j,...
#' The indices.  Most combinations of integer/double/logical values will be
#' treated the same as R does. One major difference is that \code{NA} values
#' will not be tolerated.
#' @param drop
#' Logical. If TRUE, single column matrices will be treated as one-dimensional
#' vectors.
#' @param value
#' The replacement value.
#'
#' @return
#' A float vector/matrix.
#'
#' @examples
#' \dontrun{
#' library(float)
#'
#' s = flrunif(10, 3)
#' s[, -1]
#' s[c(1, 3, 5, 7), 1:2]
#' }
#'
#' @name bracket
#' @rdname bracket
NULL

bracket_float32_vec = function(x, i, drop=TRUE)
{
  DATA(x)[i, drop=drop]
}

bracket_float32_mat = function(x, i, j, drop=TRUE)
{
  if (missing(i))
    DATA(x)[, j, drop=drop]
  else if (missing(j))
  {
    if (is.matrix(i))
      DATA(x)[i, drop=drop]
    else
      DATA(x)[i, , drop=drop]
  }
  else
    DATA(x)[i, j, drop=drop]
}

bracket_float32 = function(x, i, j, drop=TRUE)
{
  if (missing(i) && missing(j))
    return(x)

  if (isavec(x))
  {
    if (missing(i))
      stop("incorrect number of dimensions")

    d = bracket_float32_vec(x, i, drop=drop)
  }
  else
    d = bracket_float32_mat(x, i, j, drop=drop)

  if (!is.null(rownames(x)))
    rownames(d) = rownames(x)[i]
  if (!is.null(names(x)))
    names(d) = names(x)[j]

  float32(d)
}

bracket_replace_float32 = function(x, i, j, ..., value)
{
  if (is.double(value))
  {
    x = dbl(x)
    if (missing(i) && missing(j))
      x[, ] = value
    else if (missing(i))
      x[, j] = value
    else if (missing(j))
    {
      if (!is.matrix(x) || is.matrix(i))
        x[i] = value
      else
        x[i, ] = value
    }
    else
      x[i, j] = value

    return(x)
  }
  else if (is.integer(value))
    value = fl(value)

  if (missing(i) && missing(j))
    x@Data[, ] = DATA(value)
  else if (missing(i))
    x@Data[, j] = DATA(value)
  else if (missing(j))
  {
    if (isavec(x) || is.matrix(i))
      x@Data[i] = DATA(value)
    else
      x@Data[i, ] = DATA(value)
  }
  else
    x@Data[i, j] = DATA(value)

  x
}

#' @rdname bracket
#' @export
setMethod("[", signature(x="float32"), bracket_float32)

#' @rdname bracket
#' @export
setReplaceMethod("[", signature(x="float32", value="ANY"), bracket_replace_float32)


#!/usr/bin/env Rscript

# Checks the saved trees can be loaded in R. Looks for errors like singleton nodes

library(ape)

treefiles <- list.files('../phylogenies', 'summary.trees', recursive=TRUE, full.names=TRUE)

for (filename in treefiles) {
    tryCatch(tree <- read.nexus(filename), error=function(cond) {
        cat(sprintf("%40s: Read failed: \n\t%s\n", filename, cond), sep="\n")
    })

    if (Ntip(tree) <= 2) {
        # pass
    } else if (any(tabulate(tree$edge[, 1]) == 1)) {
        cat(sprintf("%40s: Singleton nodes", filename), sep="\n")
    }
}


library(ggplot2)
library(ggmuller)

population <- read.table("/home/cld100/Documents/github/muller_diagrams/description/example/tables/example.ggmuller.populations.tsv", header=TRUE)
edges <- read.table("/home/cld100/Documents/github/muller_diagrams/description/example/tables/example.ggmuller.edges.tsv", header=TRUE)

Muller_df <- get_Muller_df(edges, population)
write.csv(Muller_df, "description/example/tables/example.muller.csv", sep = "\t", col.names = NA)
palette <- c("#FFFFFF","#334538","#87CA8C","#356A44","#4BAB63","#34573E","#E32F27","#368E4F","#357C49","#3787C1","#73C07F","#9AD49A","#37A155","#5EB570")

ggplot(Muller_df, aes_string(x = "Generation", y = "Frequency", group = "Group_id", fill = "Identity", colour = "Identity")) +
geom_area() +
theme(legend.position = "right") +
guides(linetype = FALSE, color = FALSE) +
scale_y_continuous(labels = 25 * (0:4), name = "Percentage", expand=c(0,0)) +
scale_x_continuous(expand=c(0,0)) +
scale_fill_manual(name = "Identity", values = palette) +
scale_color_manual(values = palette)

ggsave("/home/cld100/Documents/github/muller_diagrams/description/example/graphics/clade/example.muller.basic.png", height = 10, width = 10)


\docType{data}
\name{vuruş}
\alias{vuruş}
\title{Vuruş istatistikleri tablosu}
\format{105.861 satır ve 22 sütundan oluşan bir data.frame
\describe{
\item{oyuncu}{Özgün oyuncu kodu}
\item{yıl}{Yıl}
\item{takım_sırası}{Oyuncunun bir sezon içinde takımlar arası yaptığı geçiş sayısı}
\item{takım}{Takım kodu (faktör)}
\item{lig}{Lig kodu (faktör) (AA, AL, FL, NL, PL, UA)}
\item{oyun}{Oyuncunun yer aldığı oyun sayısı}
\item{at_bat}{Vurucunun sopa (bat) tuttuğu ve belirli koşulları sağladığı durumların sayısı}
\item{koşu}{Vurucunun kaleye ulaşarak aldığı sayılar}
\item{hit}{Vurucunun topu uygun alana vurduktan sonra birinci bölgeye başarıyla ulaşma sayısı}
\item{çifte_vuruş}{Vurucunun topu uygun alana vurduktan sonra ikinci bölgeye başarıyla ulaşma sayısı}
\item{üçlü_vuruş}{Vurucunun topu uygun alana vurduktan sonra üçüncü bölgeye başarıyla ulaşma sayısı}
\item{home_run}{Vurucunun topu oyun alanı dışına yollama sayısı}
\item{run_batted_in}{Vurucunun takım skoruna yaptığı katkı}
\item{kale_çalma}{Koşucuların rakipten kale çalma sayısı}
\item{yakalanma}{Kale çalarken yakalanma sayısı}
\item{walk}{Atıcının dört defa vurucunun vuruş bölgesi dışına atış yapması nedeniyle vurucunun birinci kaleye yürüme hakkı kazanması}
\item{strikeout}{Atıcının yaptığı atışlar sonucunda, üç ıska ile vurucunun devre dışı kalması}
\item{kasti_walk}{Rakibe kasıtlı verilen walk}
\item{vurucuya_isabet}{Atıcının topu vurucunun vücuduna isabet ettirdiği atış sayısı}
\item{sacrifice_hit}{Kalelerde bulunan koşucuların ilerlemesi için bilerek bunting vurma sayısı}
\item{sacrifice_fly}{Üçüncü kalede bulunan koşucunun başlangıç kalesine dönerek sayı alabilmesi uğruna topu olabildiğince uzağa vurma sayısı}
\item{double_play}{Savunma oyuncularının hücum oyuncularını art arda dışarıda bırakması}
}}
\usage{vuruş}
\description{Vuruş istatistikleri}
\seealso{\code{\link[Lahman]{Batting}}}
\keyword{datasets}


#UVOZ IN OCISCENJE CSV- povprecne mesecne place po statisticnih regijah
place_po_regijah <- read.csv2("../podatki/Neocisceni_podatki/povprecne-mesecne-place-po-statisticnih-regijah.csv",
                        quote = "\"",
                        na=c('-','z','na','--'),
                        skip=2) %>%
                     rename( # preimenuj stolpce
                         STATISTICNA_REGIJA = 1,
                         STAROST = 2,
                         SPOL = 3,
                         MERITVE = 4,
                         LETO=5,
                         POVPRECNA_PLACA=6) %>%
                     drop_na(LETO) %>% # izbriši vrednosti NA v stolpcu LETO, ker takrat itak ne vemo povp.place
                     select(-MERITVE) %>% # nepotreben stolpec z eno samo vrednostjo
                     pivot_wider(names_from=SPOL, values_from=POVPRECNA_PLACA) # loci moske in ženske ?

place_po_regijah$STAROST <- case_when(place_po_regijah$STAROST == "65 let ali veè" ~ "65 let >",
                                      place_po_regijah$STAROST == "15-64 let" ~ "15-64 let",
                                      place_po_regijah$STAROST == "15-24 let" ~ "15-24 let",
                                      place_po_regijah$STAROST == "25-34 let" ~ "25-34 let",
                                      place_po_regijah$STAROST == "35-44 let" ~ "35-44 let",
                                      place_po_regijah$STAROST == "45-54 let" ~ "45-54 let",
                                      place_po_regijah$STAROST == "55-64 let" ~ "55-64 let")

# PLACE PO SEKTORJIH
place_po_sektorjih <- read.csv2("../podatki/Neocisceni_podatki/povprecne-mesecne-place-v-J-Z.csv",
                                skip=2,
                                na=c('-','z','na','--')) %>%
                              rename( # preimenuj stolpce
                                SEKTOR = 1,
                                IZOBRAZBA = 2,
                                SPOL = 3,
                                MERITVE = 4,
                                LETO=5,
                                POVPRECNA_PLACA=6) %>%
                              drop_na(LETO) %>%
                              select(-MERITVE) # nepotreben stolpec z eno samo vrednostjo

# uvoz in ociscenje podatkov za place po dejavnostih
place_po_dejavnosti <- read_excel(path="../podatki/Neocisceni_podatki/povp-place-po-dejavnostih.xlsx",
                                    col_names = FALSE,
                                    skip=2,
                                    n_max=33661,
                                    na = c('z','N','M','NA')
                                  ) %>%
                                  fill(1:3) %>%
                                  select(-c(5,7)) %>%
                                  rename(
                                    REGIJA = 1,
                                    DEJAVNOST = 2,
                                    DATUM = 3,
                                    TIP_PLACE = 4,
                                    MERITEV = 5
                                  )  %>%
                                  separate(DATUM, into=c("LETO", "MESEC"), sep='M') %>%
                                  pivot_wider(names_from=TIP_PLACE, values_from=MERITEV) %>%
                                  select(-MESEC) %>%
                                  group_by(LETO,DEJAVNOST,REGIJA) %>%
                                  rename(
                                    BRUTO = 4,
                                    NETO = 5
                                  ) %>%
                                  summarize(SKUPNO=sum(BRUTO))

write.csv2(place_po_dejavnosti,"../podatki/Pocisceni_podatki/place_po_dejavnosti.csv")
write.csv2(place_po_sektorjih,"../podatki/Pocisceni_podatki/place_po_sektorjih.csv")
write.csv2(place_po_regijah,"../podatki/Pocisceni_podatki/place_po_regijah.csv")


.units <- list(
  short=list(
    IEC=list(
      print = c("B", "KiB", "MiB", "GiB", "TiB", "PiB", "EiB", "ZiB", "YiB"),
      check = c("b", "kib", "mib", "gib", "tib", "pib", "eib", "zib", "yib")
    ),
    SI=list(
      print = c("B", "KB", "MB", "GB", "TB", "PB", "EB", "ZB", "YB"),
      check = c("b", "kb", "mb", "gb", "tb", "pb", "eb", "zb", "yb")
    )
  ),
  long=list(
    IEC=list(
      print = c("bytes", "kibibytes", "mebibytes", "gibibytes", "tebibytes", "pebibytes", "exbibytes", "zebibytes", "yobibytes"),
      check = c("bytes", "kibibytes", "mebibytes", "gibibytes", "tebibytes", "pebibytes", "exbibytes", "zebibytes", "yobibytes")
    ),
    SI=list(
      print = c("bytes", "kilobytes", "megabytes", "gigabytes", "terabytes", "petabytes", "exabytes", "zettabytes", "yottabytes"),
      check = c("bytes", "kilobytes", "megabytes", "gigabytes", "terabytes", "petabytes", "exabytes", "zettabytes", "yottabytes")
    )
  )
)

.units_bits <- list(
  short=list(
    IEC=list(
      print = c("b", "Kib", "Mib", "Gib", "Tib", "Pib", "Eib", "Zib", "Yib"),
      check = c("b", "kib", "mib", "gib", "tib", "pib", "eib", "zib", "yib")
    ),
    SI=list(
      print = c("b", "Kb", "Mb", "Gb", "Tb", "Pb", "Eb", "Zb", "Yb"),
      check = c("b", "kb", "mb", "gb", "tb", "pb", "eb", "zb", "yb")
    )
  ),
  long=list(
    IEC=list(
      print = c("bits", "kibibits", "mebibits", "gibibits", "tebibits", "pebibits", "exbibits", "zebibits", "yobibits"),
      check = c("bits", "kibibits", "mebibits", "gibibits", "tebibits", "pebibits", "exbibits", "zebibits", "yobibits")
    ),
    SI=list(
      print = c("bits", "kilobits", "megabits", "gigabits", "terabits", "petabits", "exabits", "zettabits", "yottabits"),
      check = c("bits", "kilobits", "megabits", "gigabits", "terabits", "petabits", "exabits", "zettabits", "yottabits")
    )
  )
)

# From: https://en.wikipedia.org/wiki/Names_of_large_numbers
.numbers <- data.frame(
  name=c("Thousand", "Million", "Billion", "Trillion", "Quadrillion", "Quintillion", "Sextillion", "Septillion", "Octillion", "Nonillion", "Decillion", "Undecillion", "Duodecillion", "Tredecillion", "Quattuordecillion", "Quindecillion", "Sexdecillion", "Septendecillion", "Octodecillion", "Novemdecillion", "Vigintillion", "Googol", "Centillion"),
  shorthand=c("k", "m", "b", "t", "q", "qt", "sx", "sp", "ot", "n", "d", "u", "dd", "td", "qtd", "qd", "sxd", "spd", "otd", "nd", "vg", "g", "ct"),
  exponent=c(3, 6, 9, 12, 15, 18, 21, 24, 27, 30, 33, 36, 39, 42, 45, 48, 51, 54, 57, 60, 63, 100, 303),
  stringsAsFactors=FALSE
)


#测试对数log坐标轴下的数据
#设定工作目录
setwd("D:/data")
library(xlsx)

#读取数据
ek2<-read.xlsx("t_pulse.xls", sheetName = "eject_k2", header = TRUE)
#ek3<-read.xlsx("t_pulse.xls", sheetName = "eject_k3", header = TRUE)
#ek4<-read.xlsx("t_pulse.xls", sheetName = "eject_k4", header = TRUE)
#ek5<-read.xlsx("t_pulse.xls", sheetName = "eject_k5", header = TRUE)

fv <- log10(ek2$fv)

plot(fv, ek2$X1.5, col = 0, xlab = "Voltage frequency (Hz)", ylab = "Eject time t_eject (ms)", main = "Eject time in Q = 1.5nl/min", cex.lab = 1.1, cex.main = 1.2, xlim = c(0, 4), ylim = c(0, 80)

lines(fv, ek2$X1.5, col="#458B74", lwd=2, type="l", lty=2)

lines(fv, ek2$X27, col="#FF00FF", lwd=2, type="l", lty=2)

lines(fv, ek2$X54, col="#EE0000", lwd=2, type="l", lty=2)

lines(fv, ek2$X180, col="#27408B", lwd=2, type="l", lty=2)

#区域划线
legend("topleft", c("1.5nl/min", "27nl/min", "54nl/min", "180nl/min"), col = c("#458B74", "#FF00FF", "#EE0000", "#27408B"),lwd = 2, lty = 2, cex = 1.2, inset = .03, bty = "n")


#' @param fun Function to use. Either 1) an anonymous function in the base or
#'   rlang formula syntax (see [rlang::as_function()])
#'   or 2) a quoted or character name referencing a function; see examples. Must
#'   be vectorised.
#' @param n Number of points to interpolate along the x axis.
#' @param args List of additional arguments passed on to the function defined by `fun`.
#' @param xlim Optionally, restrict the range of the function to this range.
#' @section Computed variables:
#' `stat_function()` computes the following variables:
#' \describe{
#'   \item{x}{x values along a grid}
#'   \item{y}{value of the function evaluated at corresponding x}
#' }
#' @seealso [rlang::as_function()]
#' @export
#' @rdname geom_function
stat_function <- function(mapping = NULL, data = NULL,
                          geom = "function", position = "identity",
                          ...,
                          fun,
                          xlim = NULL,
                          n = 101,
                          args = list(),
                          na.rm = FALSE,
                          show.legend = NA,
                          inherit.aes = TRUE) {
  if (is.null(data)) {
    data <- ensure_nonempty_data
  }

  layer(
    data = data,
    mapping = mapping,
    stat = StatFunction,
    geom = geom,
    position = position,
    show.legend = show.legend,
    inherit.aes = inherit.aes,
    params = list(
      fun = fun,
      n = n,
      args = args,
      na.rm = na.rm,
      xlim = xlim,
      ...
    )
  )
}

#' @rdname ggplot2-ggproto
#' @format NULL
#' @usage NULL
#' @export
StatFunction <- ggproto("StatFunction", Stat,
  default_aes = aes(y = after_scale(y)),

  compute_group = function(data, scales, fun, xlim = NULL, n = 101, args = list()) {
    if (is.null(scales$x)) {
      range <- xlim %||% c(0, 1)
      xseq <- seq(range[1], range[2], length.out = n)
      x_trans <- xseq
    } else {
      range <- xlim %||% scales$x$dimension()
      xseq <- seq(range[1], range[2], length.out = n)

      if (scales$x$is_discrete()) {
        x_trans <- xseq
      } else {
        # For continuous scales, need to back transform from transformed range
        # to original values
        x_trans <- scales$x$trans$inverse(xseq)
      }
    }

    if (is.formula(fun)) fun <- as_function(fun)

    y_out <- do.call(fun, c(list(quote(x_trans)), args))
    if (!is.null(scales$y) && !scales$y$is_discrete()) {
      # For continuous scales, need to apply transform
      y_out <- scales$y$trans$transform(y_out)
    }

    new_data_frame(list(
      x = xseq,
      y = y_out
    ))
  }
)

# Convenience function used by `stat_function()` and
# `geom_function()` to convert empty input data into
# non-empty input data without touching any non-empty
# input data that may have been provided.
ensure_nonempty_data <- function(data) {
  if (empty(data)) {
    new_data_frame(list(group = 1), n = 1)
  } else {
    data
  }
}


csv_to_rcf<-function(csv_file,Out_put_rcf_file){

  if(is.null(Out_put_rcf_file))stop("error in rcf_context_file file   - terminating")
  if(is.null(csv_file))stop("error in csv_file file   - terminating")
  OutCon<-file(Out_put_rcf_file,"w")

  cat('\n Init System LOAD FROM  CSV... \n ')
  cat('\n Parameters are: \n ')
  cat('\n CSV \n ',csv_file)
  source("load_csv.r")
  returns_args=load_csv(csv_file)
  List_Objects=returns_args$List_Objects
  List_Attributes=returns_args$List_Attributes
  AttributesofObject=returns_args$AttributesofObject
  ObjectOfAttributes=returns_args$ObjectOfAttributes

  ##################################### generating the RCF file
  cat('\n Start creating RCF Context \n ')

  writeLines("[Relational Context]", OutCon)
  writeLines("Default Name", OutCon)
  writeLines("[Binary Relation]", OutCon)
  writeLines("Name_of_dataset", OutCon)
  writeLines(paste(List_Objects, collapse = ' | '),OutCon)
  writeLines(paste(List_Attributes, collapse = ' | '),OutCon)
  for(i in 1:length(List_Objects)){
    matching_List <-  ifelse(List_Attributes %in% AttributesofObject[[i]], 1, 0)
    writeLines( paste(matching_List, collapse = ' ') ,OutCon)

  }

  writeLines("[END Relational Context]", OutCon)
  cat('\n  RCF Context successfully created \n ')
  ##################################### generating the csv file

}


 map2spatial<-function(lon,lat,map,missval){
	 lonarray<<-array(rep(lon,length(lat)), dim=dim(map))
	 latarray<<-t(array(rep(lat,length(lon)),dim=dim(t(map))))

	sp<-data.frame("lon"=as.vector(lonarray),"lat"=as.vector(latarray),"val"=as.vector(map))
	sp<-sp[abs(sp$val)<missval,]
	sp
}


#### this function takes as input a csv context and loads a data structure
load_csv=function(csv_file_name){
  #csv_file_name="/home/terminator2/Documents/R_Projects/AnomalyRulesMining/contexts/Context_ProcessEvent.csv"
  Incon = file(csv_file_name, "r")
  if(is.null(Incon))stop("error in csv_file_name     - terminating")
 # context_file=read.csv(file='./contexts/Context_ProcessEvent.csv')
  cat('loading csv')
  context_file=read.csv(file=Incon)
  ObjectOfAttributes=list()
  AttribuesList=as.list(names(context_file)[2:length(names(context_file))])
  AttributesOfObjects=list()
  colnames(context_file) <- NULL
  context_matrix <- as.matrix(context_file)
  ObjectList=as.list(context_matrix[,1])
  context_matrix<- context_matrix[,-1]
  cat('loading ObjectOfAttributes')

  for (i in 1:length(AttribuesList)){
    col= context_matrix[,i]
    List=as.list(ObjectList[col=="1"])
    ObjectOfAttributes[[length(ObjectOfAttributes)+1]] <-  List
  }
  cat('loading AttributesOfObjects')

  for (i in 1:length(ObjectList)){
    lin= context_matrix[i,]
    List=as.list(AttribuesList[lin=="1"])
    AttributesOfObjects[[length(AttributesOfObjects)+1]] <-  List
  }

  returned_list <- list("List_Objects" = ObjectList, "List_Attributes" = AttribuesList,
                        "AttributesofObject"=AttributesOfObjects,"ObjectOfAttributes"=ObjectOfAttributes)
  close(Incon)
  return (returned_list)

}


# ==============================
# Preparation of sample size files (Neyman Scenarios)
# Nuno Prista, SLU Aqua, 2019 @ KustMonitoring project
# ==============================

	# Includes simplified compromise Neyman allocation (based on Cochran, 1977)
		# at indicator level (optimizing across strata*years)
		# at multi-indicator level (optimizing across strata*years*variables)

	# Note: this script uses simulation results to produce sample size tables for a range of allocation scenarios
		# after running it, the sample size tables are used in new runs of scripts 003, 004 and 005 to produce the results fot these new allocations

rm(list=ls()); graphics.off()

library(data.table)
library("PerformanceAnalytics")

# auxiliary function
	source("000_Funs/func_chart_Correlation2.r")

# select site
	site<-"Lagnö" # sites in in c("Asköfjärden", "Norrbyn","Kvädöfjärden_Warm", "Galtfjärden","Gaviksfjärden","Holmön","Kinnbäcksfjärden","Lagnö","Långvindsfjärden","Råneå","Torhamn")

# select input scenario
	scenario <- "AllocOrigin"

# loads original data
	dir_inputs<-"001_Inputs/prepared_main/NordicGillNets/"
	load(file=paste("001_Inputs/prepared_main/NordicGillNets/",site,".Rdata",sep=""))

# loads simulations
	dir_sim_outputs <- paste("002_Sim_Outputs/",scenario,"/prepared/",sep="")
	load(file=paste(dir_sim_outputs, site, "_", scenario,"_5000sims_res_pop_prep.rdata", sep=""))
	load(file=paste(dir_sim_outputs, site, "_", scenario,"_5000sims_res_strata_prep.rdata", sep=""))

# option for Swedish captions
	sve=TRUE

# table spp conversion eng to sve
	spp_name_conv<-data.frame(eng = c('CodN','CyprinidsB','CyprinidsN','FlounderN','HerringN','PerchB','PerchN','PikeN','PikeperchN','PiscivoresN','WhitefishN'),
			sve = c('TorskN','CypriniderB','CypriniderN','SkrubbskäddaN','StrömmingN','AbborreB','AbborreN','GäddaN','GösN','PiscivorerN','SikN'))

# ====================
# Analysis of frequency of occurrence (in strata*year combinations)
# ====================

	# rare variables tend to be very variable and pull the design to the few strata where they happened to have occurred
	# rare variables may however be important (e.g., invasive species will be null and then rare at early stages)

	dir_output <- paste("003_Results/006_Freq_Occurrence/", sep=""); dir.create(dir_output, showWarnings = FALSE)

	# freq of occurrence
		mydata<-res_strata
		freq_occ<-tapply(mydata$mean_x, mydata$variable, function(x) sum(!x==0))/table(mydata$variable)
		freq_occ
		windows(4,3)
		barplot(freq_occ, las=1, cex.axis=0.7, cex.names=0.7, cex.lab=0.7, col="blue", xlab="freq. occurrence", main = paste(site, ": freq. occurrence", sep=""), horiz=T, space=.85, cex.main=0.9)
		savePlot(paste(dir_output, site, "_freq_occ.png", sep=""), type="png")
		write.csv2(freq_occ, file=paste(dir_output,site,"_freq_occ.csv",sep=""))

		if(sve==TRUE)
			{
			windows(4,3); par(oma=c(0,2,0,0), mar=c(4,3.5,2,2))
			freq_occ_sve<-freq_occ
			names(freq_occ_sve)<-spp_name_conv$sve[match(names(freq_occ_sve), spp_name_conv$eng)]
			barplot(freq_occ_sve, las=1, cex.axis=0.7, cex.names=0.7, cex.lab=0.7, col="blue", xlab="", main = paste("Indikator förekomstfrekvens", sep=""), horiz=T, space=.85, cex.main=0.9)
			mtext("förekomstfrekvens", side=1, line=2.5, cex=0.7)
			savePlot(paste(dir_output, site, "_freq_occ_sve.png", sep=""), type="png")
			write.csv2(freq_occ_sve, file=paste(dir_output,site,"_freq_occ_sve.csv",sep=""))
			}

	graphics.off()

# ====================
# Analysis of correlations
# ====================

	# very correlated variables will tend to pull the allocation to their optimal allocation
		# if one wants the design to perform "reasonably" (as in compromise) for the diversity of variables variables that display large correlation should only be present once
		# If wants the design to perform "reasonably" (as in compromise) for most variables, it may be worth maintaining correlated variables

	dir_graph <- paste("003_Results/006_Correlations/", sep=""); dir.create(dir_graph, showWarnings = FALSE)

	# pop level correlations
		mydata<-dcast(res_pop[,c("Year","variable","st_mean"), with=F],  Year~variable, fun=mean,drop=FALSE)

		round(cor(mydata[,target_vars, with=F], use="complete.obs", method="spearman"),2)
		windows()
		chart.Correlation(mydata[,target_vars, with=F], use="complete.obs", method="spearman", histogram=TRUE, pch=19)
		mtext(paste(site,"- pop level Spearman correlation"),3,3)

		windows()
		chart.Correlation(mydata[,target_vars, with=F], use="complete.obs", method="kendall", histogram=TRUE, pch=19)
		mtext(paste(site,"- pop level Kendall correlation"),3,3)

	# strata level correlations
		mydata<-dcast(res_strata[,c("Year","stratum","variable","mean_x"), with=F],  Year+stratum~variable, fun=mean,drop=FALSE)

		res <- round(cor(mydata[,target_vars, with=F], use="complete.obs", method="spearman"),2)
		windows()
		chart.Correlation(mydata[,target_vars, with=F], use="complete.obs", method="spearman", histogram=TRUE, pch=19)
		mtext(paste(site,"- strata level Spearman correlation"),3,3)
		savePlot(paste(dir_graph, site,"_correl_Pearson.png",sep=""), type="png")
		write.csv2(res, file=paste(dir_graph, site,"_correl_Pearson.csv",sep=""))

		res <- round(cor(mydata[,target_vars, with=F], use="complete.obs", method="kendall"),2)
		windows()
		chart.Correlation(mydata[,target_vars, with=F], use="complete.obs", method="kendall", histogram=TRUE, pch=19)
		mtext(paste(site,"- strata level Kendall correlation"),3,3)
		savePlot(paste(dir_graph, site,"_correl_Kendall.png",sep=""), type="png")
		write.csv2(res, file=paste(dir_graph, site,"_correl_Kendall.csv",sep=""))

		if(sve==TRUE) {
					colnames(mydata)[!colnames(mydata)%in%c("Year","stratum")]<-as.character(spp_name_conv$sve[match(colnames(mydata)[!colnames(mydata)%in%c("Year","stratum")], spp_name_conv$eng)])
					mydata[, ,!colnames(mydata) %in% names(freq_occ_sve[freq_occ_sve<0.5])]

					res <- round(cor(mydata[,names(freq_occ_sve[freq_occ_sve>=0.5]), with=F], use="complete.obs", method="spearman"),2)
					windows(9,7)
					chart.Correlation2(mydata[,names(freq_occ_sve[freq_occ_sve>=0.5]), with=F], use="complete.obs", method="spearman", histogram=FALSE, pch=19, cex=1)
					if(site=="Kvädöfjärden_Warm") site2 <- "Kvädöfjärden" else site2 <- site
					mtext(paste(site2,"- Spearman korrelation (strata medeltal)"),3,3)
					savePlot(paste(dir_graph, site,"_correl_Pearson_sve.png",sep=""), type="png")
					write.csv2(res, file=paste(dir_graph, site,"_correl_Pearson_sve.csv",sep=""))
					 }

	# fishing site level correlations
		mydata<-dt_site[,target_vars, with=F]

		round(cor(mydata[,target_vars, with=F], use="complete.obs", method="spearman"),2)
		windows()
		chart.Correlation(mydata, use="complete.obs", method="pearson", histogram=TRUE, pch=19)
		chart.Correlation(mydata, use="complete.obs", method="spearman", histogram=TRUE, pch=19)
		mtext(paste(site,"- sample level Spearman correlation"),3,3)

		windows()
		chart.Correlation(mydata, use="complete.obs", method="kendall", histogram=TRUE, pch=19)
		mtext(paste(site,"- sample level Kendall correlation"),3,3)

	graphics.off()

# ====================
# Production of sample_size table for different allocation scenarios (settings based on above analysis)
# ====================

	# ============
	# selection of output scenario
	# ============

	# site-specific scenarios
		# Torhamn	AllocScenarioCypNHerNPerNFloN
		# Råneå	AllocScenarioCypNHerNPerNWhiN
		# Långvindsfjärden	AllocScenarioCypNHerNPerNWhiN
		# Lagnö	AllocScenarioCypNHerNPerNWhiN
		# Kinnbäcksfjärden	AllocScenarioCypNHerNPerNWhiN
		# Holmön	AllocScenarioCypNHerNPerNWhiN
		# Hanöbukten	AllocScenarioCodNHerNFloN
		# Gräsö	AllocScenarioCypNHerNPerNWhiN
		# Gaviksfjärden	AllocScenarioCypNHerNPerNWhiN
		# Galtfjärden	AllocScenarioCypNHerNPerNPikperNWhiN

	# select scenarion
		scenario <- "AllocScenarioCypNHerNPerNWhiN"
		dir_table<-paste("002_Sim_Inputs/", scenario,"/", sep=""); dir.create(dir_table, showWarnings=FALSE)
		dir_results<-paste("003_Results/006_Neyman_Sample_Sizes/", sep=""); dir.create(dir_results, showWarnings=FALSE)

	# monoindicator scenarios
		if (scenario %in% c('AllocScenarioCodN','AllocScenarioCyprinidsB','AllocScenarioCyprinidsN','AllocScenarioFlounderN','AllocScenarioHerringN','AllocScenarioPerchB','AllocScenarioPerchN','AllocScenarioPikeN','AllocScenarioPikeperchN','AllocScenarioPiscivoresN','AllocScenarioWhitefishN'))
			{
			selected_spp<-freq_occ[gsub("AllocScenario","", scenario)]
			if(selected_spp<0.5) print("Attention: rare species selected!")
			}

	# Other scenarios
		# baseline restricted on frequency 'AllocScenario3'
		if (scenario == c('AllocScenario3'))
			{
			# restriction to frequent species
			threshold <- 0.5
			selected_spp <- freq_occ[freq_occ>=threshold]
			}
		# baseline restricted on frequency 'AllocScenario3', no PiscivoresN
			# test for "Asköfjärden", "Norrbyn","Kvädöfjärden_Warm"
		if (scenario == c('AllocScenario3a'))
			{
			# restriction to frequent species
			threshold <- 0.5
			selected_spp <- freq_occ[freq_occ>=threshold]
			selected_spp<-selected_spp[selected_spp!="PiscivoresN"]
			}
		# baseline restricted on frequency 'AllocScenario3', no PiscivoresN, N diversity
			# test for "Asköfjärden", "Norrbyn","Kvädöfjärden_Warm"
		if (scenario == c('AllocScenario4'))
			{
			# restriction to frequent species
			threshold <- 0.5
			selected_spp <- freq_occ[freq_occ>=threshold]
			selected_spp<-selected_spp[names(selected_spp)!="PiscivoresN"]
			selected_spp<-selected_spp[grepl(names(selected_spp), pat="N")]
			}

		# k-lab suggested scenarios
		if (scenario %in% c('AllocScenarioCypNHerNPerN'))
			{
			selected_spp<-freq_occ[c("CyprinidsN","HerringN","PerchN")]
			if(any(selected_spp<0.5)) print("Attention: rare species selected!")
			}
		if (scenario %in% c('AllocScenarioCypNHerNPerNFloN'))
			{
			# only Asköfjärden and Kvädöfjärden_Warm and Torhamn
			selected_spp<-freq_occ[c("CyprinidsN","HerringN","PerchN","FlounderN")]
			if(any(selected_spp<0.5)) print("Attention: rare species selected!")
			}
		if (scenario %in% c('AllocScenarioCypNHerNPerNFloNWhiN'))
			{
			# only Asköfjärden
			selected_spp<-freq_occ[c("CyprinidsN","HerringN","PerchN","FlounderN","WhitefishN")]
			if(any(selected_spp<0.5)) print("Attention: rare species selected!")
			}
		if (scenario %in% c('AllocScenarioCodNHerNFloN'))
			{
			# only Hanöbukten
			selected_spp<-freq_occ[c("CodN","HerringN","FlounderN")]
			if(any(selected_spp<0.5)) print("Attention: rare species selected!")
			}
		if (scenario %in% c('AllocScenarioCypNHerNPerNFloNPikperN'))
			{
			# only Kvädöfjärden_Warm
			selected_spp<-freq_occ[c("CyprinidsN","HerringN","PerchN","FlounderN","PikeperchN")]
			if(any(selected_spp<0.5)) print("Attention: rare species selected!")
			}
		if (scenario %in% c('AllocScenarioCypNHerNPerNWhiN'))
			{
			# several areas
			selected_spp<-freq_occ[c("CyprinidsN","HerringN","PerchN","WhitefishN")]
			if(any(selected_spp<0.5)) print("Attention: rare species selected!")
			}
		if (scenario %in% c('AllocScenarioCypNHerNPerNPikperNWhiN'))
			{
			# only Galtfjärden
			selected_spp<-freq_occ[c("CyprinidsN","HerringN","PerchN","PikeperchN","WhitefishN")]
			if(any(selected_spp<=0.5)) print("Attention: rare species selected!")
			}
		# just for compatibility purposes (will not be used)
		if (scenario %in% c('AllocScenarioOriginal'))
			{
			selected_spp<-freq_occ[c("CyprinidsN","HerringN","PerchN")]
			}

		selected_spp

	# ============
	# Compromise Neyman allocation (based on Cochran)
	# ============
		if(nlevels(boot_res_strata$stratum)==4)
			{
			out <- data.frame(Year=sort(unique(res_pop$Year)), variable=rep(target_vars, length(sort(unique(res_pop$Year)))), a=NA, b=NA, c=NA, d=NA)
			colnames(out)[3:6] <- levels(boot_res_strata$stratum)
			}
		if(nlevels(boot_res_strata$stratum)==3)
			{
			out <- data.frame(Year=sort(unique(res_pop$Year)), variable=rep(target_vars, length(sort(unique(res_pop$Year)))), a=NA, b=NA, c=NA)
			colnames(out)[3:5] <- levels(boot_res_strata$stratum)
			}
		if(nlevels(boot_res_strata$stratum)==2)
			{
			out <- data.frame(Year=sort(unique(res_pop$Year)), variable=rep(target_vars, length(sort(unique(res_pop$Year)))), a=NA, b=NA)
			colnames(out)[3:4] <- levels(boot_res_strata$stratum)
			}

		N <- max(res_pop$N)

		for (i in target_vars)
		{
			for (j in 2002:2018)
			{
			tmp<-res_strata[variable == i & Year == j,][order(stratum)]
			tmp1<-round(N*tmp$stratum_size*sqrt(tmp$var_x)/ sum(tmp$stratum_size*sqrt(tmp$var_x)),1)
			names(tmp1)<-tmp$stratum
			if(nlevels(boot_res_strata$stratum)==4)	out[out$Year == j & out$variable== i,3:6] <-tmp1[match(colnames(out)[3:6], names(tmp1))]
			if(nlevels(boot_res_strata$stratum)==3)	out[out$Year == j & out$variable== i,3:5] <-tmp1[match(colnames(out)[3:5], names(tmp1))]
			if(nlevels(boot_res_strata$stratum)==2)	out[out$Year == j & out$variable== i,3:4] <-tmp1[match(colnames(out)[3:4], names(tmp1))]
			#out<-rbind(out, round(N*tmp$stratum_size*sqrt(tmp$true_var_mean)/ sum(tmp$stratum_size*sqrt(tmp$true_var_mean)),1))
			}
		}

		out<-out[order(out$variable, out$Year),]
		res_neyman <- out

		res_neyman_tmp0 <- res_neyman

		# restriction to scenario
			res_neyman_tmp <- droplevels(res_neyman_tmp0[res_neyman_tmp0$variable %in% names(selected_spp),])

		# sets to 0 strata where variable is not used in estimate
			res_neyman_tmp[res_neyman_tmp$variable %in% c("CyprinidsB","CyprinidsN","EelN","EelpoutN","MesopredatorsN","PerchB","PerchN","PikeN","PiscivoresN"),"10-20m"]<-0

		# handling of the missing year*variables
			# assumes the best way is to sample according to the average neyman of the variable
			ls1 <- split(res_neyman_tmp, res_neyman_tmp$variable)
			ls2 <- lapply(ls1, function(x, N1=N){
						if(sum(is.na(x$'0-3'))>0) {
							table_values <- prop.table(apply(x[!is.na(x$'0-3'),c("0-3m","3-6m","6-10m","10-20m")],2,mean))*N1
							x[is.na(x$'0-3m'),"0-3m"]<-table_values[["0-3m"]]
							x[is.na(x$'3-6m'),"3-6m"]<-table_values[["3-6m"]]
							x[is.na(x$'6-10m'),"6-10m"]<-table_values[["6-10m"]]
							x[is.na(x$'10-20m'),"10-20m"]<-table_values[["10-20m"]]
							x
							} else x})
			res_neyman_tmp2<-rbindlist(ls2)

			# quick-check
			table(res_neyman_tmp2$variable)
			table(res_neyman_tmp2$Year)

		# determines and displays original compromise allocation
			compromise_alloc<-apply(res_neyman_tmp2[,3:c(nlevels(boot_res_strata$stratum)+2)],2,mean,na.rm=T)/sum(apply(res_neyman_tmp2[,3:c(nlevels(boot_res_strata$stratum)+2)],2,mean,na.rm=T))*N
			compromise_alloc

		if (scenario %in% c('AllocScenarioOriginal'))
			{
			compromise_alloc<-prop.table(tapply(res_strata$stratum_size, res_strata$stratum, function(x) unique(x)))*N
			}

		# corrects for <5 strata (if any)
			compromise_alloc_corr<-compromise_alloc
			tmp <- compromise_alloc_corr[round(compromise_alloc_corr)<=5]
			# assings 5 as minimum per strata
			compromise_alloc_corr[names(tmp)]<-5
			# redistributes the remaining maintaining optimum allocation
			tmp <- names(compromise_alloc_corr)[compromise_alloc_corr>5]

		# aligns with sampling goals
			# original distribution
			compromise_alloc_corr_original<-compromise_alloc_corr
			compromise_alloc_corr_original[tmp]<-round(prop.table(compromise_alloc[tmp])* (N-sum(compromise_alloc_corr[!names(compromise_alloc_corr) %in% tmp])))
			if(sum(compromise_alloc_corr_original)==N){
				compromise_alloc_corr<-compromise_alloc_corr_original
				}
			if(sum(compromise_alloc_corr_original)>N) {
				print("case minus1 needed")
				compromise_alloc_corr_minus1<-compromise_alloc_corr_original
				v1<-which(prop.table(compromise_alloc[tmp]) == min(prop.table(compromise_alloc[tmp])))
				compromise_alloc_corr_minus1[v1] <- compromise_alloc_corr_minus1[v1]-1
				compromise_alloc_corr<-compromise_alloc_corr_minus1
				}
			if(sum(compromise_alloc_corr_original)<N) {
				print("case plus1 needed")
				compromise_alloc_corr_plus1<-compromise_alloc_corr_original
				v1<-which(prop.table(compromise_alloc[tmp]) == max(prop.table(compromise_alloc[tmp])))
				compromise_alloc_corr_plus1[v1] <- compromise_alloc_corr_plus1[v1]+1
				compromise_alloc_corr<-compromise_alloc_corr_plus1
				}

		# QCA (should yield TRUE)
		sum(compromise_alloc_corr) == N

		# displays final compromise allocation
		origin_alloc<-tapply(res_strata$stratum_size, res_strata$stratum, function(x) unique(x))
		out<-rbind(origin_alloc, compromise_alloc, compromise_alloc_corr)
		out

		# saves
		write.csv2(out, file=paste(dir_results, site, "_", scenario,".csv", sep=""), row.names=T)

	# ============
	# Production of final table (includes OriginAlloc ("N") for sake of simplifying subsequent graph production)
	# ============

		# series of compromise_alloc_corr

            # attention: there is an exception for Lägnö asked by Magnus - email 2019-10-07 10:54

		compromise_alloc_corr_series<-compromise_alloc_corr
		for(i in 1:10)
		{

		if(i==1) b<-compromise_alloc_corr_series else b<-compromise_alloc_corr_series[i,]
		if(i==2) rownames(compromise_alloc_corr_series)[i-1]<-paste("n",N, sep="")
		b[tmp]<-round(prop.table(compromise_alloc[tmp])* ( (N-5*i-sum(b[!names(b) %in% tmp]))))
        if(any(b[tmp]<5) & !site=="Lagnö") break()
		if(any(b[tmp]<4 )) break()
		compromise_alloc_corr_series <- rbind(compromise_alloc_corr_series, b)
		rownames(compromise_alloc_corr_series)[i+1]<-paste("n",N-5*i,sep="")
		}

		# adds original allocation
		compromise_alloc_corr_series <- rbind(origin_alloc, compromise_alloc_corr_series)
		rownames(compromise_alloc_corr_series)[1]<-"N"

		# displays final compromise allocation_corr_series
		compromise_alloc_corr_series

		# builds samp_size_table
			# note on warning: no problem if strata and years are ordered correctly in both objects]
			samp_size_table <- data.frame(unique(res_strata[,c("Year","stratum"), with=F])[order(Year,stratum)], t(compromise_alloc_corr_series))
			colnames(samp_size_table)[2]<-"DepthStratum"
			samp_size_table
		# saves to inputs
		write.csv2(samp_size_table, file=paste(dir_table, site, "_", scenario,".csv", sep=""), row.names=F)


source("BRITE_2019/BRITE-paths.r")
library(neonUtilities)
library(neonNTrans)
library(RCurl) # load "merge_left" function
script <- getURL("https://raw.githubusercontent.com/zoey-rw/NEFI_microbe/master/NEFI_functions/merge_left.r")
eval(parse(text = script))

NTR <- loadByProduct(site = "all", dpID = "DP1.10080.001", package = "basic", check.size = F)
#NTR.new <- loadByProduct(site = "all", dpID = "DP1.10080.001", package = "expanded", check.size = F)

# calculate net N mineralization and nitrification rates and put into table
nitr.out <- def.calc.ntrans(kclInt = NTR$ntr_internalLab,
                       kclIntBlank = NTR$ntr_internalLabBlanks,
                       kclExt = NTR$ntr_externalLab,
                       soilMoist = NTR$sls_soilMoisture,
                       keepAll = T)

#getPackage(site_code = "HARV", dpID = "DP1.10080.001", package = "expanded", year_month="2018-04")

# soil physical properties
dat <- loadByProduct(site = "all", dpID = "DP1.10086.001", package = "basic", check.size = F)

# Rename dataframes
core.data <- dat$sls_soilCoreCollection
moisture.data <- dat$sls_soilMoisture
pH.data <- dat$sls_soilpH

# Merge moisture into soil cores
core.data <- merge_left(core.data,moisture.data, all.x = T)

# Merge pH into soil cores
output <- merge_left(core.data,pH.data, all.x = T)

# Add a couple columns for later
output$dateID <- substr(output$collectDate,1,7)
output$site_date <- paste(output$siteID, output$dateID)

# Add precise geolocation data
core.data <- geoNEON::def.calc.geo.os(output, 'sls_soilCoreCollection')
dim(core.data)

# merge soil core data with N cycling data
merge.output <- merge_left(core.data, nitr.out, by.col = c("sampleID", "plotID"))

# save output
saveRDS(merge.output, N_data_path)


#!/usr/bin/env Rscript
#
# This script does multiple linear regression stuff with sets of variants
# and phenotypes.
#

library(magrittr)
library(data.table)
library(dplyr)
library(dtplyr)
library(MuMIn)

impute = function(x) {
    apply(x, 2, function(x) {
          m = mean(x, na.rm=TRUE)
          x[is.na(x)] = m
          x
})
}

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

cargs = commandArgs(trailingOnly=TRUE)
geno_data_file = cargs[1] # .tsv file created from VCF with 0 and 1 for genotypes
                          # can have or not have an "rs" column
top_vars_file = cargs[2]  # File with rs; rows are replicates, columns are ordered
pheno_file = cargs[3]     # File with two columns: strain and phenotype value, no
                          # header
geno_sampling = as.numeric(cargs[4]) # Number of variants to sample to get genomic pve
calc_genomic_pve = as.logical(as.numeric(cargs[5]))  # Whether or not to calculate the genomic pve
do_interaction = as.logical(as.numeric(cargs[6]))  # Whether or not to run the interaction code
output_prefix = cargs[7]

## Get the genotype data
## It seems easiest to grab this from the tsv file that was used as
## input for the LD script rather than trying to use the VCF or plink
## files.
geno_data = fread(geno_data_file, header=TRUE)
if(!('rs' %in% colnames(geno_data))) {
    geno_data = geno_data %>% mutate(rs=paste0(contig, '-', pos))
}
geno_data %<>% setkey(cols='rs')

## Get the phenotype data and put it in the same order as the
## genotype data
pheno = read.table(pheno_file, as.is=TRUE)
#if(!all(pheno[, 1] %in% colnames(geno_data))) {
#    print(pheno[!pheno[, 1] %in% colnames(geno_data), 1])
#    stop('Some strains are missing from the the genotype data')
#}
pheno = pheno[match(colnames(geno_data), pheno[, 1]), ]
pheno = pheno[!is.na(pheno[, 1]), ]

geno_data = geno_data[, c('contig', 'pos', 'rs', pheno[, 1]), with=FALSE]
geno_mat = geno_data %>% select(-contig, -pos, -rs) %>%
    as.matrix()

## Read in list of top variants
top_vars = read.table(top_vars_file, as.is=TRUE)

if(calc_genomic_pve) {
    sampled_vars = sample(1:nrow(geno_data), geno_sampling, FALSE)
}

## Loop over replicates
for(i in 1:nrow(top_vars)) {

    ## List of variants for this replicate
    focal_vars = as.character(top_vars[i, ])
    n_vars = length(focal_vars)

    ## Get the genotypes for this replicate and impute missing data by
    ## making missing data equal the mean genotype; this is the
    ## strategy used by GEMMA, and it avoids issues with losing lots of
    ## individuals when there is missing data without biasing the results
    ## much.
    top_vars_geno = geno_data[focal_vars, on='rs'] %>%
        select(-contig, -pos, -rs) %>%
        as.matrix %>%
        t() %>%
        impute()

    ## Each variant by itself and each variant added to the model
    ## cumulatively
    output_each = data.frame('repl'=rep(i, n_vars),
                             'var'=focal_vars,
                             'r2'=numeric(n_vars)*NaN,
                             'aic'=numeric(n_vars)*NaN,
                             'r2adj'=numeric(n_vars)*NaN,
                             'geno_pve'=numeric(n_vars)*NaN)
    output_cuml = data.frame('repl'=rep(i, n_vars),
                             'var'=focal_vars,
                             'r2'=numeric(n_vars)*NaN,
                             'aic'=numeric(n_vars)*NaN,
                             'r2adj'=numeric(n_vars)*NaN,
                             'geno_pve'=numeric(n_vars)*NaN)

    ## Loop over variants
    cuml_cols = logical(n_vars)
    for(j in 1:n_vars) {
        ## If there is no non-missing data, continue
        if(all(is.na(top_vars_geno[, j]))) {
            cuml_cols[j] = FALSE
            next
        }
        ## Do the regressions
        cuml_cols[j] = TRUE
        m_cuml = lm(pheno[, 2] ~ top_vars_geno[, cuml_cols])
        sum_cuml = summary(m_cuml)
        m_each = lm(pheno[, 2] ~ top_vars_geno[, j])
        sum_each = summary(m_each)
        output_each$r2[j] = sum_each$r.squared
        output_each$r2adj[j] = sum_each$adj.r.squared
        output_each$aic = AICc(m_each)
        output_cuml$r2[j] = sum_cuml$r.squared
        output_cuml$r2adj[j] = sum_cuml$adj.r.squared
        output_cuml$aic = AICc(m_cuml)

        ## How much genomic variation is predicted by these variants
        if(calc_genomic_pve) {
            r2_genome_sum_each = 0
            r2_genome_count_each = 0
            r2_genome_sum_cuml = 0
            r2_genome_count_cuml = 0
            for(k in seq_along(sampled_vars)) {
                r2_each_ = summary(lm(as.numeric(geno_mat[sampled_vars[k], ]) ~ top_vars_geno[, j]))$r.squared
                r2_cuml_ = summary(lm(as.numeric(geno_mat[sampled_vars[k], ]) ~ top_vars_geno[, cuml_cols]))$r.squared
                if(!is.na(r2_each_)) {
                    r2_genome_sum_each %<>% + r2_each_
                    r2_genome_count_each %<>% + 1
                }
                if(!is.na(r2_cuml_)) {
                    r2_genome_sum_cuml %<>% + r2_cuml_
                    r2_genome_count_cuml %<>% + 1
                }
            }
            output_each$geno_pve[j] = r2_genome_sum_each / r2_genome_count_each
            output_cuml$geno_pve[j] = r2_genome_sum_cuml / r2_genome_count_cuml
        }
    }

    write.table(output_cuml,
                file=paste0(output_prefix, '.cumulative.tsv'),
                col.names=(i == 1), row.names=FALSE, quote=FALSE, sep='\t',
                append=(i != 1))
    write.table(output_each,
                file=paste0(output_prefix, '.each.tsv'),
                col.names=(i == 1), row.names=FALSE, quote=FALSE, sep='\t',
                append=(i != 1))

    if(do_interaction) {

        ## Pairwise output
        n_pairs = choose(n_vars, 2)
        output_pair = data.frame('repl'=rep(i, n_pairs),
                                 'var1'=character(n_pairs),
                                 'var2'=character(n_pairs),
                                 'r2_additive'=numeric(n_pairs),
                                 'r2_interact'=numeric(n_pairs),
                                 'r2adj_additive'=numeric(n_pairs),
                                 'r2adj_interact'=numeric(n_pairs),
                                 'aic_additive'=numeric(n_pairs),
                                 'aic_interact'=numeric(n_pairs),
                                 'LRT_p'=numeric(n_pairs),
                                 stringsAsFactors=FALSE)

        ## Loop over pairs, testing for interaction
        ## Use AICc function because the sample size is a little small
        pair_list = combn(1:n_vars, 2)
        for(j in 1:ncol(pair_list)) {
            a = pair_list[1, j]
            b = pair_list[2, j]
            var1 = focal_vars[a]
            var2 = focal_vars[b]
            m0 = lm(pheno[, 2] ~ top_vars_geno[, a] + top_vars_geno[, b])
            m1 = lm(pheno[, 2] ~ top_vars_geno[, a] * top_vars_geno[, b])
            s0 = summary(m0)
            s1 = summary(m1)
            output_pair[j, 'var1'] = var1
            output_pair[j, 'var2'] = var2
            output_pair[j, 'r2_additive'] = s0$r.squared
            output_pair[j, 'r2adj_additive'] = s0$adj.r.squared
            output_pair[j, 'r2_interact'] = s1$r.squared
            output_pair[j, 'r2adj_interact'] = s1$adj.r.squared
            output_pair[j, 'aic_additive'] = AICc(m0)
            output_pair[j, 'aic_interact'] = AICc(m1)
            output_pair[j, 'LRT_p'] = anova(m0, m1, test='LRT')[['Pr(>Chi)']][2]
        }
        write.table(output_pair,
                    file=paste0(output_prefix, '.interaction.tsv'),
                    col.names=(i == 1), row.names=FALSE, quote=FALSE, sep='\t',
                    append=(i != 1))
    }

}


#' This function run all the simulations based on the structure of the basic data frame.
#'
#' @param dataset dataset with all variables
#' @param exposures a vector with exposures
#' @param confounders a vector with confounders
#' @param libraries a vector of libraries to use
#' @param outcomes outcome´s name
#' @param num.sim number of simulations
#' @param delta a vector with two values
#' @param dr a vector with dose response values
#' @param newdata the dataframe with new values
#' @param show_times boolean parameter to see the time
#' @param show_num_sim boolean parameter to see the iteration of simulations
#' @param save_time boolean parameter to save the time in the result list
#' @param verbose boolean parameter to see the verbose of superlearner
#' @param family a character parameter to describe the family of the model
#' @param method a character parameter to choose the method in the superlearner
#' @return a list with 4 objects: a data frame with all simulations, risk and coefficients of the crossvalidation and the time of the proces.
#' @export
#' @details libraries could be SL if we don't select nothing or 'SL.glm', 'SL.glm.interaction','SL.glmnet', 'SL.gam','SL.xgboost','SL.polymars','SL.randomForest'

run_simulations <- function(dataset, exposures, confounders, libraries, outcomes, num.sim = 50, delta = c(0, 1), dr,
    newdata, show_times = FALSE, show_num_sim = TRUE, save_time = FALSE, verbose = FALSE, family = "gaussian", method = "method.NNLS") {
    if (class(exposures) %in% c("numeric", "integer")) {
        exposures <- names(dataset[, exposures])
    }
    if (class(confounders) %in% c("numeric", "integer")) {
        confounders <- names(dataset[, confounders])
    }
    if (class(outcomes) %in% c("numeric", "integer")) {
        outcomes <- names(dataset[, outcomes])
    }
  dataset <- data.frame(dataset)

    len_libraries <- length(libraries)
    if (len_libraries == 0) {
        simple_libr <- c("")
    } else {
        simple_libr <- gsub("SL.", "", libraries)
        simple_libr <- substr(gsub("\\.", "", simple_libr), 1, 5)
        simple_libr <- c("", simple_libr)
    }
    len_libraries <- length(libraries)
    var_tot <- c(exposures, confounders)

    d <- dataset
    N <- dim(d)[1]
    len_new <- dim(newdata)[1]

    big_matrix <- data.frame(matrix(NA, len_new, num.sim))

    risk <- data.frame(libraries, matrix(NA, len_libraries, num.sim))
    coef <- data.frame(libraries, matrix(NA, len_libraries, num.sim))

    if (save_time == TRUE)
        time3 <- NA
    t1 <- Sys.time()

    if (show_num_sim == TRUE) {
        for (i in 1:num.sim) {
            print(paste0("Run number ", i, "/", num.sim))

            idx <- sample(1:N, N, replace = T)
            dataset <- d[idx, ]

            modelo <- SuperLearner::SuperLearner(Y = dataset[, outcomes], X = dataset[, var_tot], SL.library = libraries,
                newX = newdata[, var_tot], verbose = verbose, family = family, method = method)
            risk[, i + 1] <- modelo$cvRisk
            coef[, i + 1] <- modelo$coef
            big_matrix[, i] <- modelo$SL.predict[, 1]
        }

    } else {
        print(paste0("Start running - ", Sys.time()))
        for (i in 1:num.sim) {
            idx <- sample(1:N, N, replace = T)
            dataset <- d[idx, ]

            modelo <- SuperLearner::SuperLearner(Y = dataset[, outcomes], X = dataset[, var_tot], SL.library = libraries,
                newX = newdata[, var_tot], verbose = verbose, family = family, method = method)
            risk[, i + 1] <- modelo$cvRisk
            coef[, i + 1] <- modelo$coef
            big_matrix[, i] <- modelo$SL.predict[, 1]
        }
        print(paste0("Finished - ", Sys.time()))
    }

    if (show_times == TRUE) {
        t2 <- Sys.time()
        print(t2 - t1)
        if (save_time == TRUE)
            time3 <- c(time3, t2 - t1)
    }

    fecha <- format(Sys.time(), "%Y%m%d%X")
    fecha <- gsub(":", "", fecha)
    return(list(big_matrix, risk, coef, time_proc = time3))

}


bathymetry_figures = function( p=NULL, varnames="z", logyvar=FALSE, isodepths = c( 100, 300, 500 ), savetofile="", width=1365, height=1024, pointsize=12, res=96, quality=80 ) {

  b = bathymetry_db( p=p, DS="complete" )
  b = b[b$z > 0 , ]

  for (vn in varnames) {
    print(vn)

    if (logyvar) {
      b = b[ b[,vn]>0, ]
      b[,vn] = log(b[,vn])
    }

    # oc = landmask( db="worldHires", regions=c("Canada", "US"), return.value="not.land", tag="predictions", crs=p$aegis_proj4string_planar_km )
    # if (length(oc) > 0) {
    #   b = b[oc,]
    # }

    b[,vn] = zapsmall( b[,vn] )
    datarange = quantile( b[,vn], probs=c(0.05, 0.95), na.rm=TRUE )
    dr = seq( datarange[1], datarange[2], length.out=100)
    ll = which( b[,vn] < datarange[1] )
    if (length(ll>0)) b[ll,vn] =  datarange[1]
    ul = which( b[,vn] > datarange[2] )
    if (length(ul>0)) b[ul,vn] =  datarange[2]

    levplt = levelplot( b[,vn] ~ plon + plat, data=b[,], aspect="iso", main=NULL,
      at=dr, col.regions=rev(color.code( "seis", dr)) ,
      contour=FALSE, labels=FALSE, pretty=TRUE, xlab=NULL,ylab=NULL,scales=list(draw=FALSE),
      panel = function(x, y, subscripts, ...) {
        panel.levelplot (x, y, subscripts, aspect="iso", rez=c(1,1), ...)
        sp.lines( as( isobath_db( DS="isobath", depths=isodepths, project_to=p$aegis_proj4string_planar_km ), "Spatial" ), col = "gray80", cex=0.1 )
        sp.lines( as( coastline_db( p=p, project_to=p$aegis_proj4string_planar_km ), "Spatial" ), col = "steelblue", cex=0.1 )
      }
    )

    if ( savetofile != "" ) {

      outdir = file.path( p$modeldir, p$stmv_model_label, p$project_class, paste(  p$stmv_global_modelengine, p$stmv_local_modelengine, sep="_"), p$stmv_variables$Y, "maps", p$spatial_domain )
      dir.create( outdir, showWarnings = TRUE, recursive = TRUE )

      for (i in 1:length(savetofile)){
        devtype = savetofile[i]
        if (devtype =="jpeg") devtype="jpg"
        fn = file.path( outdir, paste( "bathymetry", vn, p$spatial_domain, devtype, sep=".") )
        print(fn)
        if (devtype == "pdf" ) {
          pdf(file=fn, width=5, height=4, bg='white')
        } else if (devtype == "png" ) {
          png(filename=fn, width=width, height=height, pointsize=pointsize, res=res, bg='white' )
        } else if (devtype == "jpg" ) {
          jpeg(filename=fn, width=width, height=height, pointsize=pointsize, res=res, bg='white', quality=quality )
        } else {
          stop( "device not supported ... add it here")
        }
        print( levplt )
        dev.off()
      }
    } else {
      print( levplt )
    }

  }
  return(varnames)
}


#' ---
#' title: "Prepare dataset for MH to do Bayesian model comparison"
#' author: "Judith Degen"
#' date: "June 19, 2015"
#' Form of dataset for csv:
#' measure | subject | item | utterance | response
#' ---
library(tidyr)

setwd("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/writing/_2015/_journal_cognition/data/")
source("../rscripts/helpers.r")

# get empirical comprehension data expectations (comp_state)
load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/13_sinking-marbles-priordv-15/results/data/r.RData")

#comp_state = r[r$quantifier %in% c("Some","All","None"),] %>%
comp_state = r %>%
  select(workerid, Item, quantifier, response) %>%
  rename(subject=workerid, item=Item, utterance=quantifier)
comp_state$measure = "comp_state"
nrow(comp_state)
# 240 subjects

# get empirical comprehension data (comp_allprob)
load("~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/16_sinking-marbles-sliders-certain/results/data/r.RData")

comp_allprob = r[r$quantifier %in% c("Some","All","None") & r$Proportion == "100",] %>%
  select(workerid, Item, quantifier, normresponse) %>%
  rename(subject=workerid, item=Item, utterance=quantifier, response=normresponse)
comp_allprob$measure = "comp_allprob"
comp_allprob$subject = comp_allprob$subject + 240 # adjust subject ID so there are no duplicates with the other two experiments
nrow(comp_allprob)
# 240 subjects

# get empirical wonkiness data (wonkiness)
#load("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/17_sinking-marbles-normal-sliders/results/data/r.RData")
load("/Users/titlis/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/11_sinking-marbles-normal/results/data/r.RData")

wonkiness = r[r$quantifier %in% c("Some","All","None"),] %>%
  select(workerid, Item, quantifier, response) %>%
  rename(subject=workerid, item=Item, utterance=quantifier)
wonkiness$response = ifelse(wonkiness$response == "no",1,0)
wonkiness$measure = "wonkiness"
wonkiness$subject = wonkiness$subject + 480 # adjust subject ID so there are no duplicates with the other two experiments
# 120 subjects

d = droplevels(rbind(comp_state,comp_allprob,wonkiness),na.omit=T)
nrow(d)
str(d)
summary(d)
d = droplevels(d[!is.na(d$response),])
d[d$measure == "comp_allprob",]$response = round(d[d$measure == "comp_allprob",]$response, 1)
d[d$measure == "comp_allprob" & d$response == 0.0,]$response = 0.01
d[d$measure == "comp_allprob" & d$response == 1.0,]$response = 0.99

#write.csv(d,file="empirical.csv",row.names=F,quote=F)
write.csv(d,file="empirical_binarywonky.csv",row.names=F,quote=F)

d_nozero = droplevels(subset(d, !(measure == "comp_state" & utterance == "Some" & response == 0)))
nrow(d_nozero)
#write.csv(d_nozero,file="empirical_nozero.csv",row.names=F,quote=F)
write.csv(d_nozero,file="empirical_binarywonky_nozero.csv",row.names=F,quote=F)

# get prior probabilities from 4-step procedure
priorprobs = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/24_sinking-marbles-prior-fourstep/results/data/smoothed_15marbles_priors_withnames.txt",sep="\t", header=T, quote="")
row.names(priorprobs) = priorprobs$Item
nrow(priorprobs)

write.csv(priorprobs,file="priors.csv",row.names=F,quote=F)

# get prior probabilities from original 1-step procedure
priorprobs = read.table(file="~/cogsci/projects/stanford/projects/thegricean_sinking-marbles/experiments/12_sinking-marbles-prior15/results/data/smoothed_15marbles_priors_withnames.txt",sep="\t", header=T, quote="")
row.names(priorprobs) = priorprobs$Item
nrow(priorprobs)

write.csv(priorprobs,file="priors_original.csv",row.names=F,quote=F)

write.csv(priorprobs[c("laughed lawyers","melted ice cubes","stuck to the wall baseballs"),],file="priors_original_samplecases.csv",row.names=F,quote=F)


#selects best model by compairing AIC/AICc values of AR , Autofit/ARMA & auto.ARIMA models ---->3 Models
rm(list=ls())

#reading data files
apiary<-read.table("C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\AR\\AR_aic.txt",skip=1)       #opening mix AR_aic model data
csir_gate<-as.character(apiary$V1)  #all AR_aic ids

babuji<-read.table("C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\ARMA\\Autofit_arma_stationary.txt",skip=1)#opening autofit/ARMA stationary models

picture<-read.table("C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\Auto_ARIMA\\Auto_arima_all_gumshuda.txt",skip=1)   #opening Auto_ARIMA data
gol_square<-as.character(picture$V1)  #all auto_arima ids

leaflet<-NULL   #best AR model
guni_ranjan<-NULL   #best ARMA model
nasheman<-NULL  #best ARIMA model

for( nature in seq_along(babuji$V1) ){

nav_rich<-as.character(babuji[nature,]$V1)    #takes pdb id of stationary model

code_id<-pmatch(nav_rich,csir_gate)  #extracts position in AR_aic file
sairam<-pmatch(nav_rich,gol_square)  #extracts position in Auto_arima file

#taking aic
ar_balkadu<-apiary[code_id,]$V4        #AR_std_aic value
arma_aicc<-babuji[nature,]$V4  #ARMA AICc of stationary
auto_arima_aicc<-picture[sairam,]$V4  #auto ARIMA aicc                 #

 #checking which AIC/AICc value great
 srujan_chintan<-which.min(c(ar_balkadu,arma_aicc,auto_arima_aicc))

 if(srujan_chintan==1){nishani<-cbind(as.character(apiary[code_id,]$V1),apiary[code_id,]$V2,apiary[code_id,]$V4,deparse.level=0);  guni_ranjan<-rbind(guni_ranjan,nishani,deparse.level=0)}         #AR
 if(srujan_chintan==2){khelpatti<-cbind(nav_rich,babuji[nature,]$V2,babuji[nature,]$V3,babuji[nature,]$V4,deparse.level=0);  leaflet<-rbind(leaflet,khelpatti,deparse.level=0)}   #ARMA
 if(srujan_chintan==3){ subbu<-cbind(as.character(picture[sairam,]$V1),picture[sairam,]$V2 ,picture[sairam,]$V3,picture[sairam,]$V4,deparse.level=0);  nasheman<-rbind(nasheman,subbu,deparse.level=0) }  #auto_ARIMA

          } #checking for ends

#writes Best AR model list
 if(is.null(guni_ranjan)){write("Your All AR models fails for \"Best fitted Model\"","C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\Best_model\\Stationary\\Best_stationary_3\\Best_stationary_AR_3.txt")}else{
 write.table(guni_ranjan,"C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\Best_model\\Stationary\\Best_stationary_3\\Best_stationary_AR_3.txt",col.names=c("AR_PDB_id","P_value","AIC"),row.names=F)  } #AR last else

 #writes Best ARMA model  list
if(is.null(leaflet)){write("Your All ARMA models fails for \"Best fitted Model\"","C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\Best_model\\Stationary\\Best_stationary_3\\Best_stationary_ARMA_3.txt")}else{
write.table(leaflet,"C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\Best_model\\Stationary\\Best_stationary_3\\Best_stationary_ARMA_3.txt",col.names=c("ARMA_PDB_id","P_value","Q_value","AICC"),row.names=F)     }  #ARMA last else

 #writes Best auto ARIMA model  list
if(is.null(nasheman)){write("Your All auto_ARIMA models fails for \"Best fitted Model\"","C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\Best_model\\Stationary\\Best_stationary_3\\Best_stationary_auto_AIRMA_3.txt")}else{
write.table(nasheman,"C:\\Users\\msc2\\Desktop\\Halwa\\BADMASHI\\Model\\Best_model\\Stationary\\Best_stationary_3\\Best_stationary_ARIMA_3.txt",col.names=c("Auto_ARIMA_PDB_id","P_value","Q_value","AICC"),row.names=F)     }  #Auto_ARIMA last else