# install packages
# install.packages("tidyverse")
library(tidyverse)
# if (!requireNamespace("BiocManager", quietly = TRUE))
#   install.packages("BiocManager")
# BiocManager::install("limma")
library(limma)
library(plotly)
library(htmlwidgets)
source("GSEAenricher.R")

top_tables <- list()
pea_tables <- list()
bubble_plots <- list()

run_dea_pea <- function(matrix_file, metadata_file, doe_file, index, save_path_dea, save_path_pea) {
  matrixx <- readRDS(matrix_file)
  metadata <- readRDS(metadata_file)
  doe <- read_tsv(doe_file)

  Gender <- factor(make.names(doe$Gender))
  Age <- doe$AGE
  Braak <- factor(make.names(doe$Braak.stage))
  Batch <- factor(make.names(doe$Gel.Batch))

  design <- model.matrix(~0+Gender+Age+Braak+Batch)
  contrast <- makeContrasts(GenderComparison = GenderFemale - GenderMale, levels = design)

  fit <- lmFit(matrixx, design)
  # fit <- eBayes(fit)
  fit2 <- contrasts.fit(fit, contrast)
  fit2 <- eBayes (fit2)

  # top <- topTable(fit, coef = "GenderComparison", adjust.method = "BH",n=Inf, sort.by = "P")
  top2 <- topTable(fit2, coef = "GenderComparison", adjust.method = "BH",n=Inf, sort.by = "P")
  # top <- merge(top, metadata, by=0, all=TRUE)
  top2 <- merge(top2, metadata, by=0, all=TRUE)
  top2$Shown.ID <- top2$hgnc_symbol
  top2$Shown.ID[top2$Shown.ID==""] <- top2$Protein.IDs[top2$Shown.ID==""]
  top2$setting <- index

  top_tables[[index]] <<- top2

  top2_sig <- top2 %>%
     filter(P.Value <= 0.05)

  print (summary(decideTests(fit,adjust.method = "BH", p.value = 0.05)))
  print (summary(decideTests(fit,adjust.method = "none", p.value = 0.05)))
  print (summary(decideTests(fit2,adjust.method = "BH", p.value = 0.05)))
  print (summary(decideTests(fit2,adjust.method = "none", p.value = 0.05)))

  # write.table(top2_sig, file='sig.tsv', quote=FALSE, sep='\t', col.names = NA)

  load("gmt-go.Rdata")

  g1 <- do_GSEA(top2, 1, gmt.go, group_name = "F_vs_M", Protein.ID.Column ="Protein.IDs")

  g1$df$setting <- index

  g1_filtered <- g1$df %>%
    filter(pvalue < 0.05)

  pea_tables[[index]] <<- g1

  hcal_dea <- max ((length (unique (top2$Protein.IDs)) * 16.5 + 25 + 10 + 100), 500)
  hcal_pea <- max ((length (unique (g1$df$ID)) * 16.5 + 25 + 10 + 100), 500)
  #gp.pt <- ggplotly(p, tooltip = "text", height = hcal, source="DEAPlotSource") %>%
  #  layout (yaxis=(list(automargin = F)), margin=list (l=200))

  # ggplot(top2_sig, aes(y=Protein.IDs, x=logFC)) +
  #   geom_point(aes(size=P.Value, color=AveExpr)) +
  #   labs(y="Protein IDs", x="logFC", color="Average expression", size="P-value") +
  #   theme(axis.text.x=element_text(angle=45, hjust=1), axis.text.y=element_text(size = 8, angle = 0, hjust = 1, face = "plain"))

  p1 <- ggplot (data=top2_sig, aes (x=logFC, y=Protein.IDs)) +
    geom_point(aes (size=AveExpr, fill=logFC, color=-log10(P.Value), stroke=0.5, text=paste('Log fold change:', logFC, '
',
                                                                                'Average expression:', AveExpr,'
',
                                                                                't-statistic:', t,'
',
                                                                                'P-value:',P.Value,'
',
                                                                                'Negative log10-P-value:',-log10(P.Value),'
',
                                                                                'B-statistic:',B,'
'))) +
    scale_fill_gradient2(limits=c(-max(abs(top2_sig$logFC)), max(abs(top2_sig$logFC))), low = "#0199CC", mid = "white", high = "#FF3705", midpoint = 0) +
    scale_color_gradient2(limits=c(0, max(abs(log10(top2_sig$P.Value)))), low = "white", mid = "white", high = "black", midpoint = 1) +
    theme_minimal () + xlab("Comparison") + ylab("") +
    theme(axis.text.x=element_text(angle=45, hjust=1), axis.text.y=element_text(size = 8, angle = 0, hjust = 1, face = "plain"))

  gp.pt.1 <- ggplotly(p1, tooltip = "text", height = hcal_dea) %>%
    layout (yaxis=(list(automargin = F)), margin=list (l=200))

  saveWidget(gp.pt.1, save_path_dea)

  # ggsave(save_path_dea)

  # ggplot(g1_filtered, aes(y=ID, x=rank)) +
  #   geom_point(aes(size=pvalue, color=enrichmentScore)) +
  #   labs(y="Protein IDs", x="logFC", color="Enrichment score", size="P-value") +
  #   theme(axis.text.x=element_text(angle=45, hjust=1), axis.text.y=element_text(size = 8, angle = 0, hjust = 1, face = "plain"))

  p2 <- ggplot (data=g1_filtered, aes (x=enrichmentScore, y=ID)) +
    geom_point(aes (size=setSize, fill=NES, color=-log10(pvalue), stroke=0.5, text=paste('Core_enrichment:', core_enrichment, '
',
                                                                                'Comparison:', Group,'
',
                                                                                'Setsize:', setSize,'
',
                                                                                'NES:',NES,'
',
                                                                                'pvalue:',pvalue,'
',
                                                                                'rank:',rank,'
',
                                                                                'leading_edge:',leading_edge,'
'))) +
    scale_fill_gradient2(limits=c(-max(abs(g1_filtered$NES)), max(abs(g1_filtered$NES))), low = "#0199CC", mid = "white", high = "#FF3705", midpoint = 0) +
    scale_color_gradient2(limits=c(0, max(abs(log10(g1_filtered$pvalue)))), low = "white", mid = "white", high = "black", midpoint = 1) +
    theme_minimal () + xlab("Comparison") + ylab("") +
    theme(axis.text.x=element_text(angle=45, hjust=1), axis.text.y=element_text(size = 8, angle = 0, hjust = 1, face = "plain"))

  gp.pt.2 <- ggplotly(p2, tooltip = "text", height = hcal_pea) %>%
    layout (yaxis=(list(automargin = F)), margin=list (l=200))

  saveWidget(gp.pt.2, save_path_pea)

  # ggsave(save_path_pea)
}

run_dea_pea("pgdata_matrix_1.rds", "pgdata_metadata_1.rds", "manifest2.tsv", "filter_mindet", "dea_1.html", "pea_1.html")
run_dea_pea("pgdata_matrix_2.rds", "pgdata_metadata_2.rds", "manifest2.tsv", "filter_bpca", "dea_2.html", "pea_2.html")
run_dea_pea("pgdata_matrix_3.rds", "pgdata_metadata_3.rds", "manifest2.tsv", "nofilter_mindet", "dea_3.html", "pea_3.html")
run_dea_pea("pgdata_matrix_4.rds", "pgdata_metadata_4.rds", "manifest2.tsv", "nofilter_bpca", "dea_4.html", "pea_4.html")

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

# process top tables

top2_all <- rbind(top_tables[["filter_mindet"]], top_tables[["filter_bpca"]], top_tables[["nofilter_mindet"]], top_tables[["nofilter_bpca"]])

# process ggplot

gp_all <- rbind(pea_tables[["filter_mindet"]]$df, pea_tables[["filter_bpca"]]$df, pea_tables[["nofilter_mindet"]]$df, pea_tables[["nofilter_bpca"]]$df)

hcal_dea <- max ((length (unique (top2_all$Protein.IDs)) * 16.5 + 25 + 10 + 100), 500)
hcal_pea <- max ((length (unique (gp_all$ID)) * 16.5 + 25 + 10 + 100), 500)
#gp.pt <- ggplotly(p, tooltip = "text", height = hcal, source="DEAPlotSource") %>%
#  layout (yaxis=(list(automargin = F)), margin=list (l=200))

# ggplot(top2_sig, aes(y=Protein.IDs, x=logFC)) +
#   geom_point(aes(size=P.Value, color=AveExpr)) +
#   labs(y="Protein IDs", x="logFC", color="Average expression", size="P-value") +
#   theme(axis.text.x=element_text(angle=45, hjust=1), axis.text.y=element_text(size = 8, angle = 0, hjust = 1, face = "plain"))

p1 <- ggplot (data=top2_all, aes (x=setting, y=Protein.IDs)) +
  geom_point(aes (size=AveExpr, fill=logFC, color=-log10(P.Value), stroke=0.5, text=paste('Log fold change:', logFC, '
',
                                                                                'Average expression:', AveExpr,'
',
                                                                                't-statistic:', t,'
',
                                                                                'P-value:',P.Value,'
',
                                                                                'Negative log10-P-value:',-log10(P.Value),'
',
                                                                                'B-statistic:',B,'
'))) +
  scale_fill_gradient2(limits=c(-max(abs(top2_sig$logFC)), max(abs(top2_sig$logFC))), low = "#0199CC", mid = "white", high = "#FF3705", midpoint = 0) +
  scale_color_gradient2(limits=c(0, max(abs(log10(top2_sig$P.Value)))), low = "white", mid = "white", high = "black", midpoint = 1) +
  theme_minimal () + xlab("Comparison") + ylab("") +
  theme(axis.text.x=element_text(angle=45, hjust=1), axis.text.y=element_text(size = 8, angle = 0, hjust = 1, face = "plain"))

gp.pt.1 <- ggplotly(p1, tooltip = "text", height = hcal_dea) %>%
  layout (yaxis=(list(automargin = F)), margin=list (l=200))

saveWidget(gp.pt.1, "dea_all.html")

# ggsave(save_path_dea)

# ggplot(g1_filtered, aes(y=ID, x=rank)) +
#   geom_point(aes(size=pvalue, color=enrichmentScore)) +
#   labs(y="Protein IDs", x="logFC", color="Enrichment score", size="P-value") +
#   theme(axis.text.x=element_text(angle=45, hjust=1), axis.text.y=element_text(size = 8, angle = 0, hjust = 1, face = "plain"))

p2 <- ggplot (data=gp_all, aes (x=setting, y=ID, customdata=paste0 (gp_all$Pathway,"%sep%", gp_all$core_enrichment))) +
  geom_point(aes (size=setSize, fill=NES, color=-log10(pvalue), stroke=0.5, text=paste('Core_enrichment:', core_enrichment, '
',
                                                                                'Comparison:', Group,'
',
                                                                                'Setsize:', setSize,'
',
                                                                                'NES:',NES,'
',
                                                                                'pvalue:',pvalue,'
',
                                                                                'rank:',rank,'
',
                                                                                'leading_edge:',leading_edge,'
'))) +
  scale_fill_gradient2(limits=c(-max(abs(gp_all$NES)), max(abs(gp_all$NES))), low = "#0199CC", mid = "white", high = "#FF3705", midpoint = 0) +
  scale_color_gradient2(limits=c(0, max(abs(log10(gp_all$pvalue)))), low = "white", mid = "white", high = "black", midpoint = 1) +
  theme_minimal () + xlab("Comparison") + ylab("") +
  theme(axis.text.x=element_text(angle=45, hjust=1), axis.text.y=element_text(size = 8, angle = 0, hjust = 1, face = "plain"))

gp.pt.2 <- ggplotly(p2, tooltip = "text", height = hcal_pea) %>%
  layout (yaxis=(list(automargin = F)), margin=list (l=200))

saveWidget(gp.pt.2, "pea_all.html")


#Comparing R2 density between Tedersoo out-of-sample (OOS) forecast to NEON and NEON cross-validation (CV).
rm(list=ls())
source('paths_fall2019.r')
source('paths.r')
source('NEFI_functions/zero_truncated_density.r')
source('NEFI_functions/rsq_1.1.r')
library(RColorBrewer)

#set figure out put path.----
output.path <- 'figures/Supp._Fig._1._cross.validation_r2.jpg'

#Load ITS cross-validation data..----
#Cross validation forecasts
cv.val.core.ITS <- readRDS(core.CV_NEON_fcast.path)
cv.val.plot.ITS <- readRDS(plot.CV_NEON_fcast.path)

#Cross validation data (calibration and validation)
cv.dat.core.ITS <- readRDS(core.CV_NEON_cal.val_data.path)
cv.dat.plot.ITS <- readRDS(plot.CV_NEON_cal.val_data.path)
cv.dat.core.ITS <- cv.dat.core.ITS$val$y.val
cv.dat.plot.ITS <- cv.dat.plot.ITS$val$y.val

#Load 16S cross-validation data.-----
#Cross validation forecasts
cv.val.core.16S <- readRDS(core.CV_NEON_fcast_16S.path)
cv.val.plot.16S <- readRDS(plot.CV_NEON_fcast_16S.path)

#Cross validation data (calibration and validation)
cv.dat.core.16S <- readRDS(core.CV_NEON_cal.val_data_16S.path)
cv.dat.plot.16S <- readRDS(plot.CV_NEON_cal.val_data_16S.path)
cv.dat.core.16S <- cv.dat.core.16S$val$y.val
cv.dat.plot.16S <- cv.dat.plot.16S$val$y.val

# Create table to link deprecatedVialID and geneticSampleID
map <- readRDS(core_obs.path)[,c("geneticSampleID","deprecatedVialID")]
map$geneticSampleID <- gsub('-GEN','',map$geneticSampleID)
#drop observations with no deprecated Vial ID.
map <- map[!(map$deprecatedVialID == ''),]

#16S NEON Cross-validated stats at core and plot level.-----
#core level.
core.list.16S <- list()
for(i in 1:length(cv.val.core.16S)){
  x <- cv.val.core.16S[[i]]$core.fit$mean
  y <- cv.dat.core.16S[[i]]$rel.abundances
  #updated y rownames.
  ref <- map[map$deprecatedVialID %in% rownames(y),]
  y <-   y[rownames(y) %in% ref$deprecatedVialID,]
  ref <- ref[order(match(ref$deprecatedVialID, rownames(y))),]
  rownames(y) <- ref$geneticSampleID

  #match row and column names.
  y <- y[,order(match(colnames(y), colnames(x)))]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[rownames(y) %in% rownames(x),]
  y <- y[order(match(rownames(y), rownames(x))),]
  #Get R2 for each column.
  lev.stats <- list()
  for(j in 1:ncol(y)){
    #r square best fit.
    fit <- lm(y[,j] ~ x[,j])
    rsq <- summary(fit)$r.squared
    #r square 1:1.
    rss <- sum((x[,j] -      y[,j])  ^ 2)  ## residual sum of squares
    tss <- sum((y[,j] - mean(y[,j])) ^ 2)  ##    total sum of squares
    rsq1 <- 1 - rss/tss
    rsq1 <- rsq_1.1(y[,j], x[,j])          ## new rsq_1.1 function.
    if(rsq1 < 0){rsq1 <- 0}
    #RMSE.
    rmse <- sqrt(mean(fit$residuals^2))
    return <- c(rsq,rsq1,rmse)
    lev.stats[[j]] <- return
  }
  lev.stats <- do.call(rbind, lev.stats)
  colnames(lev.stats) <- c('rsq','rsq1','rmse')
  rownames(lev.stats) <- colnames(y)
  lev.stats <- lev.stats[-(rownames(lev.stats) %in% 'other'),]
  core.list.16S[[i]] <- lev.stats
}
names(core.list.16S) <- names(cv.val.core.16S)

#plot level.
plot.list.16S <- list()
for(i in 1:length(cv.val.plot.16S)){
  x <- cv.val.plot.16S[[i]]$plot.fit$mean
  y <- cv.dat.plot.16S[[i]]$mean
  #match row and column names.
  y <- y[,order(match(colnames(y), colnames(x)))]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[rownames(y) %in% rownames(x),]
  y <- y[order(match(rownames(y), rownames(x))),]
  #Get R2 for each column.
  lev.stats <- list()
  for(j in 1:ncol(y)){
    #r square best fit.
    fit <- lm(y[,j] ~ x[,j])
    rsq <- summary(fit)$r.squared
    #r square 1:1.
    rss <- sum((x[,j] -      y[,j])  ^ 2)  ## residual sum of squares
    tss <- sum((y[,j] - mean(y[,j])) ^ 2)  ## total sum of squares
    rsq1 <- 1 - rss/tss
    rsq1 <- rsq_1.1(y[,j], x[,j])          ## new rsq_1.1 function.
    if(rsq1 < 0){rsq1 <- 0}
    #RMSE.
    rmse <- sqrt(mean(fit$residuals^2))
    return <- c(rsq,rsq1,rmse)
    lev.stats[[j]] <- return
  }
  lev.stats <- do.call(rbind, lev.stats)
  colnames(lev.stats) <- c('rsq','rsq1','rmse')
  rownames(lev.stats) <- colnames(y)
  lev.stats <- lev.stats[-(rownames(lev.stats) %in% 'other'),]
  plot.list.16S[[i]] <- lev.stats
}
names(plot.list.16S) <- names(cv.val.plot.16S)

#16S collapse functional groups.----
phylo <- c('phylum','class','order','family','genus')
ref <- core.list.16S[!(names(core.list.16S) %in% phylo)]
core.list.16S <- core.list.16S[names(core.list.16S) %in% phylo]
core.list.16S$functional <- do.call(rbind, ref)
core.all.16S <- data.frame(do.call(rbind, core.list.16S))
ref <- plot.list.16S[!(names(plot.list.16S) %in% phylo)]
plot.list.16S <- plot.list.16S[names(plot.list.16S) %in% phylo]
plot.list.16S$functional <- do.call(rbind, ref)
plot.all.16S <- data.frame(do.call(rbind, plot.list.16S))

#16S means by taxaonomic level.----
#core scale.
core.lev.mu.16S <- list()
for(i in 1:length(core.list.16S)){
  z <- data.frame(core.list.16S[[i]])
  core.lev.mu.16S[[i]] <- mean(z$rsq1, na.rm = T)
}
core.lev.mu.16S <- unlist(core.lev.mu.16S)
names(core.lev.mu.16S) <- names(core.list.16S)
ref.order <- c(length(core.lev.mu.16S), 1:(length(core.lev.mu.16S) - 1))
core.lev.mu.16S <- core.lev.mu.16S[ref.order]

#plot scale.
plot.lev.mu.16S <- list()
for(i in 1:length(plot.list.16S)){
  z <- data.frame(plot.list.16S[[i]])
  #make sure its in the core-level validation as well.
  z <- z[rownames(z) %in% rownames(core.all.16S),]
  plot.lev.mu.16S[[i]] <- mean(z$rsq1, na.rm = T)
}
plot.lev.mu.16S <- unlist(plot.lev.mu.16S)
names(plot.lev.mu.16S) <- names(plot.list.16S)
ref.order <- c(length(plot.lev.mu.16S), 1:(length(plot.lev.mu.16S) - 1))
plot.lev.mu.16S <- plot.lev.mu.16S[ref.order]

#put together.
to.plot <- cbind(core.lev.mu, plot.lev.mu)
to.plot.16S <- cbind(core.lev.mu.16S, plot.lev.mu.16S)

#ITS NEON Cross-validated stats at core and plot level.-----
#core level.
core.list.ITS <- list()
for(i in 1:length(cv.val.core.ITS)){
  x <- cv.val.core.ITS[[i]]$core.fit$mean
  y <- cv.dat.core.ITS[[i]]$rel.abundances
  #deal with trailing -GEN
  rownames(y) <- gsub('-GEN','', rownames(y))
  rownames(x) <- gsub('-GEN','', rownames(x))
  #match row and column names.
  y <- y[,order(match(colnames(y), colnames(x)))]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[rownames(y) %in% rownames(x),]
  y <- y[order(match(rownames(y), rownames(x))),]
  #Get R2 for each column.
  lev.stats <- list()
  for(j in 1:ncol(y)){
    #r square best fit.
    fit <- lm(y[,j] ~ x[,j])
    rsq <- summary(fit)$r.squared
    #r square 1:1.
    rss <- sum((x[,j] -      y[,j])  ^ 2)  ## residual sum of squares
    tss <- sum((y[,j] - mean(y[,j])) ^ 2)  ##    total sum of squares
    rsq1 <- 1 - rss/tss
    rsq1 <- rsq_1.1(y[,j], x[,j])          ## new rsq_1.1 function.
    if(rsq1 < 0){rsq1 <- 0}
    #RMSE.
    rmse <- sqrt(mean(fit$residuals^2))
    return <- c(rsq,rsq1,rmse)
    lev.stats[[j]] <- return
  }
  lev.stats <- do.call(rbind, lev.stats)
  colnames(lev.stats) <- c('rsq','rsq1','rmse')
  rownames(lev.stats) <- colnames(y)
  lev.stats <- lev.stats[-(rownames(lev.stats) %in% 'other'),]
  core.list.ITS[[i]] <- lev.stats
}
names(core.list.ITS) <- names(cv.val.core.ITS)

#plot level.
plot.list.ITS <- list()
for(i in 1:length(cv.val.plot.ITS)){
  x <- cv.val.plot.ITS[[i]]$plot.fit$mean
  y <- cv.dat.plot.ITS[[i]]$mean
  #deal with trailing -GEN
  rownames(y) <- gsub('-GEN','', rownames(y))
  rownames(x) <- gsub('-GEN','', rownames(x))
  #match row and column names.
  y <- y[,order(match(colnames(y), colnames(x)))]
  x <- x[rownames(x) %in% rownames(y),]
  y <- y[rownames(y) %in% rownames(x),]
  y <- y[order(match(rownames(y), rownames(x))),]
  #Get R2 for each column.
  lev.stats <- list()
  for(j in 1:ncol(y)){
    #r square best fit.
    fit <- lm(y[,j] ~ x[,j])
    rsq <- summary(fit)$r.squared
    #r square 1:1.
    rss <- sum((x[,j] -      y[,j])  ^ 2)  ## residual sum of squares
    tss <- sum((y[,j] - mean(y[,j])) ^ 2)  ## total sum of squares
    rsq1 <- 1 - rss/tss
    rsq1 <- rsq_1.1(y[,j], x[,j])          ## new rsq_1.1 function.
    if(rsq1 < 0){rsq1 <- 0}
    #RMSE.
    rmse <- sqrt(mean(fit$residuals^2))
    return <- c(rsq,rsq1,rmse)
    lev.stats[[j]] <- return
  }
  lev.stats <- do.call(rbind, lev.stats)
  colnames(lev.stats) <- c('rsq','rsq1','rmse')
  rownames(lev.stats) <- colnames(y)
  lev.stats <- lev.stats[-(rownames(lev.stats) %in% 'other'),]
  plot.list.ITS[[i]] <- lev.stats
}
names(plot.list.ITS) <- names(cv.val.plot.ITS)

#ITS means by taxaonomic level.----
#core scale.
core.lev.mu.ITS <- list()
for(i in 1:length(core.list.ITS)){
  z <- data.frame(core.list.ITS[[i]])
  core.lev.mu.ITS[[i]] <- mean(z$rsq1, na.rm = T)
}
core.lev.mu.ITS <- unlist(core.lev.mu.ITS)
names(core.lev.mu.ITS) <- names(core.list.ITS)
names(core.lev.mu.ITS)[length(core.lev.mu.ITS)] <- 'functional'
ref.order <- c(length(core.lev.mu.ITS), 1:(length(core.lev.mu.ITS) - 1))
core.lev.mu.ITS <- core.lev.mu.ITS[ref.order]
core.all.ITS <- data.frame(do.call(rbind, core.list.ITS))

#plot scale.
plot.lev.mu.ITS <- list()
for(i in 1:length(plot.list.ITS)){
  z <- data.frame(plot.list.ITS[[i]])
  #make sure its in the core-level validation as well.
  z <- z[rownames(z) %in% rownames(core.all.ITS),]
  plot.lev.mu.ITS[[i]] <- mean(z$rsq1, na.rm = T)
}
plot.lev.mu.ITS <- unlist(plot.lev.mu.ITS)
names(plot.lev.mu.ITS) <- names(plot.list.ITS)
names(plot.lev.mu.ITS)[length(plot.lev.mu.ITS)] <- 'functional'
ref.order <- c(length(plot.lev.mu.ITS), 1:(length(plot.lev.mu.ITS) - 1))
plot.lev.mu.ITS <- plot.lev.mu.ITS[ref.order]
plot.all.ITS <- data.frame(do.call(rbind, plot.list.ITS))

#put together.
to.plot.ITS <- cbind(core.lev.mu.ITS, plot.lev.mu.ITS)

#jpeg save line.-----
jpeg(filename=output.path,width=8,height=5,units='in',res=300)

#Begin plot: Global plot settings.-----
par(mfrow = c(1,2),
    mar = c(4,4,2,2))
limx <- c(0,1)
trans <- 0.2 #shading transparency.
o.cex <- 1.3 #outer label size.
y.cex <- 1.3
cols <- brewer.pal(nrow(to.plot.16S) - 1,'Spectral')
cols <- c(cols,'green')

#16S by spatial and taxonomic scale.----
y.check <- max(cbind(to.plot.16S, to.plot.ITS))
limy <- c(0, max(y.check)*1.1)
x <- c(1:2)
limx <- c(min(x)*0.95, max(x)*1.05)
plot(to.plot.16S[1,] ~ x, xlim = limx, ylim = limy, bty = 'l', col = 'black', bg = cols[1],
     pch = 21, cex = 2.5, xlab= NA, ylab = NA, xaxt = 'n')
lines(x, to.plot.16S[1,], lty = 1, col = cols[1], lwd = 1.5)
for(i in 2:nrow(to.plot.16S)){
  points(to.plot.16S[i,] ~ x, pch = 21, cex = 2.5, col = 'black', bg = cols[i])
  lines(x, to.plot.16S[i,], lty = 1, lwd = 1.5,    col = cols[i])
}
axis(1, at = c(1,2,3), labels = F)
lab <- c('core','plot')
text(x=x+0.05, y = limy[1] - limy[2]*0.1, labels= lab, srt=45, adj=1, xpd=TRUE, cex = o.cex)
rsq.1.lab <- bquote({'Cross-Validated R'^2} [1:1])
mtext(rsq.1.lab, side = 2, line = 2.5, cex = y.cex)
#mtext(expression(paste("Cross-Validated R"^"2")), side = 2, line = 2.5, cex = y.cex)
leg.lab <- rownames(to.plot.16S)
legend('bottomright',leg.lab, pch = 21, col = 'black', pt.bg = cols, ncol = 2, bty= 'n')
mtext('(a)', side = 3, adj = 0.98, line = -1)
mtext('Bacteria', side = 3, adj = 0.03, line = -1, cex = o.cex)

#ITS by spatial and taxonomic scale.----
#limy <- c(0, max(to.plot.ITS)*1.1)
x <- c(1:2)
limx <- c(min(x)*0.95, max(x)*1.05)
plot(to.plot.ITS[1,] ~ x, xlim = limx, ylim = limy, bty = 'l', col = 'black', bg = cols[1],
     pch = 21, cex = 2.5, xlab= NA, ylab = NA, xaxt = 'n')
lines(x, to.plot.ITS[1,], lty = 1, col = cols[1], lwd = 1.5)
for(i in 2:nrow(to.plot.ITS)){
  points(to.plot.ITS[i,] ~ x, pch = 21, cex = 2.5, col = 'black', bg = cols[i])
  lines(x, to.plot.ITS[i,], lty = 1, lwd = 1.5,    col = cols[i])
}
axis(1, at = c(1,2,3), labels = F)
lab <- c('core','plot')
text(x=x+0.05, y = limy[1] - limy[2]*0.1, labels= lab, srt=45, adj=1, xpd=TRUE, cex = o.cex)
rsq.1.lab <- bquote({'Cross-Validated R'^2} [1:1])
mtext(rsq.1.lab, side = 2, line = 2.5, cex = y.cex)
#mtext(expression(paste("Cross-Validated R"^"2")), side = 2, line = 2.5, cex = y.cex)
leg.lab <- rownames(to.plot.ITS)
#legend('topleft',leg.lab, pch = 21, col = 'black', pt.bg = cols, ncol = 1, bty= 'n')
mtext('(b)', side = 3, adj = 0.98, line = -1)
mtext('Fungi', side = 3, adj = 0.03, line = -1, cex = o.cex)

#end plot.-----
dev.off()


./tests.verify: test performed on 2004.03.31

#### Test: ./tests.verify running ./make_F77_app.sh
we make a test run:
 call gridloop1 was run 50 times!
 in f2  0.
 in f2  0.5
 in f2  1.
 in f2  1.
 in f2  1.5
 in f2  2.
 in f2  2.
 in f2  2.5
 in f2  3.
value at ( 0.000, 0.000) = a(  0,  0) =  0.00000E+00
value at ( 0.500, 0.000) = a(  1,  0) =  0.50000E+00
value at ( 1.000, 0.000) = a(  2,  0) =  0.10000E+01
value at ( 0.000, 0.500) = a(  0,  1) =  0.10000E+01
value at ( 0.500, 0.500) = a(  1,  1) =  0.15000E+01
value at ( 1.000, 0.500) = a(  2,  1) =  0.20000E+01
value at ( 0.000, 1.000) = a(  0,  2) =  0.20000E+01
value at ( 0.500, 1.000) = a(  1,  2) =  0.25000E+01
value at ( 1.000, 1.000) = a(  2,  2) =  0.30000E+01
cmd: ./tmp.app; elapsed=6.910000.2 cpu=6.860000.2
CPU time of ./make_F77_app.sh: 7.2 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running ./tmp.app
 call gridloop1 was run 50 times!
 in f2  0.
 in f2  0.5
 in f2  1.
 in f2  1.
 in f2  1.5
 in f2  2.
 in f2  2.
 in f2  2.5
 in f2  3.
value at ( 0.000, 0.000) = a(  0,  0) =  0.00000E+00
value at ( 0.500, 0.000) = a(  1,  0) =  0.50000E+00
value at ( 1.000, 0.000) = a(  2,  0) =  0.10000E+01
value at ( 0.000, 0.500) = a(  0,  1) =  0.10000E+01
value at ( 0.500, 0.500) = a(  1,  1) =  0.15000E+01
value at ( 1.000, 0.500) = a(  2,  1) =  0.20000E+01
value at ( 0.000, 1.000) = a(  0,  2) =  0.20000E+01
value at ( 0.500, 1.000) = a(  1,  2) =  0.25000E+01
value at ( 1.000, 1.000) = a(  2,  2) =  0.30000E+01
CPU time of ./tmp.app: 6.9 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running ./make_module_1.sh
running build
running run_f2py
creating tmp1
Reading fortran codes...
	Reading file 'gridloop.f'
Line #6 in gridloop.f:"      external f2, myfunc"
	analyzeline: ignoring program arguments
Line #6 in gridloop.f:"      external f2, myfunc"
	analyzeline: ignoring program arguments
Post-processing...
	Block: ext_gridloop
			Block: test
In: :ext_gridloop:gridloop.f:test
analyzevars:replacing parameter 'nmax' in 'nmax*nmax' (dimension of 'f') with '1100'
			Block: gridloop1
					Block: func1
			Block: gridloop2
					Block: func1
			Block: gridloop3
					Block: func1
			Block: gridloop4
					Block: func1
			Block: gridloop_vec
					Block: func1
			Block: gridloop_vec2
					Block: func1
			Block: gridloop2_str
			Block: gridloop1_v1
					Block: func1
			Block: gridloop1_v2
					Block: func1
			Block: gridloop1_v3
					Block: func1
			Block: gridloop1_v4
					Block: func1
			Block: gridloop1_v5
					Block: func1
			Block: transpose2dim
			Block: dump
			Block: change
			Block: gridloop2_fixedfunc1
			Block: myfunc
			Block: f2
Saving signatures to file "./tmp1/ext_gridloop.pyf"
Reading fortran codes...
	Reading file 'tmp1/ext_gridloop.pyf'
Post-processing...
	Block: gridloop1__user__routines
		Block: gridloop1_user_interface
			Block: func1
	Block: gridloop2__user__routines
		Block: gridloop2_user_interface
			Block: func1
	Block: gridloop3__user__routines
		Block: gridloop3_user_interface
			Block: func1
	Block: gridloop4__user__routines
		Block: gridloop4_user_interface
			Block: func1
	Block: gridloop_vec__user__routines
		Block: gridloop_vec_user_interface
			Block: func1
	Block: gridloop_vec2__user__routines
		Block: gridloop_vec2_user_interface
			Block: func1
	Block: gridloop1_v1__user__routines
		Block: gridloop1_v1_user_interface
			Block: func1
	Block: gridloop1_v2__user__routines
		Block: gridloop1_v2_user_interface
			Block: func1
	Block: gridloop1_v3__user__routines
		Block: gridloop1_v3_user_interface
			Block: func1
	Block: gridloop1_v4__user__routines
		Block: gridloop1_v4_user_interface
			Block: func1
	Block: gridloop1_v5__user__routines
		Block: gridloop1_v5_user_interface
			Block: func1
	Block: ext_gridloop
			Block: gridloop1
			Block: gridloop2
			Block: gridloop3
			Block: gridloop4
			Block: gridloop_vec
			Block: gridloop_vec2
			Block: gridloop2_str
			Block: gridloop1_v1
			Block: gridloop1_v2
			Block: gridloop1_v3
			Block: gridloop1_v4
			Block: gridloop1_v5
			Block: transpose2dim
			Block: dump
			Block: change
			Block: gridloop2_fixedfunc1
			Block: myfunc
			Block: f2
Building modules...
	Constructing call-back function "cb_func1_in_gridloop1__user__routines"
	  def func1(x,y): return func1
	Constructing call-back function "cb_func1_in_gridloop2__user__routines"
	  def func1(x,y): return func1
	Constructing call-back function "cb_func1_in_gridloop3__user__routines"
	  def func1(x,y): return func1
	Constructing call-back function "cb_func1_in_gridloop4__user__routines"
	  def func1(x,y): return func1
	Constructing call-back function "cb_func1_in_gridloop_vec__user__routines"
	  def func1(a,xcoor,ycoor,[nx,ny]): return a
	Constructing call-back function "cb_func1_in_gridloop_vec2__user__routines"
	  def func1(a,[nx,ny]): return a
	Constructing call-back function "cb_func1_in_gridloop1_v1__user__routines"
	  def func1(x,y): return func1
	Constructing call-back function "cb_func1_in_gridloop1_v2__user__routines"
	  def func1(x,y): return func1
	Constructing call-back function "cb_func1_in_gridloop1_v3__user__routines"
	  def func1(x,y): return func1
	Constructing call-back function "cb_func1_in_gridloop1_v4__user__routines"
	  def func1(x,y): return func1
	Constructing call-back function "cb_func1_in_gridloop1_v5__user__routines"
	  def func1(x,y): return func1
	Building module "ext_gridloop"...
		Constructing wrapper function "gridloop1"...
		  gridloop1(a,xcoor,ycoor,func1,[nx,ny,func1_extra_args])
		Constructing wrapper function "gridloop2"...
		  a = gridloop2(xcoor,ycoor,func1,[nx,ny,func1_extra_args])
		Constructing wrapper function "gridloop3"...
		  a = gridloop3(a,xcoor,ycoor,func1,[nx,ny,func1_extra_args])
		Constructing wrapper function "gridloop4"...
		  a = gridloop4(a,xcoor,ycoor,func1,[nx,ny,overwrite_a,func1_extra_args])
		Constructing wrapper function "gridloop_vec"...
		  a = gridloop_vec(a,xcoor,ycoor,func1,[nx,ny,func1_extra_args])
		Constructing wrapper function "gridloop_vec2"...
		  a = gridloop_vec2(a,func1,[nx,ny,func1_extra_args])
		Constructing wrapper function "gridloop2_str"...
		  a = gridloop2_str(xcoor,ycoor,func_str,[nx,ny])
		Constructing wrapper function "gridloop1_v1"...
		  gridloop1_v1(a,xcoor,ycoor,func1,[nx,ny,func1_extra_args])
		Constructing wrapper function "gridloop1_v2"...
		  a = gridloop1_v2(xcoor,ycoor,func1,[nx,ny,func1_extra_args])
		Constructing wrapper function "gridloop1_v3"...
		  gridloop1_v3(a,xcoor,ycoor,func1,[nx,ny,func1_extra_args])
		Constructing wrapper function "gridloop1_v4"...
		  gridloop1_v4(a,xcoor,ycoor,func1,[nx,ny,func1_extra_args])
		Constructing wrapper function "gridloop1_v5"...
		  gridloop1_v5(a,xcoor,ycoor,func1,[nx,ny,func1_extra_args])
		Constructing wrapper function "transpose2dim"...
		  transpose2dim(a,at,[nx,ny])
		Constructing wrapper function "dump"...
		  dump(a,xcoor,ycoor,[nx,ny])
		Constructing wrapper function "change"...
		  change(a,xcoor,ycoor,[nx,ny])
		Constructing wrapper function "gridloop2_fixedfunc1"...
		  a = gridloop2_fixedfunc1(xcoor,ycoor,[nx,ny])
		Creating wrapper for Fortran function "myfunc"("myfunc")...
		Constructing wrapper function "myfunc"...
		  myfunc = myfunc(x,y)
		Creating wrapper for Fortran function "f2"("f2")...
		Constructing wrapper function "f2"...
		  f2 = f2(x,y)
	Wrote C/API module "ext_gridloop" to file "tmp1/ext_gridloopmodule.c"
	Fortran 77 wrappers are saved to "tmp1/ext_gridloop-f2pywrappers.f"
running build_flib
running build_ext
building 'ext_gridloop' extension
creating tmp1/home
creating tmp1/home/hpl
creating tmp1/home/hpl/install
creating tmp1/home/hpl/install/lib
creating tmp1/home/hpl/install/lib/python
creating tmp1/home/hpl/install/lib/python/f2py2e
creating tmp1/home/hpl/install/lib/python/f2py2e/src
creating tmp1/tmp1
gcc -pthread -fno-strict-aliasing -DNDEBUG -g -O3 -Wall -Wstrict-prototypes -fPIC -DF2PY_REPORT_ON_ARRAY_COPY=1 -I/home/hpl/install/lib/python/f2py2e/src -I/usr/include/python2.3 -c /home/hpl/install/lib/python/f2py2e/src/fortranobject.c -o tmp1/home/hpl/install/lib/python/f2py2e/src/fortranobject.o
gcc -pthread -fno-strict-aliasing -DNDEBUG -g -O3 -Wall -Wstrict-prototypes -fPIC -DF2PY_REPORT_ON_ARRAY_COPY=1 -I/home/hpl/install/lib/python/f2py2e/src -I/usr/include/python2.3 -c tmp1/ext_gridloopmodule.c -o tmp1/tmp1/ext_gridloopmodule.o
g77 -shared tmp1/home/hpl/install/lib/python/f2py2e/src/fortranobject.o tmp1/tmp1/ext_gridloopmodule.o -Ltmp1 -lext_gridloop_f2py -lg2c-pic -o ./ext_gridloop.so
['__doc__', '__file__', '__name__', '__version__', 'as_column_major_storage', 'change', 'dump', 'f2', 'gridloop1', 'gridloop1_v1', 'gridloop1_v2', 'gridloop1_v3', 'gridloop1_v4', 'gridloop1_v5', 'gridloop2', 'gridloop2_fixedfunc1', 'gridloop2_str', 'gridloop3', 'gridloop4', 'gridloop_vec', 'gridloop_vec2', 'has_column_major_storage', 'myfunc', 'transpose2dim']
This module 'ext_gridloop' is auto-generated with f2py (version:2.39.235_1649).
Functions:
  gridloop1(a,xcoor,ycoor,func1,nx=len(xcoor),ny=len(ycoor),func1_extra_args=())
  a = gridloop2(xcoor,ycoor,func1,nx=len(xcoor),ny=len(ycoor),func1_extra_args=())
  a = gridloop3(a,xcoor,ycoor,func1,nx=shape(a,0),ny=shape(a,1),func1_extra_args=())
  a = gridloop4(a,xcoor,ycoor,func1,nx=shape(a,0),ny=shape(a,1),overwrite_a=1,func1_extra_args=())
  a = gridloop_vec(a,xcoor,ycoor,func1,nx=shape(a,0),ny=shape(a,1),func1_extra_args=())
  a = gridloop_vec2(a,func1,nx=shape(a,0),ny=shape(a,1),func1_extra_args=())
  a = gridloop2_str(xcoor,ycoor,func_str,nx=len(xcoor),ny=len(ycoor))
  gridloop1_v1(a,xcoor,ycoor,func1,nx=shape(a,0),ny=shape(a,1),func1_extra_args=())
  a = gridloop1_v2(xcoor,ycoor,func1,nx=len(xcoor),ny=len(ycoor),func1_extra_args=())
  gridloop1_v3(a,xcoor,ycoor,func1,nx=shape(a,0),ny=shape(a,1),func1_extra_args=())
  gridloop1_v4(a,xcoor,ycoor,func1,nx=shape(a,0),ny=shape(a,1),func1_extra_args=())
  gridloop1_v5(a,xcoor,ycoor,func1,nx=shape(a,0),ny=shape(a,1),func1_extra_args=())
  transpose2dim(a,at,nx=shape(a,0),ny=shape(a,1))
  dump(a,xcoor,ycoor,nx=shape(a,0),ny=shape(a,1))
  change(a,xcoor,ycoor,nx=shape(a,0),ny=shape(a,1))
  a = gridloop2_fixedfunc1(xcoor,ycoor,nx=len(xcoor),ny=len(ycoor))
  myfunc = myfunc(x,y)
  f2 = f2(x,y)
.
CPU time of ./make_module_1.sh: 9.1 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running ../Grid2Deff.py verify1
x+2*y = [[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
x+2*y = 0.0
x+2*y = 0.5
x+2*y = 1.0
x+2*y = 2.0
x+2*y = 2.5
x+2*y = 3.0
f computed by external gridloop1 function:
[[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
f is correct
x+2*y = 0.0
x+2*y = 0.5
x+2*y = 1.0
x+2*y = 2.0
x+2*y = 2.5
x+2*y = 3.0
f computed by external gridloop2 function:
[[ 0.   2. ]
 [ 0.5  2.5]
 [ 1.   3. ]]
f is correct
array seen from Python:
value at (0,0)  	 = a[0,0] = 0
value at (0,1)  	 = a[0,1] = 2
value at (0.5,0)  	 = a[1,0] = 0.5
value at (0.5,1)  	 = a[1,1] = 2.5
value at (1,0)  	 = a[2,0] = 1
value at (1,1)  	 = a[2,1] = 3
array seen from Fortran (transposed, but right values):
value at ( 0.000, 0.000) = a(  0,  0) =  0.00000E+00
value at ( 0.500, 0.000) = a(  1,  0) =  0.50000E+00
value at ( 1.000, 0.000) = a(  2,  0) =  0.10000E+01
value at ( 0.000, 1.000) = a(  0,  1) =  0.20000E+01
value at ( 0.500, 1.000) = a(  1,  1) =  0.25000E+01
value at ( 1.000, 1.000) = a(  2,  1) =  0.30000E+01
CPU time of ../Grid2Deff.py: 0.3 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running ../Grid2Deff.py verify2
running build
running run_f2py
creating tmp2
Reading fortran codes...
	Reading file '_cb.f'
Post-processing...
	Block: callback
			Block: fcb
			Block: gridloop2_fcb
Saving signatures to file "./tmp2/callback.pyf"
Reading fortran codes...
	Reading file 'tmp2/callback.pyf'
Post-processing...
	Block: callback
			Block: fcb
			Block: gridloop2_fcb
Building modules...
	Building module "callback"...
		Creating wrapper for Fortran function "fcb"("fcb")...
		Constructing wrapper function "fcb"...
		  fcb = fcb(x,y)
		Constructing wrapper function "gridloop2_fcb"...
		  a = gridloop2_fcb(xcoor,ycoor,[nx,ny])
	Wrote C/API module "callback" to file "tmp2/callbackmodule.c"
	Fortran 77 wrappers are saved to "tmp2/callback-f2pywrappers.f"
running build_flib
running build_ext
building 'callback' extension
creating tmp2/home
creating tmp2/home/hpl
creating tmp2/home/hpl/install
creating tmp2/home/hpl/install/lib
creating tmp2/home/hpl/install/lib/python
creating tmp2/home/hpl/install/lib/python/f2py2e
creating tmp2/home/hpl/install/lib/python/f2py2e/src
creating tmp2/tmp2
gcc -pthread -fno-strict-aliasing -DNDEBUG -g -O3 -Wall -Wstrict-prototypes -fPIC -DF2PY_REPORT_ON_ARRAY_COPY=1 -I/home/hpl/install/lib/python/f2py2e/src -I/usr/include/python2.3 -c tmp2/callbackmodule.c -o tmp2/tmp2/callbackmodule.o
gcc -pthread -fno-strict-aliasing -DNDEBUG -g -O3 -Wall -Wstrict-prototypes -fPIC -DF2PY_REPORT_ON_ARRAY_COPY=1 -I/home/hpl/install/lib/python/f2py2e/src -I/usr/include/python2.3 -c /home/hpl/install/lib/python/f2py2e/src/fortranobject.c -o tmp2/home/hpl/install/lib/python/f2py2e/src/fortranobject.o
g77 -shared tmp2/home/hpl/install/lib/python/f2py2e/src/fortranobject.o tmp2/tmp2/callbackmodule.o ./ext_gridloop.so -Ltmp2 -lcallback_f2py -lg2c-pic -o ./callback.so
running build
running run_f2py
Reading fortran codes...
	Reading file '_cb.f'
Post-processing...
	Block: ext_gridloop2
			Block: gridloop2
Saving signatures to file "./tmp1/ext_gridloop2.pyf"
Reading fortran codes...
	Reading file 'tmp1/ext_gridloop2.pyf'
Post-processing...
	Block: ext_gridloop2
			Block: gridloop2
Building modules...
	Building module "ext_gridloop2"...
		Constructing wrapper function "gridloop2"...
		  a = gridloop2(xcoor,ycoor,[nx,ny])
	Wrote C/API module "ext_gridloop2" to file "tmp1/ext_gridloop2module.c"
running build_flib
running build_ext
building 'ext_gridloop2' extension
gcc -pthread -fno-strict-aliasing -DNDEBUG -g -O3 -Wall -Wstrict-prototypes -fPIC -DF2PY_REPORT_ON_ARRAY_COPY=1 -I/home/hpl/install/lib/python/f2py2e/src -I/usr/include/python2.3 -c tmp1/ext_gridloop2module.c -o tmp1/tmp1/ext_gridloop2module.o
g77 -shared tmp1/home/hpl/install/lib/python/f2py2e/src/fortranobject.o tmp1/tmp1/ext_gridloop2module.o -Ltmp1 -lext_gridloop2_f2py -lg2c-pic -o ./ext_gridloop2.so
myfuncf77, a= [[ 0.          0.          0.          0.        ]
 [ 2.66666667  2.7775493   2.88706441  2.99386136]
 [ 5.33333333  5.55373108  5.7632897   5.95170314]
 [ 8.          8.3271947   8.6183698   8.84147098]]
g.ext_gridloop_vec(myfuncf77): a=
[[ 0.          0.          0.          0.        ]
 [ 2.66666667  2.7775493   2.88706441  2.99386136]
 [ 5.33333333  5.55373108  5.7632897   5.95170314]
 [ 8.          8.3271947   8.6183698   8.84147098]]
g.ext_gridloop_vec2(myfuncf772): a=
[[ 0.          0.          0.          0.        ]
 [ 2.66666667  2.7775493   2.88706441  2.99386136]
 [ 5.33333333  5.55373108  5.7632897   5.95170314]
 [ 8.          8.3271947   8.6183698   8.84147098]]
 in f2  0.
 in f2  0.333333333
 in f2  0.666666667
 in f2  1.
 in f2  0.666666667
 in f2  1.
 in f2  1.33333333
 in f2  1.66666667
 in f2  1.33333333
 in f2  1.66666667
 in f2  2.
 in f2  2.33333333
 in f2  2.
 in f2  2.33333333
 in f2  2.66666667
 in f2  3.
g.ext_gridloop2_str('f2'): a=
[[ 0.          0.66666667  1.33333333  2.        ]
 [ 0.33333333  1.          1.66666667  2.33333333]
 [ 0.66666667  1.33333333  2.          2.66666667]
 [ 1.          1.66666667  2.33333333  3.        ]]
g.ext_gridloop_str('myfunc'): a=
[[ 0.          0.          0.          0.        ]
 [ 2.66666667  2.7775493   2.88706441  2.99386136]
 [ 5.33333333  5.55373108  5.7632897   5.95170314]
 [ 8.          8.3271947   8.6183698   8.84147098]]
g.gridloop2_fcb: a=
[[ 0.          0.          0.          0.        ]
 [ 2.66666667  2.7775493   2.88706441  2.99386136]
 [ 5.33333333  5.55373108  5.7632897   5.95170314]
 [ 8.          8.3271947   8.6183698   8.84147098]]
contents of callback module: ['__doc__', '__file__', '__name__', '__version__', 'as_column_major_storage', 'fcb', 'gridloop2_fcb', 'has_column_major_storage']
g.gridloop2_v2: a=
[[ 0.          0.          0.          0.        ]
 [ 2.66666667  2.7775493   2.88706441  2.99386136]
 [ 5.33333333  5.55373108  5.7632897   5.95170314]
 [ 8.          8.3271947   8.6183698   8.84147098]]
CPU time of ../Grid2Deff.py: 4.1 seconds on hplx30 i686, Linux

#### Test: ./tests.verify running ../Grid2Deff.py exceptions1
ext_gridloop.error failed in converting 1st argument `a' of ext_gridloop.gridloop1 to C/Fortran array
exceptions.TypeError ext_gridloop.gridloop2() argument 3 must be function, not str
exceptions.TypeError ext_gridloop.gridloop2() argument 3 must be function, not str
exceptions.TypeError ext_gridloop.gridloop2() argument 3 must be function, not str
CPU time of ../Grid2Deff.py: 0.3 seconds on hplx30 i686, Linux

----- appending file tmp1/ext_gridloop.pyf ------
!    -*- f90 -*-
python module gridloop1__user__routines
    interface gridloop1_user_interface
        function func1(x,y) ! in :ext_gridloop:gridloop.f:gridloop1:unknown_interface
            real*8 :: x
            real*8 :: y
            real*8 :: func1
        end function func1
    end interface gridloop1_user_interface
end python module gridloop1__user__routines
python module gridloop2__user__routines
    interface gridloop2_user_interface
        function func1(x,y) ! in :ext_gridloop:gridloop.f:gridloop2:unknown_interface
            real*8 :: x
            real*8 :: y
            real*8 :: func1
        end function func1
    end interface gridloop2_user_interface
end python module gridloop2__user__routines
python module gridloop3__user__routines
    interface gridloop3_user_interface
        function func1(x,y) ! in :ext_gridloop:gridloop.f:gridloop3:unknown_interface
            real*8 :: x
            real*8 :: y
            real*8 :: func1
        end function func1
    end interface gridloop3_user_interface
end python module gridloop3__user__routines
python module gridloop4__user__routines
    interface gridloop4_user_interface
        function func1(x,y) ! in :ext_gridloop:gridloop.f:gridloop4:unknown_interface
            real*8 :: x
            real*8 :: y
            real*8 :: func1
        end function func1
    end interface gridloop4_user_interface
end python module gridloop4__user__routines
python module gridloop_vec__user__routines
    interface gridloop_vec_user_interface
        subroutine func1(a,xcoor,ycoor,nx,ny) ! in :ext_gridloop:gridloop.f:gridloop_vec:unknown_interface
            real*8 dimension(nx,ny),intent(in,out) :: a
            real*8 dimension(nx),intent(in),depend(nx) :: xcoor
            real*8 dimension(ny),intent(in),depend(ny) :: ycoor
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
        end subroutine func1
    end interface gridloop_vec_user_interface
end python module gridloop_vec__user__routines
python module gridloop_vec2__user__routines
    interface gridloop_vec2_user_interface
        subroutine func1(a,nx,ny) ! in :ext_gridloop:gridloop.f:gridloop_vec2:unknown_interface
            real*8 dimension(nx,ny),intent(in,out) :: a
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
        end subroutine func1
    end interface gridloop_vec2_user_interface
end python module gridloop_vec2__user__routines
python module gridloop1_v1__user__routines
    interface gridloop1_v1_user_interface
        function func1(x,y) ! in :ext_gridloop:gridloop.f:gridloop1_v1:unknown_interface
            real*8 :: x
            real*8 :: y
            real*8 :: func1
        end function func1
    end interface gridloop1_v1_user_interface
end python module gridloop1_v1__user__routines
python module gridloop1_v2__user__routines
    interface gridloop1_v2_user_interface
        function func1(x,y) ! in :ext_gridloop:gridloop.f:gridloop1_v2:unknown_interface
            real*8 :: x
            real*8 :: y
            real*8 :: func1
        end function func1
    end interface gridloop1_v2_user_interface
end python module gridloop1_v2__user__routines
python module gridloop1_v3__user__routines
    interface gridloop1_v3_user_interface
        function func1(x,y) ! in :ext_gridloop:gridloop.f:gridloop1_v3:unknown_interface
            real*8 :: x
            real*8 :: y
            real*8 :: func1
        end function func1
    end interface gridloop1_v3_user_interface
end python module gridloop1_v3__user__routines
python module gridloop1_v4__user__routines
    interface gridloop1_v4_user_interface
        function func1(x,y) ! in :ext_gridloop:gridloop.f:gridloop1_v4:unknown_interface
            real*8 :: x
            real*8 :: y
            real*8 :: func1
        end function func1
    end interface gridloop1_v4_user_interface
end python module gridloop1_v4__user__routines
python module gridloop1_v5__user__routines
    interface gridloop1_v5_user_interface
        function func1(x,y) ! in :ext_gridloop:gridloop.f:gridloop1_v5:unknown_interface
            real*8 :: x
            real*8 :: y
            real*8 :: func1
        end function func1
    end interface gridloop1_v5_user_interface
end python module gridloop1_v5__user__routines
python module ext_gridloop ! in
    interface  ! in :ext_gridloop
        subroutine gridloop1(a,xcoor,ycoor,nx,ny,func1) ! in :ext_gridloop:gridloop.f
            use gridloop1__user__routines
            real*8 dimension(nx,ny),intent(inout),depend(nx,ny) :: a
            real*8 dimension(nx),intent(in) :: xcoor
            real*8 dimension(ny),intent(in) :: ycoor
            integer optional,check(len(xcoor)>=nx),depend(xcoor) :: nx=len(xcoor)
            integer optional,check(len(ycoor)>=ny),depend(ycoor) :: ny=len(ycoor)
            external func1
        end subroutine gridloop1
        subroutine gridloop2(a,xcoor,ycoor,nx,ny,func1) ! in :ext_gridloop:gridloop.f
            use gridloop2__user__routines
            real*8 dimension(nx,ny),intent(out),depend(nx,ny) :: a
            real*8 dimension(nx),intent(in) :: xcoor
            real*8 dimension(ny),intent(in) :: ycoor
            integer optional,check(len(xcoor)>=nx),depend(xcoor) :: nx=len(xcoor)
            integer optional,check(len(ycoor)>=ny),depend(ycoor) :: ny=len(ycoor)
            external func1
        end subroutine gridloop2
        subroutine gridloop3(a,xcoor,ycoor,nx,ny,func1) ! in :ext_gridloop:gridloop.f
            use gridloop3__user__routines
            real*8 dimension(nx,ny),intent(in,out) :: a
            real*8 dimension(nx),intent(in),depend(nx) :: xcoor
            real*8 dimension(ny),intent(in),depend(ny) :: ycoor
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
            external func1
        end subroutine gridloop3
        subroutine gridloop4(a,xcoor,ycoor,nx,ny,func1) ! in :ext_gridloop:gridloop.f
            use gridloop4__user__routines
            real*8 dimension(nx,ny),intent(in,out,overwrite) :: a
            real*8 dimension(nx),intent(in),depend(nx) :: xcoor
            real*8 dimension(ny),intent(in),depend(ny) :: ycoor
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
            external func1
        end subroutine gridloop4
        subroutine gridloop_vec(a,xcoor,ycoor,nx,ny,func1) ! in :ext_gridloop:gridloop.f
            use gridloop_vec__user__routines
            real*8 dimension(nx,ny),intent(in,out) :: a
            real*8 dimension(nx),intent(in),depend(nx) :: xcoor
            real*8 dimension(ny),intent(in),depend(ny) :: ycoor
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
            external func1
        end subroutine gridloop_vec
        subroutine gridloop_vec2(a,nx,ny,func1) ! in :ext_gridloop:gridloop.f
            use gridloop_vec2__user__routines
            real*8 dimension(nx,ny),intent(in,out) :: a
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
            external func1
        end subroutine gridloop_vec2
        subroutine gridloop2_str(a,xcoor,ycoor,nx,ny,func_str) ! in :ext_gridloop:gridloop.f
            real*8 dimension(nx,ny),intent(out),depend(nx,ny) :: a
            real*8 dimension(nx),intent(in) :: xcoor
            real*8 dimension(ny),intent(in) :: ycoor
            integer optional,check(len(xcoor)>=nx),depend(xcoor) :: nx=len(xcoor)
            integer optional,check(len(ycoor)>=ny),depend(ycoor) :: ny=len(ycoor)
            character*(*) :: func_str
        end subroutine gridloop2_str
        subroutine gridloop1_v1(a,xcoor,ycoor,nx,ny,func1) ! in :ext_gridloop:gridloop.f
            use gridloop1_v1__user__routines
            real*8 dimension(nx,ny) :: a
            real*8 dimension(nx),depend(nx) :: xcoor
            real*8 dimension(ny),depend(ny) :: ycoor
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
            external func1
        end subroutine gridloop1_v1
        subroutine gridloop1_v2(a,xcoor,ycoor,nx,ny,func1) ! in :ext_gridloop:gridloop.f
            use gridloop1_v2__user__routines
            real*8 dimension(nx,ny),intent(out),depend(nx,ny) :: a
            real*8 dimension(nx),intent(in) :: xcoor
            real*8 dimension(ny),intent(in) :: ycoor
            integer optional,check(len(xcoor)>=nx),depend(xcoor) :: nx=len(xcoor)
            integer optional,check(len(ycoor)>=ny),depend(ycoor) :: ny=len(ycoor)
            external func1
        end subroutine gridloop1_v2
        subroutine gridloop1_v3(a,xcoor,ycoor,nx,ny,func1) ! in :ext_gridloop:gridloop.f
            use gridloop1_v3__user__routines
            real*8 dimension(nx,ny),intent(inout) :: a
            real*8 dimension(nx),depend(nx) :: xcoor
            real*8 dimension(ny),depend(ny) :: ycoor
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
            external func1
        end subroutine gridloop1_v3
        subroutine gridloop1_v4(a,xcoor,ycoor,nx,ny,func1) ! in :ext_gridloop:gridloop.f
            use gridloop1_v4__user__routines
            real*8 dimension(nx,ny),intent(inout,c) :: a
            real*8 dimension(nx),depend(nx) :: xcoor
            real*8 dimension(ny),depend(ny) :: ycoor
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
            external func1
        end subroutine gridloop1_v4
        subroutine gridloop1_v5(a,xcoor,ycoor,nx,ny,func1,at) ! in :ext_gridloop:gridloop.f
            use gridloop1_v5__user__routines
            real*8 dimension(nx,ny),intent(inout,c) :: a
            real*8 dimension(nx),depend(nx) :: xcoor
            real*8 dimension(ny),depend(ny) :: ycoor
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
            external func1
            real*8 dimension(nx,ny),intent(in,hide),depend(nx,ny) :: at
        end subroutine gridloop1_v5
        subroutine transpose2dim(a,at,nx,ny) ! in :ext_gridloop:gridloop.f
            real*8 dimension(nx,ny) :: a
            real*8 dimension(ny,nx),depend(ny,nx) :: at
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
        end subroutine transpose2dim
        subroutine dump(a,xcoor,ycoor,nx,ny) ! in :ext_gridloop:gridloop.f
            real*8 dimension(nx,ny) :: a
            real*8 dimension(nx),depend(nx) :: xcoor
            real*8 dimension(ny),depend(ny) :: ycoor
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
        end subroutine dump
        subroutine change(a,xcoor,ycoor,nx,ny) ! in :ext_gridloop:gridloop.f
            real*8 dimension(nx,ny) :: a
            real*8 dimension(nx),depend(nx) :: xcoor
            real*8 dimension(ny),depend(ny) :: ycoor
            integer optional,check(shape(a,0)==nx),depend(a) :: nx=shape(a,0)
            integer optional,check(shape(a,1)==ny),depend(a) :: ny=shape(a,1)
        end subroutine change
        subroutine gridloop2_fixedfunc1(a,xcoor,ycoor,nx,ny) ! in :ext_gridloop:gridloop.f
            real*8 dimension(nx,ny),intent(out),depend(nx,ny) :: a
            real*8 dimension(nx),intent(in) :: xcoor
            real*8 dimension(ny),intent(in) :: ycoor
            integer optional,check(len(xcoor)>=nx),depend(xcoor) :: nx=len(xcoor)
            integer optional,check(len(ycoor)>=ny),depend(ycoor) :: ny=len(ycoor)
        end subroutine gridloop2_fixedfunc1
        function myfunc(x,y) ! in :ext_gridloop:gridloop.f
            real*8 :: x
            real*8 :: y
            real*8 :: myfunc
        end function myfunc
        function f2(x,y) ! in :ext_gridloop:gridloop.f
            real*8 :: x
            real*8 :: y
            real*8 :: f2
        end function f2
    end interface
end python module ext_gridloop

! This file was auto-generated with f2py (version:2.39.235_1649).
! See http://cens.ioc.ee/projects/f2py2e/


library(stringr)
library(dplyr)
library(ggplot2)
library(tidyr)

tran_care <- read.csv("Trans-Care-by-state-aggragate.csv",stringsAsFactors = FALSE)
#2020,12,31
#2019,12,31
#2018,12,31
#2017,12,31
#2016-12-31
#2015-12-31
twenty_15_data <- tran_care %>%
                          filter(Date == "2015-12-30")

twenty_16_data <- tran_care %>%
  filter(Date == "2016-12-30")

twenty_17_data <- tran_care %>%
  filter(Date == "2017-12-30")

twenty_18_data <- tran_care %>%
  filter(Date == "2018-12-30")

twenty_19_data <- tran_care %>%
  filter(Date == "2019-12-30")

twenty_20_data <- tran_care %>%
  filter(Date == "2020-12-30")
#example 2020 data frame to plot
long_data_set <- pivot_longer(twenty_15_data,cols = -Date)
long_data_set <- long_data_set_20 %>%
                    select(name,value)

ggplot(long_data_set,aes(x = name, y = value)) +
  geom_segment(aes(x = name, xend = name,y = 0, yend = value, color = name)) +
  geom_point() +
  labs (
    color = "States"
  )


#!/usr/bin/env Rscript

# Command line argument processing
args <- commandArgs(trailingOnly=TRUE)

# R location
rlocation <- NULL
if(substr(args[1], 0, 10) == 'rlocation='){
    rlocation <- substr(args[1], 11, nchar(args[1]))
    args <- args[-1]
}

if (length(args) < 3) {
  stop("Usage: edgeR_heatmap_MDS.r <sample_1.bam> <sample_2.bam> <sample_3.bam> (more bam files optional)", call.=FALSE)
}

# Load / install required packages
if (!is.null(rlocation)) {
  .libPaths( c( rlocation, .libPaths() ) )
}
if (!require("limma")){
    source("http://bioconductor.org/biocLite.R")
    biocLite("limma", suppressUpdates=TRUE)
    library("limma")
}
if (!require("edgeR")){
    source("http://bioconductor.org/biocLite.R")
    biocLite("edgeR", suppressUpdates=TRUE)
    library("edgeR")
}
if (!require("data.table")){
    install.packages("data.table", dependencies=TRUE, repos='http://cloud.r-project.org/')
    library("data.table")
}
if (!require("gplots")) {
    install.packages("gplots", dependencies=TRUE, repos='http://cloud.r-project.org/')
    library("gplots")
}

# Load count column from all files into a list of data frames
# Use data.tables fread as much much faster than read.table
# Row names are GeneIDs
temp <- lapply(args, fread, skip="Geneid", header=TRUE, colClasses=c(NA, rep("NULL", 5), NA))

# Merge into a single data frame
merge.all <- function(x, y) {
    merge(x, y, all=TRUE, by="Geneid")
}
data <- data.frame(Reduce(merge.all, temp))

# Clean sample name headers
colnames(data) <- gsub("Aligned.sortedByCoord.out.bam", "", colnames(data))

# Set GeneID as row name
rownames(data) <- data[,1]
data[,1] <- NULL

# Convert data frame to edgeR DGE object
dataDGE <- DGEList( counts=data.matrix(data) )

# Normalise counts
dataNorm <- calcNormFactors(dataDGE)

# Make MDS plot
pdf('edgeR_MDS_plot.pdf')
MDSdata <- plotMDS(dataNorm)
dev.off()

# Print distance matrix to file
write.csv(MDSdata$distance.matrix, 'edgeR_MDS_distance_matrix.csv', quote=FALSE,append=TRUE)

# Print plot x,y co-ordinates to file
MDSxy = MDSdata$cmdscale.out
colnames(MDSxy) = c(paste(MDSdata$axislabel, '1'), paste(MDSdata$axislabel, '2'))
write.csv(MDSxy, 'edgeR_MDS_Aplot_coordinates_mqc.csv', quote=FALSE, append=TRUE)

# Get the log counts per million values
logcpm <- cpm(dataNorm, prior.count=2, log=TRUE)

# Calculate the euclidean distances between samples
dists = dist(t(logcpm))

# Plot a heatmap of correlations
pdf('log2CPM_sample_distances_heatmap.pdf')
hmap <- heatmap.2(as.matrix(dists),
  main="Sample Correlations", key.title="Distance", trace="none",
  dendrogram="row", margin=c(9, 9)
)
dev.off()

# Plot the heatmap dendrogram
pdf('log2CPM_sample_distances_dendrogram.pdf')
plot(hmap$rowDendrogram, main="Sample Dendrogram")
dev.off()

# Write clustered distance values to file
write.csv(hmap$carpet, 'log2CPM_sample_distances_mqc.csv', quote=FALSE, append=TRUE)

file.create("corr.done")

# Printing sessioninfo to standard out
print("Sample correlation info:")
sessionInfo()


#' Converts a list of character vectors to a logical matrix
#'
#' @param x      A list of character vectors
#' @param along  Which axis to spread mask on
#' @return       A logical occurrence matrix
#' @export
mask = function(x, along=2) {
    if (is.factor(x))
        x = as.character(x)

    list2logic = function(xi) stats::setNames(base::rep(TRUE, length(xi)), xi)

    vectorList = lapply(x, list2logic)
    stacked = stack(vectorList, fill=FALSE)

    if (along == 1)
        stacked
    else
        t(stacked)
}


#!/usr/bin/Rscript
#Rscript script common-path jaspar-dir id output
#example:
#Rscript pwmmatch.r /cluster/thashim/basepiq/common.r /cluster/thashim/basepiq/pwms/jaspar.txt 141 /cluster/thashim/basepiq/tmp/pwmout.RData

options(echo=TRUE)
args <- commandArgs(trailingOnly = TRUE)
print(args)

commonfile = args[1]
jaspardir = args[2]
pwmid = as.double(args[3])
outdir = args[4]

outdir=paste0(outdir,'/')
source(commonfile)
if(!overwrite & file.exists(paste0(outdir,pwmid,'.pwmout.RData'))){
  stop("pwm file already exists")
}

####
# load PWMs
####

#pwmin = 'pwms/'

importJaspar <- function(file=myloc) {
  vec <- readLines(file)
  vec <- gsub("\t"," ",vec)
  vec <- gsub("\\[|\\]", "", vec)
  start <- grep(">", vec); end <- grep(">", vec) - 1
  pos <- data.frame(start=start, end=c(end[-1], length(vec)))
  pwm <- sapply(seq(along=pos[,1]), function(x) vec[pos[x,1]:pos[x,2]])
  pwm <- sapply(seq(along=pwm), function(x) strsplit(pwm[[x]], " {1,}"))
  pwm <- lapply(seq(along=start), function(x) matrix(as.numeric(t(as.data.frame(pwm[(pos[x,1]+1):pos[x,2]]))[,-1]), nrow=4, dimnames=list(c("A", "C", "G", "T"), NULL)))
  names(pwm) <- gsub(">", "", vec[start])
  return(pwm)
}
pwmtable <- importJaspar(jaspardir)

pwmnum = pwmid
pwmin = pwmtable[[pwmnum]] + 1e-20
pwmname = names(pwmtable)[pwmnum]

####
# end input script
# assert: existence of pwmin and pwmname
####

####
# motif match

pwmnorm=t(t(pwmin)/colSums(pwmin))
#informbase=colSums((log(pwmnorm+0.01)-log(1/4))*pwmnorm) #
#pwmnorm = pwmnorm[,(informbase > basecut)]
ipr=log(pwmnorm)-log(1/4)

#chr names
chrstr = seqnames(genome)

if(exists('blacklist') & !is.null(blacklist)){
    blacktable=read.table(blacklist)
}

if(exists('whitelist') & !is.null(whitelist)){
    whitetable=read.table(whitelist)
}

#####
# fw motif match

pwuse = ipr

coords.list = lapply(chrstr,function(i){
    print(i)
    gi=genome[[i]]
    if(remove.repeatmask & !is.null(masks(gi))){
        active(masks(gi)) <- rep(T,length(masks(gi)))
    }
    if(exists('blacklist') & !is.null(blacklist)){
        blacksel= blacktable[,1]==i
        if(sum(blacksel)>0){
            flsize = wsize*flank.blacklist
            ir=intersect(IRanges(1,length(gi)),reduce(IRanges(blacktable[blacksel,2]-flsize,blacktable[blacksel,3]+flsize)))
            mask=Mask(length(gi),start(ir),end(ir))
            if(is.null(masks(gi)))
                masks(gi) = mask
            else
                masks(gi) = append(masks(gi),mask)
        }
    }
    if(exists('whitetable')){
        whitesel=whitetable[,1]==i
        if(sum(whitesel)>0){
            wchr=whitetable[whitesel,,drop=F]
            ir=IRanges(wchr[,2],wchr[,3])
            air=IRanges(1,length(gi))
            nir=setdiff(air,ir)
            rir=reduce(IRanges(start(nir)-wsize,end(nir)+wsize))
            maskr=intersect(rir,air)
            mask = Mask(length(gi),start(maskr),end(maskr))
            if(is.null(masks(gi)))
                masks(gi) = mask
            else
                masks(gi) = append(masks(gi),mask)
        }else{
            mask = Mask(length(gi),1,length(gi))
            if(is.null(masks(gi)))
                masks(gi) = mask
            else
                masks(gi) = append(masks(gi),mask)
        }
    }
    mpwm=matchPWM(pwuse,gi,min.score=motifcut)
    pscore=PWMscoreStartingAt(pwuse,as(gi,"DNAString"),start(mpwm))
    list(mpwm,pscore)
})

if(sum(sapply(coords.list,function(i){length(i[[2]])}))>0){

allpwm=do.call(c,lapply(coords.list,function(i){i[[2]]}))
pwmcut2=sort(allpwm,decreasing=T)[min(length(allpwm),maxcand)]
rm(allpwm)
print(pwmcut2)

coords=lapply(1:length(coords.list),function(i){
    as(coords.list[[i]][[1]],'IRanges')[coords.list[[i]][[2]] >= pwmcut2]
})

coords.pwm=lapply(coords.list,function(i){i[[2]][i[[2]] >= pwmcut2]})

#coords=lapply(coords.list,unlist)

clengths=sapply(coords,length)
print(sum(clengths))
coords.short=coords[clengths>0]
names(coords.short)=chrstr[clengths>0]
ncoords=chrstr[clengths>0]#names(coords)
coords2=sapply(coords.short,flank,width=wsize,both=T)

save(coords,coords.pwm,ipr,pwmin,pwmname,chrstr,clengths,coords.short,ncoords,coords2,file=paste0(outdir,pwmid,'.pwmout.RData'))

}else{
clengths=0
save(clengths,file=paste0(outdir,pwmid,'.pwmout.RData'))
}

#
#####

#####
# RC motif match

pwuse = reverseComplement(ipr)

coords.list = lapply(chrstr,function(i){
    print(i)
    gi=genome[[i]]
    if(remove.repeatmask & !is.null(masks(gi))){
        active(masks(gi)) <- rep(T,length(masks(gi)))
    }
    if(exists('blacklist') & !is.null(blacklist)){
        blacksel= blacktable[,1]==i
        if(sum(blacksel)>0){
            flsize = wsize*flank.blacklist
            ir=intersect(IRanges(1,length(gi)),reduce(IRanges(blacktable[blacksel,2]-flsize,blacktable[blacksel,3]+flsize)))
            mask=Mask(length(gi),start(ir),end(ir))
            if(is.null(masks(gi)))
                masks(gi) = mask
            else
                masks(gi) = append(masks(gi),mask)
        }
    }
    if(exists('whitetable')){
        whitesel=whitetable[,1]==i
        if(sum(whitesel)>0){
            wchr=whitetable[whitesel,,drop=F]
            ir=IRanges(wchr[,2],wchr[,3])
            air=IRanges(1,length(gi))
            nir=setdiff(air,ir)
            rir=reduce(IRanges(start(nir)-wsize,end(nir)+wsize))
            maskr=intersect(rir,air)
            mask = Mask(length(gi),start(maskr),end(maskr))
            if(is.null(masks(gi)))
                masks(gi) = mask
            else
                masks(gi) = append(masks(gi),mask)
        }else{
            mask = Mask(length(gi),1,length(gi))
            if(is.null(masks(gi)))
                masks(gi) = mask
            else
                masks(gi) = append(masks(gi),mask)
        }
    }
    mpwm=matchPWM(pwuse,gi,min.score=motifcut)
    pscore=PWMscoreStartingAt(pwuse,as(gi,"DNAString"),start(mpwm))
    list(mpwm,pscore)
})

if(sum(sapply(coords.list,function(i){length(i[[2]])}))>0){

allpwm=do.call(c,lapply(coords.list,function(i){i[[2]]}))
pwmcut2=sort(allpwm,decreasing=T)[min(length(allpwm),maxcand)]
rm(allpwm)
print(pwmcut2)

coords=lapply(1:length(coords.list),function(i){
    as(coords.list[[i]][[1]],'IRanges')[coords.list[[i]][[2]] >= pwmcut2]
})

coords.pwm=lapply(coords.list,function(i){i[[2]][i[[2]] >= pwmcut2]})

#coords=lapply(coords.list,unlist)

clengths=sapply(coords,length)
print(sum(clengths))
coords.short=coords[clengths>0]
names(coords.short)=chrstr[clengths>0]
ncoords=chrstr[clengths>0]#names(coords)
coords2=sapply(coords.short,flank,width=wsize,both=T)

save(coords,coords.pwm,ipr,pwmin,pwmname,chrstr,clengths,coords.short,ncoords,coords2,file=paste0(outdir,pwmid,'.pwmout.rc.RData'))

}else{
clengths=0
save(clengths,file=paste0(outdir,pwmid,'.pwmout.rc.RData'))
}


# Formatting the 2011 Diallel phenotype data
# Jinliang Yang
# Jan 17th, 2012
# KC, TKW and AKW

#setwd("/Users/yangjl/Documents/workingSpace/pheno2011/codes")

setwd("/Users/yangjl/Documents/Heterosis_GWAS/pheno2011")

#############################################################
# Check the data completeness and correct the notes
#Notes:
#Dairy 8651-9000 v
#Zumwalt 9251-9600 v
#Johnson J2601-J2950 v
#Ki11: kill@ => Ki11 v
#Ms71: MS71 => Ms71 v

file1 <- read.csv("LL_KN_AKW_test.csv")
dim(file1)
#[1] 8286   11 ||||| #8678 8

diallel <- subset(file1, Note.y=="Diallel" | Note.y=="NAM Filler"| Note.y=="B73");
dim(diallel)
#[1] 3204   11 | [1] 2850    8
summary(diallel)

###########################################################
### Delete duplicated input and missing data
# Get ride of three duplicated records
barcode <- diallel[duplicated(diallel$Barcode),]$Barcode
diallel[diallel$Barcode %in% barcode,]
diallel <- diallel[!duplicated(diallel$Barcode),]
dim(diallel)
#[1] 3200   11
# Get ride of recodes with note.x nad KC<5
diallel <- subset(diallel, Note.x=="" & KC >= 50)
#diallel[is.na(diallel$TKW),]
#diallel <- diallel[!is.na(diallel$KRN),]
##########################################################
### checking for outlyers
diallel$KC <- as.numeric(as.character(diallel$KC));
hist(diallel$AKW)
hist(diallel$KC, xlim=c(0, 1000))
hist(diallel$TKW)

#######################################################
### get the LSmean
library(nlme)

#fit the model (it takes a while to run in R)
lmeout1 <- lme(KC~Genotype, data=diallel, random=~1|Farm);
lmeout2 <- lme(TKW~Genotype, data=diallel, random=~1|Farm);
lmeout3 <- lme(AKW~Genotype, data=diallel, random=~1|Farm);

#extract the estimates of coefficents, which are the lsmeans
ped.hat1 <- lmeout1$coef$fixed
ped.hat2 <- lmeout2$coef$fixed
ped.hat3 <- lmeout3$coef$fixed

#reparameterize the estimates to be more interpretable
ped.hat1[-1] <- ped.hat1[-1]+ped.hat1[1];
ped.hat2[-1] <- ped.hat2[-1]+ped.hat2[1];
ped.hat3[-1] <- ped.hat3[-1]+ped.hat3[1];

#rename the first estimate
head(ped.hat1)
head(diallel[order(diallel$Genotype),], 30);

names(ped.hat1)[1]="B73 x B97";
names(ped.hat2)[1]="B73 x B97";
names(ped.hat3)[1]="B73 x B97";

#get rid of the prefix "Genotype" in the levels names so that they are more readable
names(ped.hat1) <- gsub("Genotype","",names(ped.hat1));
names(ped.hat2) <- gsub("Genotype","",names(ped.hat2));
names(ped.hat3) <- gsub("Genotype","",names(ped.hat3));
#transpose the results
kc <- data.frame(Genotype=names(ped.hat1), KC=ped.hat1);
tkw <- data.frame(Genotype=names(ped.hat2), TKW=ped.hat2);
akw <- data.frame(Genotype=names(ped.hat3), AKW=ped.hat3);

############# H2 ###############################
fit1 <- aov(KC ~ Farm + Genotype, data=diallel)
#71424477/(71424477+33294773+9504759)=62.5 pval=2.2e-16 ***
fit2 <- aov(TKW ~ Farm + Genotype, data=diallel)
#10406226/(3627354+10406226+1473890)=67.1 pval=2.2e-16 ***
fit3 <- aov(AKW ~ Farm + Genotype, data=diallel)
#8.3488/(8.3488+3.8944+0.8990)=63.5 pval=2.2e-16 ***
###########################################################
### merge the trait of reciprocal F1
library(ggplot2)
########-------KC
kc$Genotype <- as.character(kc$Genotype);
kc$p1 <- NA;
kc$p2 <- NA;
for (i in 1:nrow(kc)){
  tem <- sort(unlist(strsplit(kc$Genotype[i], split=" x ")));
  kc$p1[i] <- tem[1];
  kc$p2[i] <- tem[2];
}

kc <- kc[order(kc$p1, kc$p2),]
kc$ped <- paste(kc$p1, kc$p2, sep="|")
lsmean_kc <- ddply(kc, .(ped), summarise,
                   KC=mean(KC))
dim(lsmean_kc)
#[1] 249   2

########-------TKW
tkw$Genotype <- as.character(tkw$Genotype);
tkw$p1 <- NA;
tkw$p2 <- NA;
for (i in 1:nrow(tkw)){
  tem <- sort(unlist(strsplit(tkw$Genotype[i], split=" x ")));
  tkw$p1[i] <- tem[1];
  tkw$p2[i] <- tem[2];
}

tkw <- tkw[order(tkw$p1, tkw$p2),]
tkw$ped <- paste(tkw$p1, tkw$p2, sep="|")
lsmean_tkw <- ddply(tkw, .(ped), summarise,
                   TKW=mean(TKW))
dim(lsmean_tkw)
#[1] 249   2

########-------AKW
akw$Genotype <- as.character(akw$Genotype);
akw$p1 <- NA;
akw$p2 <- NA;
for (i in 1:nrow(akw)){
  tem <- sort(unlist(strsplit(akw$Genotype[i], split=" x ")));
  akw$p1[i] <- tem[1];
  akw$p2[i] <- tem[2];
}

akw <- akw[order(akw$p1, akw$p2),]
akw$ped <- paste(akw$p1, akw$p2, sep="|")
lsmean_akw <- ddply(akw, .(ped), summarise,
                   AKW=mean(AKW))
dim(lsmean_akw)
#[1] 249   2
######################################################################
nathan <- read.csv("Nathan_p1_subset.csv")
nam <- read.table("nam_parents", header=TRUE)
p <- c("B73", as.character(nam$parent))
p <- toupper(p);
nathan$INBRED <- toupper(nathan$INBRED)

pcob <- subset(nathan, INBRED %in% p)
pcob[pcob=="."] <- NA;
pcob$X10KW_Inbred <- as.numeric(as.character(pcob$X10KW_Inbred))
pcob$TKW_Inbred <- as.numeric(as.character(pcob$TKW_Inbred))
pcob$KC_Inbred <- as.numeric(as.character(pcob$KC_Inbred))
pcobmean <- ddply(pcob, .(INBRED), summarise,
                  AKW=mean(X10KW_Inbred, na.rm=T)/10,
                  TKW=mean(TKW_Inbred, na.rm=T),
                  KC=mean(KC_Inbred, na.rm=T)
                  )
b73 <- data.frame(INBRED="B73", AKW=0.2583333 , TKW=62.85, KC=243.2903)
pcobmean <- rbind(b73, pcobmean)
########################################################
#------------------ AKW F1 and parents lsmean:
idx1 <- grep("@", lsmean_akw$ped)
f1akw <- lsmean_akw[-idx1,]

pakw <- lsmean_akw[idx1,]
pakw$ped <- gsub('@\\|NA',"", pakw$ped)

pakw$ped <- toupper(pakw$ped);
pakw2 <- merge(pakw, pcobmean[, c("INBRED", "AKW")], by.x="ped", by.y="INBRED", all=T)

cor(subset(pakw2, !is.na(AKW.x) & !is.na(AKW.y))[,2:3])
#0.50

mymean <- function(x) mean(x, na.rm=T);
pakw2$AKW <- apply(pakw2[,2:3], 1, mymean)
pakw2 <- pakw2[, c(1,4)]
names(pakw2)[1] <- "ped"

master_akw <- rbind(f1akw, pakw2)
dim(master_akw)
#[1] 254   2
#------------------ TKW F1 and parents lsmean:
idx2 <- grep("@", lsmean_tkw$ped)
f1tkw <- lsmean_tkw[-idx2,]

ptkw <- lsmean_tkw[idx2,]
ptkw$ped <- gsub('@\\|NA',"", ptkw$ped)

ptkw$ped <- toupper(ptkw$ped);
ptkw2 <- merge(ptkw, pcobmean[, c("INBRED", "TKW")], by.x="ped", by.y="INBRED", all=T)

cor(subset(ptkw2, !is.na(TKW.x) & !is.na(TKW.y))[,2:3])
#0.45

#mymean <- function(x) mean(x, na.rm=T);
#pcw2$CW <- apply(pcw2[,2:3], 1, mymean)
ptkw2 <- ptkw2[, c(1,3)]
names(ptkw2)[2] <- "TKW"

master_tkw <- rbind(f1tkw, ptkw2)

#------------------ KC F1 and parents lsmean:
idx3 <- grep("@", lsmean_kc$ped)
f1kc <- lsmean_kc[-idx3,]

pkc <- lsmean_kc[idx3,]
pkc$ped <- gsub('@\\|NA',"", pkc$ped)

pkc$ped <- toupper(pkc$ped);
pkc2 <- merge(pkc, pcobmean[, c("INBRED", "KC")], by.x="ped", by.y="INBRED", all=T)

cor(subset(pkc2, !is.na(KC.x) & !is.na(KC.y))[,2:3])
#0.61

#mymean <- function(x) mean(x, na.rm=T);
#pcd2$CD <- apply(pcd2[,2:3], 1, mymean)
pkc2 <- pkc2[, c(1,3)]
names(pkc2)[2] <- "KC"

master_kc <- rbind(f1kc, pkc2)
###########################################
#### Merge the data for output
master_kernel <- merge(master_akw, master_tkw, by="ped", all=T)
master_kernel <- merge(master_kernel, master_kc, by="ped", all=T)

write.table(master_kernel, "diallel_lsmean_kernel_020112.csv", sep=",", row.names=FALSE, quote=FALSE)
## plot and output lsmean
idx2 <- grep("\\|", master_kc$ped);
f1 <- master_kc[idx2,]
p <- master_kc[-idx2, ]
plot(density(f1$KC), main="KC of Diallel and parents", xlab="KRN", lwd=3, col="blue")
lines(density(p$KC), lwd=3, lty=2, col="red")


#############################################################
# Modelling dose - responses

library(drc)
library(mixtox)
library(bmdModeling)
library(synergyfinder)
library(multcomp)
library(bmd)

# library(BIGL)

#############################################################
# Read and graphics

library(readxl)
library(ggplot2)

#############################################################
# Setup working directory

setwd("")

#############################################################
# Setup working directory

names_end=excel_sheets("data/TOX_VIVO_CHICKEN.xls")

endlen=length(names_end)

cases_ls=list()

for ( i in 1:endlen) {

  cases_ls[[i]]=as.data.frame(read_excel("data/TOX_VIVO_CHICKEN.xls",names_end[i]))

  }

saveRDS(cases_ls,"cases_ls.rds")

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

cases_ls_liv=list()
cases_ls_mar=list()

for(  i in 1:endlen) {
  cases_ls_liv[[i]]=cases_ls[[i]][which(cases_ls[[i]]$Specie=="White Leghorn chickens"),]
  cases_ls_mar[[i]]=cases_ls[[i]][which(cases_ls[[i]]$Specie=="Marek chickens"),]
}

saveRDS(cases_ls_liv,"cases_ls_liv.rds")
saveRDS(cases_ls_mar,"cases_ls_mar.rds")

############################################################
# 'LL.3' and 'LL2.3' provide the three-parameter
#  log-logistic function where the lower limit is equal to 0. '

############################################################
old.par=par()
par(old.par)
set.seed(2)
range01 <- function(x){(x-min(x,na.rm=T))/(max(x,na.rm=T)-min(x,na.rm=T))}

############################################################
# BW  gain
# Marek

datamyc=cases_ls_mar[[1]]
dataexpand=data.frame(Bodyweight_gain=rep(datamyc$Bodyweight_gain,100)+runif(length(datamyc$Bodyweight_gain)*100,-1.5,1.5)*rep(datamyc$Bodyweight_gain.sd,100),
                      Mycotoxin=rep(datamyc$Mycotoxin,100),
                      Dose_T=rep(datamyc$Dose_T,100))

############################################################
# BW  gain
# Marek

datamyc=cases_ls_mar[[1]]
dataexpand=data.frame(Bodyweight_gain=rep(datamyc$Bodyweight_gain,100)+runif(length(datamyc$Bodyweight_gain)*100,-1.5,1.5)*rep(datamyc$Bodyweight_gain.sd,100),
                      Mycotoxin=rep(datamyc$Mycotoxin,100),
                      Dose_T=rep(datamyc$Dose_T,100))

dataexpand$response=range01(dataexpand$Bodyweight_gain)

multi.m3=drm(Bodyweight_gain~Dose_T,Mycotoxin,data=dataexpand,fct = AR.3())
#multi.s=drm(response~Dose_T,Mycotoxin,data=dataexpand,fct = LL.2())

ED(multi.m3,c(10,50), interval = "delta")

file.remove("summary_BW_gain_Marek.txt")

cat(capture.output(ED(multi.m3,c(10,50), interval = "delta")),
    file = "summary_BW_gain_Marek.txt",
    sep="\n",append = T)

cat(capture.output(summary(multi.m3)),
    file = "summary_BW_gain_Marek.txt",
    sep="\n",append = T)

png("images/BW_gain_Marek.png")

plot(multi.m3,
     col = TRUE,
     xlab = "Log Dose(mg/kg feed)",
     ylab = "BW_gain",
     main="Bodyweight_gain AF & OTA Marek chickens\n Bootstrap=Yes Model=L.3")

dev.off()

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

datamyc=cases_ls_liv[[1]]

multi.m3 <- drm(Terminal_bodyweight~Dose_T,Mycotoxin,data=datamyc,fct = MM.3())
print(summary(multi.m3))

file.remove("summary_TW_gain_Liv.txt")

cat(capture.output(ED(multi.m3,c(10,50), interval = "delta")),
    file = "summary_TW_gain_Liv.txt",
    sep="\n",append = T)

cat(capture.output(summary(multi.m3)),
    file = "summary_TW_gain_Liv.txt",
    sep="\n")

png("images/TW_gain_Liv.png")

plot(multi.m3,
     col = TRUE,
     xlab = "Log Dose(mg/kg feed)",
     ylab = "Terminal BW",
     main="Terminal BW AF & OTA  White Leghorn chickens\n Bootstrap=Not Model=MM.3")
dev.off()

########################################################################################à
# Feed conversion #Marek

datamyc=cases_ls_mar[[2]]
dataexpand=data.frame(Feed_conversion=rep(datamyc$Feed_conversion,100)+runif(length(datamyc$Feed_conversion)*100,-1.5,1.5)*rep(datamyc$Feed_conversion.sd,100),
                      Mycotoxin=rep(datamyc$Mycotoxin,100),
                      Dose_T=rep(datamyc$Dose_T,100))

multi.m3 <- drm(Feed_conversion~Dose_T,Mycotoxin,data=dataexpand,fct = AR.3())

print(summary(multi.m3))

file.remove("summary_Feed_conversion_mar.txt")

cat(capture.output(ED(multi.m3,c(10,50), interval = "delta")),
    file = "summary_Feed_conversion_mar.txt",
    sep="\n",append = T)

cat(capture.output(summary(multi.m3)),
    file = "summary_Feed_conversion_mar.txt",
    sep="\n")

png("images/Feed_conversion_mar.png")

plot(multi.m3,
     col = TRUE,
     xlab = "Log Dose(mg/kg feed)",
     ylab = "Feed_conversion",
     main="Feed_conversion AF & OTA  Marek chickens\n Bootstrap=Yes Model=AR.3",
     legendPos = c(0.4, 2.8))

dev.off()

#########################################################################################
# Feed intake #Marek

datamyc=cases_ls_mar[[3]]
multi.m3 <- drm(Feed_intake~Dose_T,Mycotoxin,data=datamyc,fct = AR.3())
print(summary(multi.m3))

png("images/Feed_intake_mar_bootno.png")

plot(multi.m3,
     col = TRUE,
     xlab = "Log Dose(mg/kg feed)",
     ylab = "Feed_intake",
     main="Feed_intake AF & OTA Marek chickens\n Bootstrap=No Model=AR.3")

dev.off()

dataexpand=data.frame(Feed_intake=rep(datamyc$Feed_intake,100)+runif(length(datamyc$Feed_intake)*100,-1.5,1.5)*rep(datamyc$Feed_intake.sd,100),
                      Mycotoxin=rep(datamyc$Mycotoxin,100),
                      Dose_T=rep(datamyc$Dose_T,100))

multi.m3 <- drm(Feed_intake~Dose_T,Mycotoxin,data=dataexpand,fct = AR.3())
print(summary(multi.m3))

file.remove("summary_Feed_intake_mar.txt")

cat(capture.output(ED(multi.m3,c(10,50), interval = "delta")),
    file = "summary_Feed_intake_mar.txt",
    sep="\n",append = T)

cat(capture.output(summary(multi.m3)),
    file = "summary_Feed_intake_mar.txt",
    sep="\n",append = T)

png("images/Feed_intake_mar.png")

plot(multi.m3,
     col = TRUE,
     xlab = "Log Dose(mg/kg feed)",
     ylab = "Feed_intake",
     main=" Feed_intake AF & OTA  Marek chickens\n Bootstrap=Yes Model=AR.3")
dev.off()

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

datamyc=cases_ls_liv[[3]]
multi.m3 <- drm(Feed_intake~Dose_T,Mycotoxin,data=datamyc,fct = L.3())
print(summary(multi.m3))

file.remove("summary_Feed_intake_liv.txt")

cat(capture.output(ED(multi.m3,c(10,50), interval = "delta")),
    file = "summary_Feed_intake_liv.txt",
    sep="\n",append = T)

cat(capture.output(summary(multi.m3)),
    file = "summary_Feed_intake_mar.txt",
    sep="\n",append = T)

png("images/Feed_intake_liv_bootno.png")

plot(multi.m3,
     col = TRUE,
     xlab = "Log Dose(mg/kg feed)",
     ylab = "Feed_intake",
     xlim=c(0,10),
     main="Feed_intake AF & OTA   White Leghorn chickens\n Bootstrap=No Model=L.3",
     legendPos = c(9, 5400))

dev.off()

##########################################################################################
# Liver_relative_weight #Marek

datamyc=cases_ls_mar[[4]]

dataexpand=data.frame(Liver_relative_weight=rep(datamyc$Liver_relative_weight,100)+runif(length(datamyc$Liver_relative_weight)*100,-1.2,1.2)*rep(datamyc$Liver_relative_weight.sd,100),
                      Mycotoxin=rep(datamyc$Mycotoxin,100),
                      Dose_T=rep(datamyc$Dose_T,100))

multi.m3 <- drm(Liver_relative_weight~Dose_T,Mycotoxin,data=dataexpand,fct = AR.3())
print(summary(multi.m3))
file.remove("summary_Liver_RW_mar.txt")

cat(capture.output(ED(multi.m3,c(10,50), interval = "delta")),
    file = "summary_Liver_RW_mar.txt",
    sep="\n",append = T)

cat(capture.output(summary(multi.m3)),
    file = "summary_Liver_RW_mar.txt",
    sep="\n",append = T)

png("images/Liver_RW_mar.png")

plot(multi.m3, col = TRUE,
     xlab = "Log Dose(mg/kg feed)",
     ylab = "Liver RW",
     main="Liver RW AF & OTA  Marek chickens\n Bootstrap=Yes Model=AR.3",
     legendPos = c(0.5, 4.8))

dev.off()

##########################################################################################
# Kidney_relative_weight#Marek

datamyc=cases_ls_mar[[5]]

dataexpand=data.frame(Kidney_relative_weight=rep(datamyc$Kidney_relative_weight,100)+runif(length(datamyc$Kidney_relative_weight)*100,-1.5,1.5)*rep(datamyc$Kidney_relative_weight.sd,100),
                      Mycotoxin=rep(datamyc$Mycotoxin,100),
                      Dose_T=rep(datamyc$Dose_T,100))

multi.m3 <- drm(Kidney_relative_weight~Dose_T,Mycotoxin,data=dataexpand,fct = AR.3())
print(summary(multi.m3))

file.remove("summary_Kidney_RW_mar.txt")

cat(capture.output(ED(multi.m3,c(10,50), interval = "delta")),
    file = "summary_Kidney_RW_mar.txt",
    sep="\n",append = T)

cat(capture.output(summary(multi.m3)),
    file = "summary_Kidney_RW_mar.txt",
    sep="\n",append = T)

png("images/Kidney_RW_mar.png")

plot(multi.m3, col = TRUE,
     xlab = "Log Dose(mg/kg feed)",
     ylab = "Kidney RW",
     main="Kidney RW AF & OTA Marek chickens\n Bootstrap=Yes Model=AR.3",
     legendPos = c(0.5, 0.9))

dev.off()

##########################################################################################
# Spleen_relative weight

datamyc=cases_ls_mar[[6]]
multi.m4 <- drm(Spleen_relative_weight~Dose_T,Mycotoxin,data=datamyc[,],fct=L.3())
print(summary(multi.m4))

file.remove("summary_Spleen_RW_mar.txt")

cat(capture.output(ED(multi.m4,c(10,50), interval = "delta")),
    file = "summary_Spleen_RW_mar.txt",
    sep="\n",append = T)

cat(capture.output(summary(multi.m4)),
    file = "summary_Spleen_RW_mar.txt",
    sep="\n",append = T)

png("images/Spleen_RW_mar.png")

plot(multi.m4, col = TRUE,
     xlab = "Log Dose(mg/kg feed)",
     ylab = "Spleen RW",
     main="Spleen RW AF & OTA Marek chickens\n Bootstrap=No Model=L.3",
     legendPos = c(0.4, 0.329))

dev.off()


library(ggplot2)
library(dplyr)

# disable scientific notation
options(scipen=999)

df=read.table("time.txt", header=TRUE)

# compute the median
dfMedian=ddply(df, .(tool), summarise, med = median(time))

plot1=ggplot(df, aes(x=tool, y=time)) + scale_y_log10() + ylab("Time (ms)") + xlab(element_blank()) +
  geom_violin() +
  stat_summary(fun.y="median", geom="point") +
  geom_text(data=dfMedian, aes(x=tool, y=med, label=med), size=3, vjust=-1.5)

ggsave("plot1.pdf", plot=plot1, width=4, height=4, units="in", dpi=300)

sum(filter(df, tool == "RefDiff")$time)
median(filter(df, tool == "RefDiff")$time)
mean(filter(df, tool == "RefDiff")$time)
max(filter(df, tool == "RefDiff")$time)
sum(filter(df, tool == "RMiner")$time)
median(filter(df, tool == "RMiner")$time)
mean(filter(df, tool == "RMiner")$time)
max(filter(df, tool == "RMiner")$time)

#> sum(filter(df, tool == "RefDiff")$time)
#[1] 394632
#> median(filter(df, tool == "RefDiff")$time)
#[1] 157
#> mean(filter(df, tool == "RefDiff")$time)
#[1] 368.815
#> max(filter(df, tool == "RefDiff")$time)
#[1] 10500
#> sum(filter(df, tool == "RMiner")$time)
#[1] 2188286
#> median(filter(df, tool == "RMiner")$time)
#[1] 109
#> mean(filter(df, tool == "RMiner")$time)
#[1] 2045.127
#> max(filter(df, tool == "RMiner")$time)
#[1] 85576

#dfRefdiff=read.table("refdiff.txt", header=TRUE)
#dfRminer=read.table("rminer.txt", header=TRUE)

#ggplot(dfRminer, aes(x=files, y=time)) + geom_point(shape=23) + geom_point(data=dfRefdiff, aes(x=files, y=time), shape=1, color="blue")


#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
rm(list=ls()) # clears workspace
# setwd('/Volumes/NovakLab/Projects/SaturationMetaAnalysis/')
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
library(ggplot2)
library(plyr)
library(devtools)
devtools::install_github("ropensci/rgpdd")
library(rgpdd) # for Global Popn Dynamics Db
source('SatMeta-Functions.r')
#~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# Run to update data files
# source('SatMeta-GoogleImportDataPrep.r')
load('../Data/Saturation_Data.Rdata')
load('../Data/Saturation_GAMfit.Rdata')

#####################################################################################
# Compare estimated taxon effects to percent cycling (Kendall et al. 1998)
#####################################################################################

# Using means of raw data
fr.feed <- ddply(dat,.(Taxon.group),summarise,fr.feed=mean(Percent.feeding)/100)

fr.feed.eff<-coef(fit)[2:(length(TaxonGroupLevels)-1)]
fr.feed.eff<-data.frame(Taxon.group=substring(names(fr.feed.eff),11,nchar(names(fr.feed.eff))),fr.feed.eff=fr.feed.eff)

fr.period <- read.csv('../Data/Kendall_et_al_1998-FracPeriodic.csv', stringsAsFactors=F)
colnames(fr.period)[1]<-'Taxon.group'

# Aggregate Kendall groups to correspond to our grouping
fr.period<-rbind(fr.period,fr.period[1,])
fr.period[nrow(fr.period),1]<-'Mollusca'
fr.period[nrow(fr.period),c(2,3,5)]<-fr.period[6,c(2,3,5)]+fr.period[7,c(2,3,5)]
fr.period[nrow(fr.period),c(4,6,7)]<-ddply(rbind(fr.period[6,],fr.period[7,]),.(),summarise, Frac.Popns.Periodic=weighted.mean(Frac.Popns.Periodic,Number.Popns), Frac.Spp.Periodic.Raw=weighted.mean(Frac.Spp.Periodic.Raw,Number.Spp), Frac.Spp.Periodic.Bonf=weighted.mean(Frac.Spp.Periodic.Bonf,Number.Spp))[,-1]

fr.period<-rbind(fr.period,fr.period[1,])
fr.period[nrow(fr.period),1]<-'Arthropoda'
fr.period[nrow(fr.period),c(2,3,5)]<-fr.period[4,c(2,3,5)]+fr.period[5,c(2,3,5)]
fr.period[nrow(fr.period),c(4,6,7)]<-ddply(rbind(fr.period[4,],fr.period[5,]),.(),summarise, Frac.Popns.Periodic=weighted.mean(Frac.Popns.Periodic,Number.Popns), Frac.Spp.Periodic.Raw=weighted.mean(Frac.Spp.Periodic.Raw,Number.Spp), Frac.Spp.Periodic.Bonf=weighted.mean(Frac.Spp.Periodic.Bonf,Number.Spp))[,-1]

############
# Merge data
############
fr.comb<-merge(merge(fr.feed,fr.feed.eff,all.y=TRUE),fr.period,all.x=TRUE)

#################
pdf('../Output/SatMeta-PerFeed.v.PerCyclic.pdf',width=6,height=5)
par(pty='s',mfrow=c(2,3),las=2,cex=0.5,mgp=c(1.7,0.3,0),tcl=-0.2,cex.lab=1.1)
  xlims<-ylims<-c(0,1)
  plot(fr.comb$fr.feed,fr.comb$Frac.Popns.Periodic,pch=19,xlim=xlims,ylim=ylims,xlab='Percent feeding',ylab='Percent cycling (Kendall et al.)')
    text(fr.comb$fr.feed,fr.comb$Frac.Popns.Periodic,fr.comb$Taxon.group,pos=3)
  plot(fr.comb$fr.feed,fr.comb$Frac.Spp.Periodic.Raw,pch=19,xlim=xlims,ylim=ylims,xlab='Percent feeding',ylab='Percent cycling (Kendall et al.)')
    text(fr.comb$fr.feed,fr.comb$Frac.Spp.Periodic.Raw,fr.comb$Taxon.group,pos=3)
  plot(fr.comb$fr.feed,fr.comb$Frac.Spp.Periodic.Bonf,pch=19,xlim=xlims,ylim=ylims,xlab='Percent feeding',ylab='Percent cycling (Kendall et al.)')
    text(fr.comb$fr.feed,fr.comb$Frac.Spp.Periodic.Bonf,fr.comb$Taxon.group,pos=3)

    xlims<-c(0,2.5)
    plot(fr.comb$fr.feed.eff,fr.comb$Frac.Popns.Periodic,pch=19,xlim=xlims,ylim=ylims,xlab='Taxon effect',ylab='Percent cycling (Kendall et al.)')
    text(fr.comb$fr.feed.eff,fr.comb$Frac.Popns.Periodic,fr.comb$Taxon.group,pos=3)
    plot(fr.comb$fr.feed.eff,fr.comb$Frac.Spp.Periodic.Raw,pch=19,xlim=xlims,ylim=ylims,xlab='Taxon effect',ylab='Percent cycling (Kendall et al.)')
    text(fr.comb$fr.feed.eff,fr.comb$Frac.Spp.Periodic.Raw,fr.comb$Taxon.group,pos=3)
    plot(fr.comb$fr.feed.eff,fr.comb$Frac.Spp.Periodic.Bonf,pch=19,xlim=xlims,ylim=ylims,xlab='Taxon effect',ylab='Percent cycling (Kendall et al.)')
    text(fr.comb$fr.feed.eff,fr.comb$Frac.Spp.Periodic.Bonf,fr.comb$Taxon.group,pos=3)
dev.off()

# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~


  applyMean = function( f, method="fast", newnames=NULL, ... ) {
    cnames= c("id", "x", "w" )

    if (is.null( newnames )) newnames=names(f)

    nv = ncol(f)
    names(f) = cnames[1:nv]

    if (method=="slow") {
      if (nv==2) {
        r = by( f, f$id, with, mean( x, na.rm=TRUE, ... ))
        out = data.frame( id=names(r), x=as.numeric(as.vector(r)) , stringsAsFactors=FALSE )
      }
      if (nv==3 ) {
        r = by( f, f$id, with, weighted.mean( x, w, na.rm=TRUE, ... ))
        out = data.frame( id=names(r), x=as.numeric(as.vector(r)) , stringsAsFactors=FALSE )
      }
    }

    if (method=="compact_but_slow") {
      rowindex = 1:nrow(f)
      if (nv==2) {
        out = aggregate(rowindex ~ id, f, function(i) mean(f$x[i], na.rm=TRUE ), na.action=na.omit ) #arithmetic mean
      }
      if (nv==3 ) {
        out = aggregate(rowindex ~ id, f, function(i) weighted.mean(f$x[i], f$w[i], na.rm=TRUE ), na.action=na.omit ) # weighted mean
      }
    }

    if (method=="fast") {
      if (nv==2 ) {
        # no weighting factor .. simple means
        o = which( is.finite( f$x) )
        if ( length(o) == 0 ) return( "No data?")
        f = f[o,]

        f$id = as.factor( f$id )
        f$x = as.numeric( f$x )
        l0 = 1/(median(f$x))
        out0 = as.data.frame( xtabs( f$x * l0 ~ f$id, na.action=na.omit) / l0 , stringsAsFactors=FALSE )
        names( out0) = c("id", "sumx" )

        out1 = as.data.frame( xtabs( ~ f$id, na.action=na.omit) , stringsAsFactors=FALSE )
        names( out1) = c("id", "n" )

        out = merge( out0, out1, by="id", all=TRUE, sort=FALSE )
        out$res = out$sumx / out$n
        out = out[ ,c( "id", "res" )]
      }

      if( nv==3 ) {
        # has a weighting factor .. weighted average

        o = which( is.finite( f$x + f$w) )
        if ( length(o) == 0 ) return( "No data?")
        f = f[o,]

        f$id = as.factor( f$id )
        f$x = as.numeric( f$x )
        f$xw = as.numeric( f$x * f$w )

        l0 = 1 / median( f$xw, na.rm=TRUE ) # a scaling factor to help avoid overflow errors
        l1 = 1 / median( f$w,  na.rm=TRUE )

        out0 = as.data.frame( xtabs( f$xw * l0 ~ f$id, na.action=na.omit) / l0 , stringsAsFactors=FALSE )
        names( out0) = c("id", "sumxw" )

        out1 = as.data.frame( xtabs( f$w *l1 ~ f$id, na.action=na.omit) / l1 , stringsAsFactors=FALSE )
        names( out1) = c("id", "sumw" )

        out = merge( out0, out1, by="id", all=TRUE, sort=FALSE )
        out$res = out$sumxw / out$sumw
        out = out[ ,c( "id", "res" )]

      }
    }

    names(out) = newnames[1:2]
    return( out )
  }


##CTE534_ClasificacionSupervisada=group
##Imagen=raster
##Vector=vector
##Codigo=field Vector
##Usos=field Vector
##TablaUsos=output table
#CodigoUsos=output table
##EntrenamientoRaster=output raster
##Covariables=output raster
##Trainingbrick=output raster
##ValueTable=output table
##Matriz_de_Confusion=output table
##showplots

#Extraer valores de imagen según vector
Salida<-raster::extract(Imagen, Vector, df=TRUE)
Vector$ID<-row.names(Vector)
TablaUsos<-merge(Salida, Vector, x.by="ID", by.y="ID")

#Rasterizar
EntrenamientoRaster <- rasterize(Vector, Imagen[[1]], field=Codigo)

#CoVariables
Covariables <- mask(Imagen, EntrenamientoRaster)

#Training Brick
Trainingbrick <- addLayer(Covariables, EntrenamientoRaster)

#Extraer todos los valores en una matriz
valuetable<- getValues(Trainingbrick)
#Convertir a data frame
valuetable <- as.data.frame(valuetable)
#Eliminar los na
ValueTable  <- na.omit(valuetable)

Levels <- length(unique(Vector[[Codigo]]))

#RANDOM FOREST
library(randomForest)

#valuetable <- read.csv("CSV/ValueTable.csv")
modelRF <- randomForest(x = ValueTable[ ,c(1:(dim(ValueTable)[2] - 1))], y=factor(ValueTable$layer),
                        importance = TRUE, type="classification")

#Inspeccionar la matriz de confusión del el analisís del error OOB
modelRF$confusion
clasificacion <- sort(unique(Vector[[Usos]]))

#Matriz de confusion
Matriz_de_Confusion <- data.frame(modelRF$confusion)
names(Matriz_de_Confusion)[1:Levels] <- clasificacion
#row.names(Matriz_de_Confusion) <- clasificacion
Matriz_de_Confusion

#Importancia variables
varImpPlot(modelRF)


assert.type <- function(x, type, nm=deparse(substitute(x)))
{
  Rstuff <- c("character", "numeric", "integer", "double", "logical", "matrix", "data.frame", "vector")
  type <- match.arg(type, Rstuff)

  fun <- eval(parse(text=paste("is.", type, sep="")))

  if (!fun(x))
    pbdMPI::comm.stop(paste0("argument '", nm, "' must be of type ", type), call.=FALSE)

  return(invisible(TRUE))
}

assert.nonneg <- function(x, nm=deparse(substitute(x)))
{
  if (x < 0)
    pbdMPI::comm.stop(paste0("argument '", nm, "' must be >= 0; have ", nm, "=", x), call.=FALSE)

  return(invisible(TRUE))
}

assert.positive <- function(x, nm=deparse(substitute(x)))
{
  if (x <= 0)
    pbdMPI::comm.stop(paste0("argument '", nm, "' must be > 0; have ", nm, "=", x), call.=FALSE)

  return(invisible(TRUE))
}

isint <- function(x)
{
  epsilon <- 1e-8

  return(abs(x - round(x)) < epsilon)
}

assert.wholenum <- function(x, nm=deparse(substitute(x)))
{
  if (!isint(x))
    pbdMPI::comm.stop(paste0("argument '", nm, "' must be an integer; have ", nm, "=", x), call.=FALSE)

  return(invisible(TRUE))
}

assert.natnum <- function(x)
{
  nm <- deparse(substitute(x))
  assert.wholenum(x, nm=nm)
  assert.nonneg(x, nm=nm)

  return(invisible(TRUE))
}

assert.posint <- function(x)
{
  nm <- deparse(substitute(x))
  assert.wholenum(x, nm=nm)
  assert.positive(x, nm=nm)

  return(invisible(TRUE))
}


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

cl <- makeCluster(2)
registerDoParallel(cl)

setwd("Enrichment-Inference-Supplemental-Materials/simulation_files/difference_bands")
source("power_type1_cb.r")
source("hypothesis_test_new.r")

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

method.v <- c("sup-t", "bonf", "EmProc")

dist <- "binorm"
params.ls <- list(list(c(sqrt(2) * .8, 0), c(sqrt(2) * .6, 0)), list(c(sqrt(2) * .8, 0), c(sqrt(2) * .8, 0)),
                  list(c(sqrt(2) * .6, 0), c(sqrt(2) * .6, 0)))
rho <- c(.9, .9, .9)

k.ls <- rep(list(list()), length(params.ls))
k.c.ls <- rep(list(list()), length(params.ls))
i <- 1; j <- 1
for(i in seq_along(params.ls)) {
  for(j in seq_along(method.v)) {
    print(paste(params.ls[i], method.v[j]))
    k.ls[[i]][[j]] <- power.test(params= params.ls[[i]], dist = dist, pi.0.true = 1/500,
                                 myseed=569, method = method.v[j], plus = F,
                                 simreps = simreps, m = 150000,
                                 r.vec = r.vec, metric = "k", rho = rho[i])
    k.c.ls[[i]][[j]] <- power.test(params= params.ls[[i]], dist = dist, pi.0.true = 1/500,
                                   myseed=569, method = method.v[j], plus = T,
                                   simreps = simreps, m = 150000,
                                   r.vec = r.vec, metric = "k", rho = rho[i])
    save.image("power_band_binorm_corr.rdata")
  }
}


#**********
# libs
#**********
rm(list = ls())
library(readr)
source('Evaluation.r')

#****************
# read data
#****************
file_names <- list.files('./data/', pattern = '*.csv')
j = 1
for(file_name in file_names){
  x = read_csv(paste('./data/', file_name, sep = ''))

  if(j == 1){
    rslt = x
  }else{
    rslt = rbind(rslt, x)
  }

  j = j +1
}

save(file = 'rslt.RData', rslt, compression_level = 9)

#*******************
# analyze performance
#******************

cutoffs = c(seq(0.5, 0.9, 0.1), seq(0.91, 0.99, 0.01))
j = 1
for(i in cutoffs){
  perf <- eval(post = rslt$pred_prob, ground.truth = rslt$ground_truth, thres = i)

  if(j == 1)
      perfs = perf
  else{
      perfs = rbind(perfs, perf)
  }

  print(j)
  j = j + 1
}

write.csv(file = 'perfs.csv', perfs, row.names = F, quote = T)

#conduct analysis on cutoff
load('rslt.RData')
proportion = c(seq(0.1, 0.02, -0.01),
               seq(0.01, 0.001, -0.001))
N = nrow(rslt)
rslt = sort(rslt[,2], decreasing = T, method = 'quick')
ns = c()
for (p in proportion){
  ns = c(ns, ceiling(N*p))
}
cutoff_prob = rslt[ns]
cutoff_prop_prob = data.frame(prop = proportion, prob = cutoff_prob)
write.csv(file='Celegans.csv', cutoff_prop_prob, row.names = F)

# prop      prob
# 1  0.100 0.5359123
# 2  0.090 0.5876898
# 3  0.080 0.6408077
# 4  0.070 0.6935574
# 5  0.060 0.7449306
# 6  0.050 0.7938480
# 7  0.040 0.8399874
# 8  0.030 0.8832679
# 9  0.020 0.9236561
# 10 0.010 0.9614733
# 11 0.009 0.9651591
# 12 0.008 0.9688153
# 13 0.007 0.9724771
# 14 0.006 0.9761189
# 15 0.005 0.9797641
# 16 0.004 0.9834235
# 17 0.003 0.9871500
# 18 0.002 0.9909271
# 19 0.001 0.9949517


# install necessary packages ----
library(ggplot2)
library(ggradar)
suppressPackageStartupMessages(library(dplyr))
library(scales)

#load necessary data
#field_radar = read_csv('write_data/field_radar.csv')

# data processing ----
field_radar <- field_radar %>%
  #as_tibble(rownames = 'classification') %>%
  mutate_at(vars(-'classification'),function(x) x/100)%>%
  head(5)

# visualization radar plot ----
ggradar(field_radar) +
  ggsave("fifa_radar_plot.png")