#***************************************************************************************************************************************
# Functions: Start
#***************************************************************************************************************************************

#===============================================================================
# PCA
#===============================================================================
multisample_PCA = function(df, sampleinfo_df, outfile)
{
  tempdf = df[,-1];
  tempcol = colnames(tempdf);
  tempgrp = sampleinfo_df[tempcol,2];
  tempdf = t(tempdf) %>% as.data.frame();
  tempdf[is.na(tempdf)] = 0;
  tempdf$Group = tempgrp;
  png(outfile, width = 6, height = 6, units = 'in', res=300);
  # bitmap(outfile, "png16m");
  g = autoplot(prcomp(select(tempdf, -Group)), data = tempdf, colour = 'Group', size=3);
  saveWidget(ggplotly(g), file.path(gsub("\\.png", "\\.html", outplot)))
  plot(g);
  dev.off();
}

#===============================================================================
# Regression and Cook's distance
#===============================================================================
singlesample_regression = function(PE_TE_data,htmloutfile, append=TRUE)
{
  rownames(PE_TE_data) = PE_TE_data$PE_ID;
  regmodel = lm(PE_abundance~TE_abundance, data=PE_TE_data);
  regmodel_summary = summary(regmodel);

  cat("
Linear Regression model fit between Proteome and Transcriptome data
\n",
      "
Assuming a linear relationship between Proteome and Transcriptome data, we here fit a linear regression model.
\n",
      '

Parameter	Value
\n',
      file = htmloutfile, append = TRUE);

  cat("
Formula	","PE_abundance~TE_abundance","
\n",
      "
 Coefficients	","
\n",
      "
",names(regmodel$coefficients[1]),"	",regmodel$coefficients[1]," (Pvalue:", regmodel_summary$coefficients[1,4],")","
\n",
      "
",names(regmodel$coefficients[2]),"	",regmodel$coefficients[2]," (Pvalue:", regmodel_summary$coefficients[2,4],")","
\n",
      "
 Model parameters	","
\n",
      "
Residual standard error	",regmodel_summary$sigma," (",regmodel_summary$df[2]," degree of freedom)
\n",
      "
F-statistic	",regmodel_summary$fstatistic[1]," ( on ",regmodel_summary$fstatistic[2]," and  ",regmodel_summary$fstatistic[3]," degree of freedom)
\n",
      "
R-squared	",regmodel_summary$r.squared,"
\n",
      "
Adjusted R-squared	",regmodel_summary$adj.r.squared,"
\n",
      file = htmloutfile, append = TRUE);

  cat("
\n", file = htmloutfile, append = TRUE);

  cat(
    "
Regression and diagnostics plots
\n",
    file = htmloutfile, append = TRUE);

  outplot = paste(outdir,"/PE_TE_lm_1.png",sep="",collapse="");
  png(outplot, width = 10, height = 10, units = 'in',res=300);
  # bitmap(outplot, "png16m");
  par(mfrow=c(1,1));
  plot(regmodel, 1, cex.lab=1.5);
  dev.off();

  suppressWarnings(g <- autoplot(regmodel, label = FALSE)[[1]] +
    geom_point(aes(text=sprintf("Residual: %.2f
Fitted value: %.2f
Gene: %s", .fitted, .resid, PE_TE_data$PE_ID)),
               shape = 1, size = .1, stroke = .2) +
    theme_light())
  saveWidget(ggplotly(g, tooltip= c("text")), file.path(gsub("\\.png", "\\.html", outplot)))

  outplot = paste(outdir,"/PE_TE_lm_2.png",sep="",collapse="");
  png(outplot,width = 10, height = 10, units = 'in', res=300);
  # bitmap(outplot, "png16m");
  par(mfrow=c(1,1));
  g <- plot(regmodel, 2, cex.lab=1.5);
  ggplotly(g)
  dev.off();

  suppressWarnings(g <- autoplot(regmodel, label = FALSE)[[2]] +
    geom_point(aes(text=sprintf("Standarized residual: %.2f
Theoretical quantile: %.2f
Gene: %s", .qqx, .qqy, PE_TE_data$PE_ID)),
               shape = 1, size = .1) +
    theme_light())
  saveWidget(ggplotly(g, tooltip = "text"), file.path(gsub("\\.png", "\\.html", outplot)))

  outplot = paste(outdir,"/PE_TE_lm_5.png",sep="",collapse="");
  png(outplot, width = 10, height = 10, units = 'in',res=300);
  # bitmap(outplot, "png16m");
  par(mfrow=c(1,1));
  plot(regmodel, 5, cex.lab=1.5);
  dev.off();

  cd_cont_pos <- function(leverage, level, model) {sqrt(level*length(coef(model))*(1-leverage)/leverage)}
  cd_cont_neg <- function(leverage, level, model) {-cd_cont_pos(leverage, level, model)}

  suppressWarnings(g <- autoplot(regmodel, label = FALSE)[[4]] +
    aes(label = PE_TE_data$PE_ID) +
    geom_point(aes(text=sprintf("Leverage: %.2f
Standardized residual: %.2f
Gene: %s", .hat, .stdresid, PE_TE_data$PE_ID))) +
    theme_light())
  saveWidget(ggplotly(g, tooltip = "text"), file.path(gsub("\\.png", "\\.html", outplot)))

  cat('
', file = htmloutfile, append = TRUE);

  cat(
    '
', "
1) Residuals vs Fitted plot
	\n",
    '
2) Normal Q-Q plot of residuals

\n',
    file = htmloutfile, append = TRUE);

  cat(
    '
',
    gsub("width:500px;height:500px", "width:600px;height:600px", extractWidgetCode(paste(outdir,"/PE_TE_lm_1.png",sep="",collapse=""))$widget_div),
    '	',
    gsub("width:500px;height:500px", "width:600px;height:600px", extractWidgetCode(paste(outdir,"/PE_TE_lm_2.png",sep="",collapse=""))$widget_div),
    '
\n', file = htmloutfile, append = TRUE);

  cat(
    '
This plot checks for linear relationship assumptions.
If a horizontal line is observed without any distinct patterns, it indicates a linear relationship.	\n',
    'This plot checks whether residuals are normally distributed or not.
It is good if the residuals points follow the straight dashed line i.e., do not deviate much from dashed line.

\n',
    file = htmloutfile, append = TRUE);

  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  # Residuals data
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  res_all = regmodel$residuals;
  res_mean = mean(res_all);
  res_sd = sd(res_all);
  res_diff = (res_all-res_mean);
  res_zscore = res_diff/res_sd;
  # res_outliers = res_all[which((res_zscore > 2)|(res_zscore < -2))]

  tempind = which((res_zscore > 2)|(res_zscore < -2));
  res_PE_TE_data_no_outlier = PE_TE_data[-tempind,];
  res_PE_TE_data_no_outlier$residuals = res_all[-tempind];
  res_PE_TE_data_outlier = PE_TE_data[tempind,];
  res_PE_TE_data_outlier$residuals = res_all[tempind];

  # Save the complete table for download (influential_observations)
  temp_outlier_data = data.frame(res_PE_TE_data_outlier$PE_ID, res_PE_TE_data_outlier$TE_abundance, res_PE_TE_data_outlier$PE_abundance, res_PE_TE_data_outlier$residuals)
  colnames(temp_outlier_data) = c("Gene", "Transcript abundance", "Protein abundance", "Residual value")
  outdatafile = paste(outdir,"/PE_TE_outliers_residuals.txt", sep="", collapse="");
  write.table(temp_outlier_data, file=outdatafile, row.names=F, sep="\t", quote=F);

  # Save the complete table for download (non influential_observations)
  temp_all_data = data.frame(PE_TE_data$PE_ID, PE_TE_data$TE_abundance, PE_TE_data$PE_abundance, res_all)
  colnames(temp_all_data) = c("Gene", "Transcript abundance", "Protein abundance", "Residual value")
  outdatafile = paste(outdir,"/PE_TE_abundance_residuals.txt", sep="", collapse="");
  write.table(temp_all_data, file=outdatafile, row.names=F, sep="\t", quote=F);

  cat('

Outliers based on the residuals from regression analysis
\n',
      file = htmloutfile, append = TRUE);
  cat('
\n',
      '
Residuals from Regression
\n',
      '
Parameter	Value
\n',
      file = htmloutfile, append = TRUE);

  cat("
Mean Residual value	",res_mean,"
\n",
      "
Standard deviation (Residuals)	",res_sd,"
\n",
      '
Total outliers (Residual value > 2 standard deviation from the mean)	',length(tempind),' (Download these ',length(tempind),' data points with high residual values here)	\n',
      '
',
      '(Download the complete residuals data here)',
      "
\n

\n",
      file = htmloutfile, append = TRUE);

  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

  cat('

', file = htmloutfile, append = TRUE);

  cat(
    '

3) Residuals vs Leverage plot

\n',
    file = htmloutfile, append = TRUE);

  cat(
    '
',
    gsub("width:500px;height:500px", "width:600px;height:600px", extractWidgetCode(paste(outdir,"/PE_TE_lm_5.png",sep="",collapse=""))$widget_div)
    , '
\n',
    file = htmloutfile, append = TRUE);

  cat(
    '
This plot is useful to identify any influential cases, that is outliers or extreme values.
They might influence the regression results upon inclusion or exclusion from the analysis.

\n',
    file = htmloutfile, append = TRUE);

  #^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
  # Cook's Distance
  #^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
  cat('

INFLUENTIAL OBSERVATIONS
\n',
      file = htmloutfile, append = TRUE);
  cat(
    '
Cook\'s distance computes the influence of each data point/observation on the predicted outcome. i.e. this measures how much the observation is influencing the fitted values.
In general use, those observations that have a Cook\'s distance > than ', cookdist_upper_cutoff,' times the mean may be classified as influential.
\n',
    file = htmloutfile, append = TRUE);

  cooksd <- cooks.distance(regmodel);

  outplot = paste(outdir,"/PE_TE_lm_cooksd.png",sep="",collapse="");
  png(outplot, width = 10, height = 10, units = 'in', res=300);
  # bitmap(outplot, "png16m");
  par(mfrow=c(1,1));
  plot(cooksd, main="Influential Obs. by Cook\'s distance", ylab="Cook\'s distance", xlab="Observations", type="n")  # plot cooks distance
  sel_outlier=which(cooksd>=as.numeric(cookdist_upper_cutoff)*mean(cooksd, na.rm=T))
  sel_nonoutlier=which(cooksd<as.numeric(cookdist_upper_cutoff)*mean(cooksd, na.rm=T))
  points(sel_outlier, cooksd[sel_outlier],pch="*", cex=2, cex.lab=1.5, col="red")
  points(sel_nonoutlier, cooksd[sel_nonoutlier],pch="*", cex=2, cex.lab=1.5, col="black")
  abline(h = as.numeric(cookdist_upper_cutoff)*mean(cooksd, na.rm=T), col="red")  # add cutoff line
  #text(x=1:length(cooksd)+1, y=cooksd, labels=ifelse(cooksd>as.numeric(cookdist_upper_cutoff)*mean(cooksd, na.rm=T),names(cooksd),""), col="red", pos=2)  # add labels
  dev.off();

  cooksd_df <- data.frame(cooksd)
  cooksd_df$genes <- row.names(cooksd_df)
  cooksd_df$index <- 1:nrow(cooksd_df)
  cooksd_df$colors <- "black"
  cutoff <- as.numeric(cookdist_upper_cutoff)*mean(cooksd, na.rm=T)
  cooksd_df[cooksd_df$cooksd > cutoff,]$colors <- "red"

  g <- ggplot(cooksd_df, aes(x = index, y = cooksd, label = row.names(cooksd_df), color=as.factor(colors),
          text=sprintf("Gene: %s
Cook's Distance: %.3f", row.names(cooksd_df), cooksd))) +
    ggtitle("Influential Obs. by Cook's distance") + xlab("Observations") + ylab("Cook's Distance") +
    #xlim(0, 3000) + ylim(0, .15) +
    scale_shape_discrete(solid=F) +
    geom_point(size = 2, shape = 8)  +
    geom_hline(yintercept = cutoff,
               linetype = "dashed", color = "red") +
    scale_color_manual(values = c("black" = "black", "red" = "red")) +
    theme_light() + theme(legend.position="none")
  saveWidget(ggplotly(g, tooltip= "text"), file.path(gsub("\\.png", "\\.html", outplot)))

  cat(
    '',
    gsub("width:500px;height:500px", "width:800px;height:800px", extractWidgetCode(outplot)$widget_div),
    '
In the above plot, observations above red line (',cookdist_upper_cutoff,' * mean Cook\'s distance) are influential. Genes that are outliers could be important. These observations influences the correlation values and regression coefficients

',
    file = htmloutfile, append = TRUE);

  tempind = which(cooksd>as.numeric(cookdist_upper_cutoff)*mean(cooksd, na.rm=T));
  PE_TE_data_no_outlier = PE_TE_data[-tempind,];
  PE_TE_data_no_outlier$cooksd = cooksd[-tempind];
  PE_TE_data_outlier = PE_TE_data[tempind,];
  PE_TE_data_outlier$cooksd = cooksd[tempind];
  a = sort(PE_TE_data_outlier$cooksd, decreasing=T, index.return=T);
  PE_TE_data_outlier_sorted = PE_TE_data_outlier[a$ix,];

  cat(
    '

Parameter	Value
\n',
    file = htmloutfile, append = TRUE);

  # Save the complete table for download (influential_observations)
  temp_outlier_data = data.frame(PE_TE_data_outlier$PE_ID, PE_TE_data_outlier$TE_abundance, PE_TE_data_outlier$PE_abundance, PE_TE_data_outlier$cooksd)
  colnames(temp_outlier_data) = c("Gene", "Transcript abundance", "Protein abundance", "Cook's distance")
  outdatafile = paste(outdir,"/PE_TE_influential_observation.txt", sep="", collapse="");
  write.table(temp_outlier_data, file=outdatafile, row.names=F, sep="\t", quote=F);

  # Save the complete table for download (non influential_observations)
  temp_no_outlier_data = data.frame(PE_TE_data_no_outlier$PE_ID, PE_TE_data_no_outlier$TE_abundance, PE_TE_data_no_outlier$PE_abundance, PE_TE_data_no_outlier$cooksd)
  colnames(temp_no_outlier_data) = c("Gene", "Transcript abundance", "Protein abundance", "Cook's distance")
  outdatafile = paste(outdir,"/PE_TE_non_influential_observation.txt", sep="", collapse="");
  write.table(temp_no_outlier_data, file=outdatafile, row.names=F, sep="\t", quote=F);

  cat("
Mean Cook\'s distance	",mean(cooksd, na.rm=T),"
\n",
      "
Total influential observations (Cook\'s distance > ",cookdist_upper_cutoff," * mean Cook\'s distance)	",length(tempind),"	\n",

      "
Observations with Cook\'s distance < ",cookdist_upper_cutoff," * mean Cook\'s distance	",length(which(cooksd<as.numeric(cookdist_upper_cutoff)*mean(cooksd, na.rm=T))),"	\n",
      "

\n",
      file = htmloutfile, append = TRUE);

  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  # Scatter plot after removal of influential points
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@
  outplot = paste(outdir,"/AbundancePlot_scatter_without_outliers.png",sep="",collapse="");
  min_lim = min(c(PE_TE_data$PE_abundance,PE_TE_data$TE_abundance));
  max_lim = max(c(PE_TE_data$PE_abundance,PE_TE_data$TE_abundance));
  png(outplot, width = 10, height = 10, units = 'in', res=300);
  # bitmap(outplot,"png16m");
  suppressWarnings(g <- ggplot(PE_TE_data_no_outlier, aes(x=TE_abundance, y=PE_abundance, label=PE_ID)) + geom_smooth() +
    xlab("Transcript abundance log fold-change") + ylab("Protein abundance log fold-change") +
    xlim(min_lim,max_lim) + ylim(min_lim,max_lim) +
    geom_point(aes(text=sprintf("Gene: %s
Transcript Abundance (log fold-change): %.3f
Protein Abundance (log fold-change): %.3f",
                                PE_ID, TE_abundance, PE_abundance))))
  suppressMessages(plot(g))
  suppressMessages(saveWidget(ggplotly(g, tooltip="text"), file.path(gsub("\\.png", "\\.html", outplot))))
  dev.off();

  cat('

Scatterplot: Before removal	Scatterplot: After removal
\n', file = htmloutfile, append = TRUE);
  # Before
  cat("
",
      '',
      gsub('id="html', 'id="secondhtml"',
           gsub("width:500px;height:500px", "width:600px;height:600px", extractWidgetCode(paste(outdir,"/TE_PE_scatter.png",sep="",collapse=""))$widget_div)),
      '	\n',
      file = htmloutfile, append = TRUE);

  # After
  cat("\n",
      '',
      gsub("width:500px;height:500px", "width:600px;height:600px", extractWidgetCode(outplot)$widget_div),

      '
\n',
      file = htmloutfile, append = TRUE);
  #@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@

  cor_result_pearson = cor.test(PE_TE_data_no_outlier[,"TE_abundance"], PE_TE_data_no_outlier[,"PE_abundance"], method = "pearson");
  cor_result_spearman = cor.test(PE_TE_data_no_outlier[,"TE_abundance"], PE_TE_data_no_outlier[,"PE_abundance"], method = "spearman");
  cor_result_kendall = cor.test(PE_TE_data_no_outlier[,"TE_abundance"], PE_TE_data_no_outlier[,"PE_abundance"], method = "kendall");

  cat('
\n', file = htmloutfile, append=TRUE);
  singlesample_cor(PE_TE_data, htmloutfile, append=TRUE);
  cat('	\n', file = htmloutfile, append=TRUE);

  cat('

Parameter	Method 1	Method 2	Method 3
\n',
      file = htmloutfile, append = TRUE);

  cat(
    "
Correlation method	",cor_result_pearson$method,"	",cor_result_spearman$method,"	",cor_result_kendall$method,"
\n",
    "
Correlation coefficient	",cor_result_pearson$estimate,"	",cor_result_spearman$estimate,"	",cor_result_kendall$estimate,"
\n",
    file = htmloutfile, append = TRUE)
  cat("

\n", file = htmloutfile, append = TRUE)

  if(dim(PE_TE_data_outlier)[1]<10)
  {
    tab_n_row = dim(PE_TE_data_outlier)[1];
  }else{
    tab_n_row = 10;
  }

  cat("

Download the complete list of influential observations    ",
      "Download the complete list (After removing influential points)
\n",
      '

Top ',as.character(tab_n_row),' Influential observations (Cook\'s distance > ',cookdist_upper_cutoff,' * mean Cook\'s distance)
\n',
      file = htmloutfile, append = TRUE);

  cat('

\n', sep = "",file = htmloutfile, append = TRUE);
  cat("Gene	Protein Log Fold-Change	Transcript Log Fold-Change	Cook's Distance
\n",
      file = htmloutfile, append = TRUE);

  for(i in 1:tab_n_row)
  {
    cat(
      '
','',as.character(PE_TE_data_outlier_sorted[i,1]),'	\n',
      '',format(PE_TE_data_outlier_sorted[i,2], scientific=F),'	\n',
      '',PE_TE_data_outlier_sorted[i,4],'	\n',
      '',format(PE_TE_data_outlier_sorted[i,5], scientific=F),'
\n',
      file = htmloutfile, append = TRUE);
  }
  cat('

\n',file = htmloutfile, append = TRUE);

}

#===============================================================================
# Heatmap
#===============================================================================
singlesample_heatmap=function(PE_TE_data, htmloutfile, hm_nclust){
  cat('

Heatmap of PE and TE abundance values (Hierarchical clustering)	Number of clusters to extract: ',hm_nclust,'
\n',
      file = htmloutfile, append = TRUE);

  hc=hclust(dist(as.matrix(PE_TE_data[,c("PE_abundance","TE_abundance")])))
  hm_cluster = cutree(hc,k=hm_nclust);

  outplot = paste(outdir,"/PE_TE_heatmap.png",sep="",collapse="");
  png(outplot, width = 10, height = 10, units = 'in', res=300);
  # bitmap(outplot, "png16m");
  par(mfrow=c(1,1));
  hmap = heatmap.2(as.matrix(PE_TE_data[,c("PE_abundance","TE_abundance")]),
                   trace="none", cexCol=1, col=greenred(100),Colv=F,
                   labCol=c("Proteins","Transcripts"), scale="col",
                   hclustfun = hclust, distfun = dist);

  dev.off();

  p <- d3heatmap(as.matrix(PE_TE_data[,c("PE_abundance","TE_abundance")]), scale = "col",
                 dendrogram = "row", colors = greenred(100),
                 hclustfun = hclust, distfun = dist,
                 show_grid = FALSE)
  saveWidget(p, file.path(gsub("\\.png", "\\.html", outplot)))

  cat('
',
      '',
      gsub("width:960px;height:500px", "width:800px;height:800px", extractWidgetCode(outplot)$widget_div),
      '
\n',
      file = htmloutfile, append = TRUE);

  temp_PE_TE_data = data.frame(PE_TE_data$PE_ID, PE_TE_data$TE_abundance, PE_TE_data$PE_abundance, hm_cluster);
  colnames(temp_PE_TE_data) = c("Gene", "Transcript abundance", "Protein abundance", "Cluster (Hierarchical clustering)")
  tempoutfile = paste(outdir,"/PE_TE_hc_clusterpoints.txt",sep="",collapse="");
  write.table(temp_PE_TE_data, file=tempoutfile, row.names=F, quote=F, sep="\t", eol="\n")

  cat('
Download the hierarchical cluster list

\n',
      file = htmloutfile, append = TRUE);
}

#===============================================================================
# K-means clustering
#===============================================================================
singlesample_kmeans=function(PE_TE_data, htmloutfile, nclust){
  PE_TE_data_kdata = PE_TE_data;
  k1 = kmeans(PE_TE_data_kdata[,c("PE_abundance","TE_abundance")], nclust);
  outplot = paste(outdir,"/PE_TE_kmeans.png",sep="",collapse="");
  png(outplot, width = 10, height = 10, units = 'in', res=300);
  # bitmap(outplot, "png16m");
  par(mfrow=c(1,1));
  scatter.smooth(PE_TE_data_kdata[,"TE_abundance"], PE_TE_data_kdata[,"PE_abundance"], xlab="Transcript Abundance", ylab="Protein Abundance", cex.lab=1.5);
  legend(1, 95, legend=c("Cluster 1", "Line 2"), col="red", lty=1:1, cex=0.8)
  legend(1, 95, legend="Cluster 2", col="green", lty=1:1, cex=0.8)

  ind=which(k1$cluster==1);
  points(PE_TE_data_kdata[ind,"TE_abundance"], PE_TE_data_kdata[ind,"PE_abundance"], col="red", pch=16);
  ind=which(k1$cluster==2);
  points(PE_TE_data_kdata[ind,"TE_abundance"], PE_TE_data_kdata[ind,"PE_abundance"], col="green", pch=16);
  ind=which(k1$cluster==3);
  points(PE_TE_data_kdata[ind,"TE_abundance"], PE_TE_data_kdata[ind,"PE_abundance"], col="blue", pch=16);
  ind=which(k1$cluster==4);
  points(PE_TE_data_kdata[ind,"TE_abundance"], PE_TE_data_kdata[ind,"PE_abundance"], col="cyan", pch=16);
  ind=which(k1$cluster==5);
  points(PE_TE_data_kdata[ind,"TE_abundance"], PE_TE_data_kdata[ind,"PE_abundance"], col="black", pch=16);
  ind=which(k1$cluster==6);
  points(PE_TE_data_kdata[ind,"TE_abundance"], PE_TE_data_kdata[ind,"PE_abundance"], col="brown", pch=16);
  ind=which(k1$cluster==7);
  points(PE_TE_data_kdata[ind,"TE_abundance"], PE_TE_data_kdata[ind,"PE_abundance"], col="gold", pch=16);
  ind=which(k1$cluster==8);
  points(PE_TE_data_kdata[ind,"TE_abundance"], PE_TE_data_kdata[ind,"PE_abundance"], col="thistle", pch=16);
  ind=which(k1$cluster==9);
  points(PE_TE_data_kdata[ind,"TE_abundance"], PE_TE_data_kdata[ind,"PE_abundance"], col="yellow", pch=16);
  ind=which(k1$cluster==10);
  points(PE_TE_data_kdata[ind,"TE_abundance"], PE_TE_data_kdata[ind,"PE_abundance"], col="orange", pch=16);
  dev.off();

  # Interactive plot for k-means clustering
  g <- ggplot(PE_TE_data, aes(x = TE_abundance, y = PE_abundance, label = row.names(PE_TE_data),
                text=sprintf("Gene: %s
Transcript Abundance: %.3f
Protein Abundance: %.3f",
                PE_ID, TE_abundance, PE_abundance),
                color=as.factor(k1$cluster))) +
    xlab("Transcript Abundance") + ylab("Protein Abundance") +
    scale_shape_discrete(solid=F) + geom_smooth(method = "loess", span = 2/3) +
    geom_point(size = 1, shape = 8) +
    theme_light() + theme(legend.position="none")
  saveWidget(ggplotly(g, tooltip=c("text")), file.path(gsub("\\.png", "\\.html", outplot)))

  cat('

K-mean clustering	Number of clusters: ',nclust,'
\n',
      file = htmloutfile, append = TRUE);

  tempind = order(k1$cluster);
  tempoutfile = paste(outdir,"/PE_TE_kmeans_clusterpoints.txt",sep="",collapse="");
  write.table(data.frame(PE_TE_data_kdata[tempind, ], Cluster=k1$cluster[tempind]), file=tempoutfile, row.names=F, quote=F, sep="\t", eol="\n")

  #paste(outdir,"/PE_TE_heatmap.png",sep="",collapse="");
  cat('
',
      gsub("width:500px;height:500px", "width:800px;height:800px", extractWidgetCode(outplot)$widget_div), '
\n',
      file = htmloutfile, append = TRUE);
  cat('
Download the cluster list

\n',
      file = htmloutfile, append = TRUE);

}

#===============================================================================
# scatter plot
#===============================================================================
singlesample_scatter = function(PE_TE_data, outfile)
{
  min_lim = min(c(PE_TE_data$PE_abundance,PE_TE_data$TE_abundance));
  max_lim = max(c(PE_TE_data$PE_abundance,PE_TE_data$TE_abundance));
  png(outfile, width = 10, height = 10, units = 'in', res=300);
  # bitmap(outfile, "png16m");
  suppressWarnings(g <- ggplot(PE_TE_data, aes(x=TE_abundance, y=PE_abundance, label=PE_ID)) + geom_smooth() +
    xlab("Transcript abundance log fold-change") + ylab("Protein abundance log fold-change") +
    xlim(min_lim,max_lim) + ylim(min_lim,max_lim) +
    geom_point(aes(text=sprintf("Gene: %s
Transcript Abundance (log fold-change): %.3f
Protein Abundance (log fold-change): %.3f",
                                PE_ID, TE_abundance, PE_abundance)),
              size = .5))
  suppressMessages(plot(g))
  suppressMessages(saveWidget(ggplotly(g, tooltip = "text"), file.path(gsub("\\.png", "\\.html", outfile))))
  dev.off();
}

#===============================================================================
# Correlation table
#===============================================================================
singlesample_cor = function(PE_TE_data, htmloutfile, append=TRUE)
{
  cor_result_pearson = cor.test(PE_TE_data$TE_abundance, PE_TE_data$PE_abundance, method = "pearson");
  cor_result_spearman = cor.test(PE_TE_data$TE_abundance, PE_TE_data$PE_abundance, method = "spearman");
  cor_result_kendall = cor.test(PE_TE_data$TE_abundance, PE_TE_data$PE_abundance, method = "kendall");

  cat(
    '

Parameter	Method 1	Method 2	Method 3
\n',
    file = htmloutfile, append = TRUE);

  cat(
    "
Correlation method	",cor_result_pearson$method,"	",cor_result_spearman$method,"	",cor_result_kendall$method,"
\n",
    "
Correlation coefficient	",cor_result_pearson$estimate,"	",cor_result_spearman$estimate,"	",cor_result_kendall$estimate,"
\n",
    file = htmloutfile, append = TRUE)
  cat("
\n", file = htmloutfile, append = TRUE);

}

#===============================================================================
# Boxplot
#===============================================================================
multisample_boxplot = function(df, sampleinfo_df, outfile, fill_leg, user_xlab, user_ylab)
{
  tempdf = df[,-1, drop=FALSE];
  tempdf = t(tempdf) %>% as.data.frame();
  tempdf[is.na(tempdf)] = 0;
  tempdf$Sample = rownames(tempdf);
  tempdf1 = melt(tempdf, id.vars = "Sample");

  if("Gene" %in% colnames(df)){
    tempdf1$Name = df$Gene;
  } else if ("Protein" %in% colnames(df)){
    tempdf1$Name = df$Protein;
  } else if ("Genes" %in% colnames(df)){
    tempdf1$Name = df$Genes;
  }

  tempdf1$Group = sampleinfo_df[tempdf1$Sample,2];
  png(outplot, width = 6, height = 6, units = 'in', res=300);
  # bitmap(outplot, "png16m");
  if(fill_leg=="No"){
    tempdf1$Group = c("case", "control")
  }

  g = ggplot(tempdf1, aes(x=Sample, y=value, fill=Group)) +
    geom_boxplot()+
    labs(x=user_xlab) + labs(y=user_ylab)
  saveWidget(ggplotly(g), file.path(gsub("\\.png", "\\.html", outfile)))
  plot(g);
  dev.off();
}

## A wrapper to saveWidget which compensates for arguable BUG in
## saveWidget which requires `file` to be in current working
## directory.
saveWidget <- function (widget,file,...) {
  wd<-getwd()
  on.exit(setwd(wd))
  outDir<-dirname(file)
  file<-basename(file)
  setwd(outDir);
  htmlwidgets::saveWidget(widget,file=file,selfcontained = FALSE)
}

#===============================================================================
# Mean or Median of Replicates
#===============================================================================

mergeReplicates = function(TE_df,PE_df, sampleinfo_df, method)
{
  grps = unique(sampleinfo_df[,2]);

  TE_df_merged <<- sapply(grps, function(x){
    tempsample = sampleinfo_df[which(sampleinfo_df$Group==x),1]
    if(length(tempsample)!=1){
      apply(TE_df[,tempsample],1,method);
    }else{
      return(TE_df[,tempsample]);
    }
  });
  TE_df_merged <<-   data.frame(as.character(TE_df[,1]), TE_df_merged);
  colnames(TE_df_merged) = c(colnames(TE_df)[1], grps);

  PE_df_merged <<- sapply(grps, function(x){
    tempsample = sampleinfo_df[which(sampleinfo_df$Group==x),1]
    if(length(tempsample)!=1){
      apply(PE_df[,tempsample],1,method);
    }else{
      return(PE_df[,tempsample]);
    }
  });

  PE_df_merged <<-   data.frame(as.character(PE_df[,1]), PE_df_merged);
  colnames(PE_df_merged) = c(colnames(PE_df)[1], grps);

  #sampleinfo_df_merged =  data.frame(Sample = grps, Group = grps, stringsAsFactors = F);
  sampleinfo_df_merged =  data.frame(Sample = grps, Group = "Group", stringsAsFactors = F);

  return(list(TE_df_merged = TE_df_merged, PE_df_merged = PE_df_merged, sampleinfo_df_merged = sampleinfo_df_merged));
}

#===============================================================================
# (T-Test or Wilcoxon ranksum test) and Volcano Plot
#===============================================================================

perform_Test_Volcano = function(TE_df_data,PE_df_data,TE_df_logfold, PE_df_logfold,sampleinfo_df, method, correction_method,volc_with)
{

  PE_colnames = colnames(PE_df_data);
  control_sample = sampleinfo_df[which(sampleinfo_df$Group=="control"),1];
  control_ind <<- sapply(control_sample, function(x){temp_ind = which(PE_colnames==x); as.numeric(temp_ind)});
  condition_sample = sampleinfo_df[which(sampleinfo_df$Group=="case"),1];
  condition_ind <<- sapply(condition_sample, function(x){temp_ind = which(PE_colnames==x); as.numeric(temp_ind)});

  if(method=="mean"){
    #PE_pval = apply(PE_df_data[2:length(colnames(PE_df_data))],1,function(x) t.test(x[condition_ind-1], x[control_ind-1])$p.value);
    PE_pval = apply(PE_df_data[2:length(colnames(PE_df_data))],1,function(x) {obj<-try(t.test(x[condition_ind-1], x[control_ind-1]),silent=TRUE); if(is(obj, "try-error")){return(NA)}else{return(obj$p.value)}})
  }else{
    if(method=="median"){
      PE_pval = apply(PE_df_data[2:length(colnames(PE_df_data))],1,function(x) {obj<-try(wilcox.test(x[condition_ind-1], x[control_ind-1]),silent=TRUE); if(is(obj, "try-error")){return(NA)}else{return(obj$p.value)}})
      # PE_pval = apply(PE_df_data[2:length(colnames(PE_df_data))],1,function(x) wilcox.test(x[condition_ind-1], x[control_ind-1])$p.value);
    }
  }
  PE_adj_pval = p.adjust(PE_pval, method = correction_method, n = length(PE_pval))

  TE_colnames = colnames(TE_df_data);
  control_sample = sampleinfo_df[which(sampleinfo_df$Group=="control"),1];
  control_ind <<- sapply(control_sample, function(x){temp_ind = which(TE_colnames==x); as.numeric(temp_ind)});
  condition_sample = sampleinfo_df[which(sampleinfo_df$Group=="case"),1];
  condition_ind <<- sapply(condition_sample, function(x){temp_ind = which(TE_colnames==x); as.numeric(temp_ind)});

  if(method=="mean"){
    # TE_pval = apply(TE_df_data[2:length(colnames(TE_df_data))],1,function(x) t.test(x[condition_ind-1], x[control_ind-1])$p.value);
    TE_pval = apply(TE_df_data[2:length(colnames(TE_df_data))],1,function(x) {obj<-try(t.test(x[condition_ind-1], x[control_ind-1]),silent=TRUE); if(is(obj, "try-error")){return(NA)}else{return(obj$p.value)}})
  }else{
    if(method=="median"){
      TE_pval = apply(TE_df_data[2:length(colnames(TE_df_data))],1,function(x) {obj<-try(wilcox.test(x[condition_ind-1], x[control_ind-1]),silent=TRUE); if(is(obj, "try-error")){return(NA)}else{return(obj$p.value)}})
      # TE_pval = apply(TE_df_data[2:length(colnames(TE_df_data))],1,function(x) wilcox.test(x[condition_ind-1], x[control_ind-1])$p.value);
    }
  }
  TE_adj_pval = p.adjust(TE_pval, method = correction_method, n = length(TE_pval))

  PE_TE_logfold_pval = data.frame(TE_df_logfold$Gene, TE_df_logfold$LogFold, TE_pval, TE_adj_pval, PE_df_logfold$LogFold, PE_pval, PE_adj_pval);
  colnames(PE_TE_logfold_pval) = c("Gene", "Transcript log fold-change", "p-value (transcript)", "adj p-value (transcript)", "Protein log fold-change", "p-value (protein)", "adj p-value (protein)");
  outdatafile = paste(outdir,"/PE_TE_logfold_pval.txt", sep="", collapse="");
  write.table(PE_TE_logfold_pval, file=outdatafile, row.names=F, sep="\t", quote=F);
  cat("

Download the complete fold change data here
\n",
      file = htmloutfile, append = TRUE);

  if(length(condition_ind)!=1)
  {
    # Volcano Plot

    if(volc_with=="adj_pval")
    {
      PE_pval = PE_adj_pval
      TE_pval = TE_adj_pval
      volc_ylab = "-log10 Adjusted p-value";
    }else{
      if(volc_with=="pval")
      {
        volc_ylab = "-log10 p-value";
      }
    }
    outplot_PE = paste(outdir,"/PE_volcano.png",sep="",collapse="");
    png(outplot_PE, width = 10, height = 10, units = 'in', res=300);
    # bitmap(outplot, "png16m");
    par(mfrow=c(1,1));

    plot(PE_df_logfold$LogFold, -log10(PE_pval),
         xlab="log2 fold change", ylab=volc_ylab,
         type="n")
    sel <- which((PE_df_logfold$LogFold<=log(2,base=2))&(PE_df_logfold$LogFold>=log(0.5, base=2))) # or whatever you want to use
    points(PE_df_logfold[sel,"LogFold"], -log10(PE_pval[sel]),col="black")
    PE_df_logfold$color <- "black"
    #sel <- which((PE_df_logfold$LogFold>log(2,base=2))&(PE_df_logfold$LogFold<log(0.5,base=2))) # or whatever you want to use
    sel <- which((PE_df_logfold$LogFold>log(2,base=2))|(PE_df_logfold$LogFold<log(0.5, base=2)))
    sel1 <- which(PE_pval<=0.05)
    sel=intersect(sel,sel1)
    points(PE_df_logfold[sel,"LogFold"], -log10(PE_pval[sel]),col="red")
    PE_df_logfold[sel,]$color <- "red"
    sel <- which((PE_df_logfold$LogFold>log(2,base=2))|(PE_df_logfold$LogFold<log(0.5, base=2)))
    sel1 <- which(PE_pval>0.05)
    sel=intersect(sel,sel1)
    points(PE_df_logfold[sel,"LogFold"], -log10(PE_pval[sel]),col="blue")
    PE_df_logfold[sel,]$color <- "blue"
    abline(h = -log(0.05,base=10), col="red", lty=2)
    abline(v = log(2,base=2), col="red", lty=2)
    abline(v = log(0.5,base=2), col="red", lty=2)
    dev.off();

    g <- ggplot(PE_df_logfold, aes(x = LogFold, -log10(PE_pval), color = as.factor(color),
            text=sprintf("Gene: %s
Log2 Fold-Change: %.3f
-log10 p-value: %.3f
p-value: %.3f",
              Genes, LogFold, -log10(PE_pval), PE_pval))) +
      xlab("log2 fold change") + ylab("-log10 p-value") +
      geom_point(shape=1, size = 1.5, stroke = .2) +
      scale_color_manual(values = c("black" = "black", "red" = "red", "blue" = "blue")) +
      geom_hline(yintercept = -log(0.05,base=10), linetype="dashed", color="red") +
      geom_vline(xintercept = log(2,base=2), linetype="dashed", color="red") +
      geom_vline(xintercept = log(0.5,base=2), linetype="dashed", color="red") +
      theme_light() + theme(legend.position="none")
    saveWidget(ggplotly(g, tooltip="text"), file.path(gsub("\\.png", "\\.html", outplot_PE)))

    outplot_TE = paste(outdir,"/TE_volcano.png",sep="",collapse="");
    png(outplot_TE, width = 10, height = 10, units = 'in', res=300);
    # bitmap(outplot, "png16m");
    par(mfrow=c(1,1));

    plot(TE_df_logfold$LogFold, -log10(TE_pval),
         xlab="log2 fold change", ylab=volc_ylab,
         type="n")

    sel <- which((TE_df_logfold$LogFold<=log(2,base=2))&(TE_df_logfold$LogFold>=log(0.5, base=2))) # or whatever you want to use
    points(TE_df_logfold[sel,"LogFold"], -log10(TE_pval[sel]),col="black")
    TE_df_logfold$color <- "black"
    #sel <- which((TE_df_logfold$LogFold>log(2,base=2))&(TE_df_logfold$LogFold<log(0.5,base=2))) # or whatever you want to use
    sel <- which((TE_df_logfold$LogFold>log(2,base=2))|(TE_df_logfold$LogFold<log(0.5, base=2)))
    sel1 <- which(TE_pval<=0.05)
    sel=intersect(sel,sel1)
    points(TE_df_logfold[sel,"LogFold"], -log10(TE_pval[sel]),col="red")
    TE_df_logfold[sel,]$color <- "red"
    sel <- which((TE_df_logfold$LogFold>log(2,base=2))|(TE_df_logfold$LogFold<log(0.5, base=2)))
    sel1 <- which(TE_pval>0.05)
    sel=intersect(sel,sel1)
    points(TE_df_logfold[sel,"LogFold"], -log10(TE_pval[sel]),col="blue")
    TE_df_logfold[sel,]$color <- "blue"
    abline(h = -log(0.05,base=10), col="red", lty=2)
    abline(v = log(2,base=2), col="red", lty=2)
    abline(v = log(0.5,base=2), col="red", lty=2)
    dev.off();

    g <- ggplot(TE_df_logfold, aes(x = LogFold, -log10(TE_pval), color = as.factor(color),
          text=sprintf("Gene: %s
Log2 Fold-Change: %.3f
-log10 p-value: %.3f
p-value: %.3f",
                                                Genes, LogFold, -log10(TE_pval), TE_pval))) +
      xlab("log2 fold change") + ylab("-log10 p-value") +
      geom_point(shape=1, size = 1.5, stroke = .2) +
      scale_color_manual(values = c("black" = "black", "red" = "red", "blue" = "blue")) +
      geom_hline(yintercept = -log(0.05,base=10), linetype="dashed", color="red") +
      geom_vline(xintercept = log(2,base=2), linetype="dashed", color="red") +
      geom_vline(xintercept = log(0.5,base=2), linetype="dashed", color="red") +
      theme_light() + theme(legend.position="none")
    saveWidget(ggplotly(g, tooltip="text"), file.path(gsub("\\.png", "\\.html", outplot_TE)))

    cat('

Transcript Fold-Change	Protein Fold-Change
\n', file = htmloutfile, append = TRUE);
    cat("
",
        '',
        extractWidgetCode(outplot_TE)$widget_div,
        '	\n', file = htmloutfile, append = TRUE);
    cat("",
        '',
        extractWidgetCode(outplot_PE)$widget_div,
        '

\n',
        file = htmloutfile, append = TRUE);

  }else{
    cat('

!!! No replicates found. Cannot perform test to check significance of differential expression. Thus, no Volcano plot generated !!!

',
        file = htmloutfile, append = TRUE);
  }

}

#***************************************************************************************************************************************
# Functions: End
#***************************************************************************************************************************************

#===============================================================================
# Arguments
#===============================================================================
noargs = 12;
args = commandArgs(trailingOnly = TRUE);
if(length(args) != noargs)
{
  stop(paste("Please check usage. Number of arguments is not equal to ",noargs,sep="",collapse=""));
}

mode = args[1]; # "multiple" or "logfold"
method = args[2]; # "mean" or "median"
sampleinfo_file = args[3];
proteome_file = args[4];
transcriptome_file = args[5];
correction_method = args[6];
cookdist_upper_cutoff = args[7];
numCluster = args[8];
hm_nclust = args[9];
volc_with = args[10];

htmloutfile = args[11]; # html output file
outdir = args[12]; # html supporting files

#===============================================================================
# Check for file existance
#===============================================================================
if(! file.exists(proteome_file))
{
  stop(paste("Proteome Data file does not exists. Path given: ",proteome_file,sep="",collapse=""));
}
if(! file.exists(transcriptome_file))
{
  stop(paste("Transcriptome Data file does not exists. Path given: ",transcriptome_file,sep="",collapse=""));
}

#===============================================================================
# Load library
#===============================================================================
options(warn=-1);

suppressPackageStartupMessages(library(dplyr));
suppressPackageStartupMessages(library(data.table));
suppressPackageStartupMessages(library(gplots));
suppressPackageStartupMessages(library(ggplot2));
suppressPackageStartupMessages(library(ggfortify));
suppressPackageStartupMessages(library(plotly));
suppressPackageStartupMessages(library(d3heatmap));

#===============================================================================
# Select mode and parse experiment design file
#===============================================================================
if(mode=="multiple")
{
  expDesign = fread(sampleinfo_file, header = FALSE, stringsAsFactors = FALSE, sep="\t") %>% data.frame();
  expDesign_cc = expDesign[1:2,];

  sampleinfo_df = expDesign[3:nrow(expDesign),];
  rownames(sampleinfo_df)=1:nrow(sampleinfo_df);
  colnames(sampleinfo_df) =  c("Sample","Group");

  condition_cols = sampleinfo_df[which(sampleinfo_df[,2]==expDesign_cc[which(expDesign_cc[,1]=="case"),2]),1];
  condition_g_name = "case";
  control_cols = sampleinfo_df[which(sampleinfo_df[,2]==expDesign_cc[which(expDesign_cc[,1]=="control"),2]),1];
  control_g_name = "control";
  sampleinfo_df[which(sampleinfo_df[,2]==expDesign_cc[which(expDesign_cc[,1]=="case"),2]),2] = "case";
  sampleinfo_df[which(sampleinfo_df[,2]==expDesign_cc[which(expDesign_cc[,1]=="control"),2]),2] = "control";
  sampleinfo_df_orig = sampleinfo_df;
}

if(mode=="logfold")
{
  sampleinfo_df = data.frame("Sample"= c("LogFold"), "Group"=c("Fold_Change"))
}

#===============================================================================
# Parse Transcriptome data
#===============================================================================
TE_df_orig = fread(transcriptome_file, sep="\t", stringsAsFactor=F, header=T) %>% data.frame();
if(mode=="multiple")
{
  TE_df = TE_df_orig[,c(colnames(TE_df_orig)[1],condition_cols,control_cols)];
}
if(mode=="logfold")
{
  TE_df = TE_df_orig;
  colnames(TE_df) = c("Genes", "LogFold");
}
#===============================================================================
# Parse Proteome data
#===============================================================================
PE_df_orig = fread(proteome_file, sep="\t", stringsAsFactor=F, header=T) %>% data.frame();
if(mode=="multiple")
{
  PE_df = PE_df_orig[,c(colnames(PE_df_orig)[1],condition_cols,control_cols)];
}
if(mode=="logfold")
{
  PE_df = PE_df_orig;
  colnames(PE_df) = c("Genes", "LogFold");
}

#=============================================================================================================
# Create directory structures and then set the working directory to output directory
#=============================================================================================================
if(! file.exists(outdir))
{
  dir.create(outdir);
}
#===============================================================================
# Write initial data summary in html outfile
#===============================================================================
cat("\n", file = htmloutfile);

cat("
QuanTP: Association between abundance ratios of transcript and protein

\n",
    "
Input data summary
\n",
    "
\n",
    "
Abbreviations used: PE (Proteome data) and TE (Transcriptome data)","

\n",
    "
Input Proteome data dimension (Row Column): ", dim(PE_df)[1]," x ", dim(PE_df)[2],"
\n",
    "
Input Transcriptome data dimension (Row Column): ", dim(TE_df)[1]," x ", dim(TE_df)[2],"

\n",
    file = htmloutfile, append = TRUE);

cat("
Table of Contents:
\n",
    "
\n",
    "
Sample distribution
\n",
    "
Correlation
\n",
    "
Regression analysis
\n",
    "
Influential observations
\n",
    "
Cluster analysis

\n",
    file = htmloutfile, append = TRUE);
#===============================================================================
# Find common samples
#===============================================================================
common_samples = intersect(sampleinfo_df[,1], colnames(TE_df)[-1]) %>% intersect(., colnames(PE_df)[-1]);

if(length(common_samples)==0)
{
  stop("No common samples found ");
  cat("Please check your experiment design file. Sample names (column names) in the Transcriptome and the Proteome data do not match. \n",file = htmloutfile, append = TRUE);
}

#===============================================================================
# Create subsets based on common samples
#===============================================================================
TE_df =  select(TE_df, 1, common_samples);
PE_df =  select(PE_df, 1, common_samples);
sampleinfo_df = filter(sampleinfo_df, Sample %in% common_samples);
rownames(sampleinfo_df) = sampleinfo_df[,1];

#===============================================================================
# Check for number of rows similarity
#===============================================================================
if(nrow(TE_df) != nrow(PE_df))
{
  stop("Number of rows in Transcriptome and Proteome data are not same i.e. they are not paired");
  cat("The correlation analysis expects paired TE and PE data i.e. (i)th gene/transcript of TE file should correspond to (i)th protein of PE file. In the current input provided there is mismatch in terms of number of rows of TE and PE file. Please make sure you provide paired data.\n",file = htmloutfile, append = TRUE);
}

#===============================================================================
# Number of groups
#===============================================================================
ngrps = unique(sampleinfo_df[,2]) %>% length();
grps = unique(sampleinfo_df[,2]);
names(grps) = grps;

#===============================================================================
# Change column1 name
#===============================================================================
colnames(TE_df)[1] = "Gene";
colnames(PE_df)[1] = "Protein";

#===============================================================================
# Treat missing values
#===============================================================================
TE_nacount = sum(is.na(TE_df));
PE_nacount = sum(is.na(PE_df));

TE_df[is.na(TE_df)] = 0;
PE_df[is.na(PE_df)] = 0;

#===============================================================================
# Obtain JS/HTML lines for interactive visualization
#===============================================================================
extractWidgetCode = function(outplot){
  lines <- readLines(gsub("\\.png", "\\.html", outplot))
  return(list(
    'prescripts'  = c('',
                      gsub('script', 'script',
                           lines[grep('',lines) + 3
                                 :grep('' ,lines) - 5]),
                      ''),
    'widget_div'  = paste('', sep=''),
    'postscripts' = paste('',
                          gsub('script', 'script',
                               lines[grep(lines, pattern='


library(pec)
data(GBSG2,package="pec")
GBSG2$tgrade <- as.factor(as.character(GBSG2$tgrade))
GBSG2$Age <- cut(GBSG2$age,c(0,40,60,81),labels=c("21-40","41-60","61-80"))

library(prodlim)
library(survival)

quantile(prodlim(Hist(time,cens)~1,data=GBSG2,reverse=TRUE))


## Author: Yunchuan Kong
## Copyright Reserved 2018

dyn.load("csupp.dll") ## uncomment if using Windows
# dyn.load("csupp.so") ## Uncomment if using Linux
# dyn.load("csupp_OS/csupp.so") ## Uncomment if using OS

source("utils.r")
source("visualize.r")

## Given data matrix "array" and supervised labels "GO.select"

hypergraph_unsup <- function(array, fdr=0.2, save_triplets=FALSE, save_glist=FALSE, cor_thres=1){

    dat <- deleteZeros(array)
    dat <- normalizeData(dat)

    nog=nrow(dat) ## number of genes
    nos=ncol(dat) ## number of samples
    glist=rownames(dat) ## gene name list
    clist=colnames(dat) ## sample name list
    rownames(dat)=1:nog ## re-name genes as numbers
    colnames(dat)=NULL

    corr=cor(t(dat))  ## pairwise correlation matrix
    dict <- penalizeCorr(corr, cor_thres)  ## "dictionary" for low correlated pairs
    diag(dict) <- 0

    triplets <- makeTriplets(nog, nos, dat, dict, fdr=fdr)
    # dim(triplets)

    A <- createFlow(triplets, nog, corMat=FALSE) ## usually don't calculate corMat here
    glist_new <- which(apply(A,2,sum)!=0)
    # cat(length(glist_new),"out of", dim(A)[1],".\n")
    corA <- cor(A[glist_new,glist_new]) ## calculate the correlation matrix for A here
    label_sub <- createLabels_unsup(1-corA)
    label <- matrix(0,ncol=ncol(label_sub),nrow=nrow(A))
    label[glist_new,] <- label_sub

    noc=ncol(label)-1 ## num of clusters
    labelSum <- apply(label[,1:noc],2,sum)
    net_vec<-shrink(triplets,label)
    fullNet_vec<-fullyConnect(labelSum)
    net<-normalize(noc,net_vec,fullNet_vec)
    r=sum(as.numeric(net_vec))/sum(as.numeric(fullNet_vec))
    net <- net/r
    net <- array(net,c(noc,noc,noc))

    res_unsup <- NULL
    res_unsup$net <- net
    res_unsup$label <- label
#     res_unsup$enrichment <- enrichment
    if (isTRUE(save_triplets)){
        res_unsup$triplets <- triplets
    }
    if (isTRUE(save_glist)){
        res_unsup$glist <- glist
    }
    return(res_unsup)
}

hypergraph_sup <- function(array, label_list, fdr=0.2, save_triplets=FALSE, save_glist=FALSE, cor_thres=1){

    dat <- deleteZeros(array)
    dat <- normalizeData(dat)

    nog=nrow(dat) ## number of genes
    nos=ncol(dat) ## number of samples
    glist=rownames(dat) ## gene name list
    clist=colnames(dat) ## sample name list
    rownames(dat)=1:nog ## re-name genes as numbers
    colnames(dat)=NULL

    corr=cor(t(dat))  ## pairwise correlation matrix
    dict <- penalizeCorr(corr, cor_thres)  ## "dictionary" for low correlated pairs
    diag(dict) <- 0

    triplets <- makeTriplets(nog, nos, dat, dict, fdr=fdr)

    label <- createLabels_sup(label_list, glist)

    noc=ncol(label)-1 ## num of clusters
    labelSum=apply(label[,1:noc],2,sum)
    net_vec<-shrink(triplets,label)
    fullNet_vec<-fullyConnect(labelSum)
    net<-normalize(noc,net_vec,fullNet_vec)
    r <- sum(as.numeric(net_vec))/sum(as.numeric(fullNet_vec))
    net <- net/r
    net <- array(net,c(noc,noc,noc))

    res_sup <- NULL
    res_sup$net <- net
    res_sup$label <- label
    if (isTRUE(save_triplets)){
        res_sup$triplets <- triplets
    }
    if (isTRUE(save_glist)){
        res_sup$glist <- glist
    }
    return(res_sup)
}


library(ComplexHeatmap)
library(circlize)

path = "../../data/"
for (i in list.files(path)) {
dataset <- read.csv(paste(path,i, sep=""))
colnames(dataset)[1]="X"
dataset <- dataset[!duplicated(dataset$X),]
row.names(dataset) <- dataset$X
dataset$X <- NULL
dataset <- as.matrix(dataset)

if (grepl("DSF", i) == TRUE){
  color = colorRamp2(c(-20, 0, 20), c("red", "white", "blue"))
}else {
  color = colorRamp2(c(-100, 0, 100), c("red", "white", "blue"))
}
len = length(unlist(strsplit(i,"\\_")))
svg(file=paste0("../Report",i,"_Pearson_unscaled.svg"),
    width=ifelse(dim(dataset)[2] > 300, 26.5 , ifelse(dim(dataset)[2] > 200, 16.5 , 7.25 )),
    height=ifelse(dim(dataset)[2] > 100, 8, 5))
print(Heatmap(dataset, name="Value",
        col = color,
        na_col = "grey",
        clustering_distance_rows = function(x)as.dist(1-cor(t(x), use="pairwise", method="pearson")),
        clustering_distance_columns = function(x)as.dist(1-cor(t(x), use="pairwise", method="pearson")),
        clustering_method_columns = "ward.D2", clustering_method_rows = "ward.D2",
        show_row_names = FALSE,
        column_title = paste0(unlist(strsplit(i,"\\_"))[1:len-1], collapse=" "),
        column_title_gp = gpar(fontsize=10, fontface="bold"),
        column_names_gp = gpar(fontsize=5),
        column_dend_height = unit(30, "mm")
))

dev.off()
}


# Load lmerTest
library(lmerTest)

# Fit a Poisson glmer
glmerOut <- glmer(clicks ~ webpage + (1|group), data=userGroups, family='poisson')

# Examine output with summary()
summary(glmerOut)


#' transform data.frame to stage.series type. The data type contains the information about stocks and flows
#'
#' @param x data.frame; input data
#' @param stages a vector of names of columns
#'
#' @return a stage.series object
#' @export
#'
#' @examples
#' library(TimePlotR)
#' dat.ss = as.stage.series(FourLevels, c('Lv1', 'Lv2', 'Lv3', 'Lv4'))
#' print(dat.ss)
#'
as.stage.series <- function(x, stages) {
  lvs <- lapply(stages, function(i) {
    d <- x[,i]
    if (is.factor(d)) {
      return (levels(d))
    } else {
      return (unique(d))
    }
  })
  names(lvs) <- stages

  factorised <- list()
  for (stage in stages) {
    # todo check existance
    factorised[[stage]] <- as.factor(x[, stage])
  }
  factorised <- data.frame(factorised)

  # Formulate flows
  flows <- data.frame(
    'StageSrc' = character(),
    'StageTar' = character(),
    'LevelSrc' = character(),
    'LevelTar' = character(),
    'Count' = integer()
  )

  # todo chisq test
  for (i in 1:(length(stages) - 1)) {
    stage.src <- stages[i]
    stage.tar <- stages[i + 1]
    transitions <-
      table(factorised[, stage.src], factorised[, stage.tar])
    transitions <- data.frame(transitions)
    colnames(transitions) <- c('LevelSrc', 'LevelTar', 'Count')
    transitions$StageSrc <- stage.src
    transitions$StageTar <- stage.tar
    flows <- rbind(flows, transitions)
  }

  flows <-
    flows[, c('StageSrc', 'LevelSrc', 'StageTar', 'LevelTar', 'Count')]

  # Formulate stocks
  stocks <- data.frame('Stage' = character(),
                       'Level' = character(),
                       'Count' = integer())

  for (stage in stages) {
    stock <- table(factorised[, stage])
    stock <- data.frame(stock)
    colnames(stock) <- c('Level', 'Count')
    stock$Stage <- stage
    stocks <- rbind(stocks, stock)
  }
  stocks <- stocks[, c('Stage', 'Level', 'Count')]

  res <- list(
    Data = factorised,
    Flows = flows,
    Stocks = stocks,
    Hierarchy = lvs
  )

  class(res) <- 'stage.series'
  res
}

print.stage.series <- function(ss) {
  cat('Number of sample:', nrow(ss$Data), '\n')
  cat('Stages:', names(ss$Hierarchy), '\n')
}

#' Sankey diagram with hierarchy. The diagram shows the flows between states of each pair of stages.
#'
#' @param x.ss a stage.series object
#' @param bar.width width of bars
#' @param bar.dist.min the minimal distance between bars in the same stage
#' @param xlab label of stages
#' @param ylab label of states or levels
#' @param band.col colour of flow bands
#' @param band.alpha opacity of flow bands
#'
#' @return hierarchical Sankey with ggplot
#' @export
#'
#' @examples
#' library(TimePlotR)
#'
#' dat.ss = as.stage.series(FourLevels, c('Lv1', 'Lv2', 'Lv3', 'Lv4'))
#' plt <- hierarchical.sankey(dat.ss, bar.dist.min = 20, band.col = "darkgreen")
#' plt
#'
#' ## Apply customised colour palette
#' plt <- plt + scale_fill_brewer(palette="Spectral")
#' plt
#'
hierarchical.sankey <-
  function(x.ss,
           bar.width = 10,
           bar.dist.min = 10,
           xlab = 'Stage',
           ylab = 'State',
           band.col = 'green',
           band.alpha = 0.3) {
    hier <- x.ss$Hierarchy
    # Prepare graphic parameters
    sts <- names(hier)
    sts.n <- length(sts)
    sts.size <- sapply(hier, length)
    sts.size.max <- max(sts.size)

    bar.height.total <- 50 * sts.size.max
    interval <- 80
    height <- bar.height.total + (sts.size.max - 1) * bar.dist.min
    width <- sts.n * bar.width + (sts.n - 1) * interval

    # locate stock bars
    stocks <- x.ss$Stocks
    stocks <- cbind(
      stocks,
      x0 = -1,
      x1 = -1,
      y0 = -1,
      y1 = -1
    )
    stocks$Level <- as.character(stocks$Level)

    for (i in 1:sts.n) {
      lv <- sts[i]
      nodes.n <- sts.size[i]
      cnts <- stocks[stocks$Stage == lv, ]$Count
      hei <- bar.height.total * cnts / sum(cnts)
      pad <- (height - bar.height.total) / (nodes.n - 1)
      x0 <- (i - 1) * (bar.width + interval)
      y0 <- cumsum(c(0, (hei + pad)[-nodes.n]))

      stocks[stocks$Stage == lv, 'x0'] <- x0
      stocks[stocks$Stage == lv, 'y0'] <- y0
      stocks[stocks$Stage == lv, 'y1'] <- y0 + hei
    }
    stocks$x1 <- stocks$x0 + bar.width

    # locate flow bands
    flows <- x.ss$Flows
    flows <- cbind(
      flows,
      x0 = -1,
      x1 = -1,
      y0s = -1,
      y1s = -1,
      y0t = -1,
      y1t = -1
    )
    for (stage in sts) {
      flows[flows$StageSrc == stage, 'x0'] <-
        stocks[stocks$Stage == stage, 'x1']
      flows[flows$StageTar == stage, 'x1'] <-
        stocks[stocks$Stage == stage, 'x0']
    }

    dis <- function(y0, y1, ns) {
      int <- (y1 - y0) / sum(ns) * ns
      cint <- cumsum(int)
      cbind(y0 + cint - int, y0 + cint)
    }

    for (j in 1:nrow(stocks)) {
      stock <- stocks[j,]
      with(stock, {
        flow.sel <-
          flows[flows$StageSrc == Stage & flows$LevelSrc == Level,]
        if (nrow(flow.sel)) {
          ns <- flow.sel$Count
          flows[flows$StageSrc == Stage &
                  flows$LevelSrc == Level, c('y0s', 'y1s')] <<-
            dis(y0, y1, ns)
        }

        flow.sel <-
          flows[flows$StageTar == Stage & flows$LevelTar == Level,]
        if (nrow(flow.sel)) {
          ns <- flow.sel$Count
          flows[flows$StageTar == Stage &
                  flows$LevelTar == Level, c('y0t', 'y1t')] <<-
            dis(y0, y1, ns)
        }
      })
    }

    # Make the graph
    plt <- ggplot2::ggplot(data = stocks) +
      ggplot2::geom_rect(ggplot2::aes(
        xmin = x0,
        xmax = x1,
        ymin = y0,
        ymax = y1,
        fill = Level
      )) +
      ggplot2::geom_text(ggplot2::aes(
        x = (x0 + x1) / 2,
        y = (y0 + y1) / 2,
        label = Level
      ), alpha=0.7)

    dat <- unique(stocks[c('Stage', 'x0', 'x1')])
    plt <-
      plt + ggplot2::scale_x_continuous(breaks = (dat$x0 + dat$x1) / 2, label = dat$Stage)

    n.step <- 50
    for (i in 1:nrow(flows)) {
      plt <- plt + with(flows[i,], {
        xx <- seq(-pi / 2, pi / 2, length.out = n.step)
        ys.upper <- y0s + (y0t - y0s) / 2 * (sin(xx) + 1)
        ys.lower <- y1s + (y1t - y1s) / 2 * (sin(xx) + 1)
        xs <- seq(x0, x1, length.out = n.step)
        dat <- data.frame(xs, ys.lower, ys.upper)
        ggplot2::geom_ribbon(
          ggplot2::aes(
            x = xs,
            ymin = ys.lower,
            ymax = ys.upper
          ),
          fill = band.col,
          alpha = band.alpha,
          data = dat
        )
      })
    }

    plt <- plt + ggplot2::labs(x = xlab, y = ylab) +
      ggplot2::theme(
        legend.position = "none",
        axis.text.y = ggplot2::element_blank(),
        axis.text.x = ggplot2::element_text(face = "bold")
      )

    plt
  }


rm(list=ls())
library(dplyr)
library(ggplot2)
library(tidyr)
library(ggpubr)
library(stats)
library(tibble)

# set dataset

dataset <- "Burbrink"

setwd(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset, sep=''))

# Read in data
load(paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/Calcs_",dataset,".RData", sep=''))

metaData <- c("MEAN_COL_SCORE","Sequences","Columns","Dist_Pat","Pars_Info","Sing_Sites","Cons_Sites" ,"Chi2_Fail","Gaps_Ambig")

# Add column to name type of support
mLGL <- mutate(mLGL, supportType = case_when(TvS != 'a' ~ "dGLS"))
mLBF <- mutate(mLBF, supportType = case_when(TvS != 'a' ~ "BF"))

# Change from 2ln(BF) to ln(BF) by dividing all comparisons by 2 7-10
mLBF[7:10] <- mLBF[7:10]/2
# for singhal OG
#mLBF[4] <- mLBF[4]/2

# Check number of NA
sum(is.na(mLBF$MEAN_COL_SCORE))

# Transform datasets - stack two comparisons, and add column for bf and gl
# Each dataset one hypothesis

reformatdf <- function(df,h,h1,s1,keepCols){
  # keepCols is a vector of the locus and support type column indices
  # Grab column number
  c1 <- match(h1,names(df))
  # Grab and rename column, add hypothesis column
  a.df <- df[,append(keepCols,c1)]
  names(a.df)[names(a.df) == h1] <- h
  a.df$Hypothesis <- rep(h1,length(a.df[,1]))
  c <- match(h,names(a.df))
  # Adjust direction of support if needed. ie if column is AIvSA, but you want to know SAvAI
  a.df[,c] <- a.df[,c]*(s1)
  return(a.df)
}

keep <- c(1,seq(14,22))

B <- bind_rows(reformatdf(mLBF,"BF","AIvSA",1,keep),
               reformatdf(mLBF,"BF","AIvSI",1,keep),
               reformatdf(mLBF,"BF","SAvSI",1,keep),
               reformatdf(mLBF,"BF","TvS",1,keep))

G <- bind_rows(reformatdf(mLGL,"GL","AIvSA",1,keep),
               reformatdf(mLGL,"GL","AIvSI",1,keep),
               reformatdf(mLGL,"GL","SAvSI",1,keep),
               reformatdf(mLGL,"GL","TvS",1,keep))

# for SinghalOG
#keep <- c(1,seq(5,13))
#B <- reformatdf(mLBF,"BF","TvS",1,keep)
#G <- reformatdf(mLGL,"GL","TvS",1,keep)

metaData <- c("MEAN_COL_SCORE","Sequences","Columns","Dist_Pat","Pars_Info","Sing_Sites","Cons_Sites" ,"Chi2_Fail","Gaps_Ambig")
all <- left_join(B, G, by=c("Locus","Hypothesis",metaData), suffix = c(".g", ".b"))

##################################################################################################
## Test correlation across all hypotheses
##################################################################################################
# http://www.sthda.com/english/wiki/correlation-test-between-two-variables-in-r
# https://rpubs.com/aaronsc32/spearman-rank-correlation
# Run from current line to document end 	Ctrl+Alt+E

rm(null,null_rs,new,sig2tp05,emp_rs,a,h)
h <- 'TvS'
#h <- 'AIvSA'
#h <- 'AIvSI'
#h <- 'SAvSI'
a <- all[all$Hypothesis == h,]

# start with all the meta data

null <- a %>% select(c(Locus,Hypothesis,metaData,BF,GL))

# Permute BF and GL in 1,000 seperate columns

for (n in 1:1000) {
  newcolname1 <- paste('BF',n,sep='')
  null[, newcolname1] <- sample(a$BF, replace = FALSE)
  newcolname2 <- paste('GL',n,sep='')
  null[, newcolname2] <- sample(a$GL, replace = FALSE)
}

# Create new dataset for spearman rank coefficients

assign('null_rs', setNames(data.frame(1:1000), "replicate"))

# for meta data

for (x in metaData) {
  null_rs[,paste(x,'.b.null',sep='')] <- NA
  null_rs[,paste(x,'.g.null',sep='')] <- NA
}

# then for bf and gl - these should end up the same

null_rs[,'GL.b.null'] <- NA # bf replicated, gl same
null_rs[,'BF.g.null'] <- NA # gl replicated, bf same

# Add bf gl

for (n in 1:1000) {

  # Grab column names, calculate value
  colname1 <- paste('BF',n,sep='')
  cc1 <- cor(null[,'GL'],null[,colname1],method="spearman")
  nullcol1 <- paste('GL','.b.null',sep='')
  null_rs[n,nullcol1] <- cc1
  colname2 <- paste('GL',n,sep='')
  cc2 <- cor(null[,'BF'],null[,colname2],method="spearman")
  nullcol2 <- paste('BF','.g.null',sep='')
  null_rs[n,nullcol2] <- cc2

}

for (i in metaData) {

  # Calculate rs for all permuted columns in null dataset

  for (n in 1:1000) {

    # Grab column names, calculate value
    colname1 <- paste('BF',n,sep='')
    cc1 <- cor(null[,i],null[,colname1],method="spearman")
    nullcol1 <- paste(i,'.b.null',sep='')
    null_rs[n,nullcol1] <- cc1
    colname2 <- paste('GL',n,sep='')
    cc2 <- cor(null[,i],null[,colname2],method="spearman")
    nullcol2 <- paste(i,'.g.null',sep='')
    null_rs[n,nullcol2] <- cc2

  }
}

save(all,null,null_rs, file=paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_CorrNullDist_",h,".RData",sep=''))
#save(null_rs, file=paste("/Users/ChatNoir/Projects/Squam/scripts/Graphing/",dataset,"_CorrNullDist_",h,"_rs.RData",sep=''))

#load("/Users/ChatNoir/Projects/Squam/scripts/Graphing/CorrelationNullDist_rs.RData")

# Add row of emp scores

assign('emp_rs', setNames(data.frame('emp'), "replicate"))
empRow <- 1

# First bf and gl

# Grab column names, calculate value for BF GL there is only one value for both columns

i <- "BF"
cc1 <- cor(a[,i],a[,'GL'],method="spearman")
empcol1 <- paste(i,'.g.emp',sep='')
emp_rs[empRow,empcol1] <- cc1
i <- "GL"
empcol2 <- paste(i,'.b.emp',sep='')
emp_rs[empRow,empcol2] <- cc1

# Add all metadata emp for BF and GL

metaData <- c("MEAN_COL_SCORE","Sequences","Columns","Dist_Pat","Pars_Info","Sing_Sites","Cons_Sites" ,"Chi2_Fail","Gaps_Ambig")

for (i in metaData) {
  cc1 <- cor(a[,i],a[,'GL'],method="spearman")
  empcol1 <- paste(i,'.g.emp',sep='')
  emp_rs[empRow,empcol1] <- cc1
  cc2 <- cor(all[,i],all[,'BF'],method="spearman")
  empcol2 <- paste(i,'.b.emp',sep='')
  emp_rs[empRow,empcol2] <- cc2
}

# Add rows for quantile cut offs

emp_rs$replicate <- as.character(emp_rs$replicate)
emp_rs[2,1] <- "p0.025"
emp_rs[3,1] <- "p0.975"

# add gl and bf

emp_rs[2,'GL.b.emp'] <- quantile(null_rs$BF.g.null, c(0.025, 0.975))[[1]]
emp_rs[3,'GL.b.emp'] <- quantile(null_rs$BF.g.null, c(0.025, 0.975))[[2]]
emp_rs[2,'BF.g.emp'] <- quantile(null_rs$GL.b.null, c(0.025, 0.975))[[1]]
emp_rs[3,'BF.g.emp'] <- quantile(null_rs$GL.b.null, c(0.025, 0.975))[[2]]

for (i in metaData) {
  gl.n <- paste(i,'.g.null',sep='')
  gl.e <- paste(i,'.g.emp',sep='')
  g025 <- quantile(null_rs[,gl.n], c(0.025, 0.975))[[1]]
  g975 <- quantile(null_rs[,gl.n], c(0.025, 0.975))[[2]]
  emp_rs[2,gl.e] <- g025
  emp_rs[3,gl.e] <- g975
  bf.n <- paste(i,'.b.null',sep='')
  bf.e <- paste(i,'.b.emp',sep='')
  b025 <- quantile(null_rs[,bf.n], c(0.025, 0.975))[[1]]
  b975 <- quantile(null_rs[,bf.n], c(0.025, 0.975))[[2]]
  emp_rs[2,bf.e] <- b025
  emp_rs[3,bf.e] <- b975
}

# Create two boolean rows for significance

# Transform dataset from rows to columns

new <- data.frame(t(emp_rs))
colnames(new) <- as.character(unlist(new[1,]))
new <- new[-1,]
new$emp <- as.numeric(as.character(new$emp))
new$p0.025 <- as.numeric(as.character(new$p0.025))
new$p0.975 <- as.numeric(as.character(new$p0.975))
sig2tp05 <- new %>% rownames_to_column('metaData') %>%
  mutate(sig = case_when(emp < p0.025 ~ "Lower",
                                       emp > p0.975 ~ "Upper",
                                    emp >= p0.025 & emp <= p0.975 ~ "False"))

# Save null and emp rs as backup
save(null_rs, emp_rs, sig2tp05,  file=paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_Corr_",h,"_rsvals.RData",sep=''))

# Save each hypothesis to output in xlxs sheet for each dataset

assign(h, sig2tp05)

#ctrl shift c - to uncomment. then run at end
#https://stackoverflow.com/questions/48799959/r-reduce-with-merge-and-more-than-2-suffixes-or-how-to-merge-multiple-datafr
#Merge all datasets

list.df <- list(TvS,AIvSA,AIvSI,SAvSI)
sfx <- c("_TvS", "_AIvSA", "_AIvSI", "_SAvSI")
res <- list.df[[1]]
for(i in head(seq_along(list.df), -1)) {

  res <- merge(res, list.df[[i+1]], all = TRUE,
               suffixes = sfx[i:(i+1)], by = c("metaData"))
}

# output excel sheet

library(xlsx)

fname <- paste("/Users/ChatNoir/Projects/Squam/Graphs/",dataset,"/",dataset,"_correlation.xlsx",sep='')

write.xlsx2(as.data.frame(res), file=fname, sheetName="ALL", row.names=FALSE)
write.xlsx2(as.data.frame(TvS), file=fname, sheetName="TvS", append=TRUE, row.names=FALSE)
write.xlsx2(as.data.frame(AIvSA), file=fname, sheetName="AIvSA", append=TRUE, row.names=FALSE)
write.xlsx2(as.data.frame(AIvSI), file=fname, sheetName="AIvSI", append=TRUE, row.names=FALSE)
write.xlsx2(as.data.frame(SAvSI), file=fname, sheetName="SAvSI", append=TRUE, row.names=FALSE)


# Global procedures

## Load the data
loadData()

## Generate computed columns
computeColumns()

# Annual CPI (sourced from ABS - http://www.abs.gov.au/AUSSTATS/abs@.nsf/DetailsPage/6401.0Jun%202013#Time, Table 2)
baseYear <- 85
cpiJune67 = cpi$Index.Numbers....All.groups.CPI....Australia[baseYear]
cpiJune67

# # Loop in multiples of 4 for each year's figure
lastYear <- baseYear + 46 * 4
cpiJune13 = cpi$Index.Numbers....All.groups.CPI....Australia[lastYear]
cpiJune13

lastYear <- baseYear + 32 * 4
cpiJune99 = cpi$Index.Numbers....All.groups.CPI....Australia[lastYear]
cpiJune99


## * Utilities

upper1st <- function(x) {
    if (is.factor(x))
        x0 <- levels(x) else x0 <- as.character(x)
    nc <- nchar(x0)
    x0[nc > 1] <- sprintf('%s%s', toupper(substr(x0[nc > 1], 1, 1)), substr(x0[nc > 1], 2, nchar(x0[nc > 1])))
    x0[nc == 1] <- toupper(x0[nc == 1])
    if (is.factor(x))
        levels(x) <- x0 else x <- x0
    return(x)
}

slugify <- function(x) {
    gsub(' +', '_', gsub('\'', '', tolower(x)))
}

## * Statistical

estBetaParams <- function(mu, var) {
    ## Estimate alpha and beta of beta distribution from mean and variance
    ## from http://stats.stackexchange.com/questions/12232/calculating-the-parameters-of-a-beta-distribution-using-the-mean-and-variance
    alpha <- ((1 - mu) / var - 1 / mu) * mu ^ 2
    beta <- alpha * (1 / mu - 1)
    return(params = list(alpha = alpha, beta = beta))
}

## * For PST

## ** Rmax formula from Niel & Lebreton 2008
funNL<- function(x,a,s) (exp((a+s/(x-s))^-1)-x)^2
lmax_nl <- function(a,s) return(optimise(funNL, c(1,2), a=a, s=s, tol=1e-10)$minimum)
Lmax_nl <- function(a,s,usemc=F) {
    if (usemc) {
        library(parallel)
        return(mcmapply(lmax_nl, a, s))
    } else return(mapply(lmax_nl, a, s))
}
Rmax_NL <- function(s,a,...) return(Lmax_nl(a,s,...)-1)

## * For PST

## formula from Neil & Lebreton 2008
funNL<- function(x,a,s) (exp((a+s/(x-s))^-1)-x)^2
lmax_nl <- function(a,s) return(optimise(funNL, c(1,2), a=a, s=s, tol=1e-10)$minimum)
Lmax_nl <- function(a,s,usemc=F) {
    if (usemc) {
        library(parallel)
        return(mcmapply(lmax_nl, a, s))
    } else return(mapply(lmax_nl, a, s))
}
Rmax_NL <- function(s,a,...) return(Lmax_nl(a,s,...)-1)

 ## Survival variation
surv_var_norm_mean_se <- function(n=1000, smean, sse)
    {
    se_beta <- sse/(smean*(1-smean)) ## calculate se(beta(S)) from se(S), uses delta method
    logit_s <- rnorm(n=n, mean=log(smean/(1-smean)), sd=se_beta) ## apply normal variation to logit(s)
    surv <- exp(logit_s)/(1+exp(logit_s)) ## back-transform
    return(surv)
    }
## surv_var_norm_mean_se1 <- Vectorize(surv_var_norm_mean_se0, SIMPLIFY=F)
## surv_var_norm_mean_se <- function(n=1000, smean, sse)
##   do.call('rbind', surv_var_norm_mean_se1(n=1000, smean, sse))

surv_ci0 <- function(smean, sse)
    {
    se_beta <- sse/(smean*(1-smean)) ## calculate se(beta(S)) from se(S)
    logit_s <- log(smean/(1-smean))
    ll <- logit_s-1.96*se_beta
    ul <- logit_s+1.96*se_beta
    ll <- exp(ll) / (1 + exp(ll))
    ul <- exp(ul) / (1 + exp(ul))
    return(data.frame(ll=ll, ul=ul))
    }
surv_ci1 <- Vectorize(surv_ci0, SIMPLIFY=F)
surv_ci <- function(smean, sse)  do.call('rbind', surv_ci1(smean, sse))

surv_meansd_from_ci0 <- function(lcl, ucl)
    {
    logitlcl <- log(lcl/(1-lcl))
    logitucl <- log(ucl/(1-ucl))
    sdlogit <- (logitucl-logitlcl) / (2*1.96)
    meanlogit <- mean(c(logitlcl,logitucl))
    mean <- exp(meanlogit)/(1+exp(meanlogit))
    sd <- sdlogit*(mean*(1-mean))
    return(data.frame(mean=mean, sd=sd))
    }
surv_meansd_from_ci1 <- Vectorize(surv_meansd_from_ci0, SIMPLIFY=F)
surv_meansd_from_ci <- function(lcl, ucl)  do.call('rbind', surv_meansd_from_ci1(lcl, ucl))

ntot2 <- function(Nadtot, surv, afr, nsims=4000) {
    if (length(Nadtot)==1 | is.null(names(Nadtot))) {
        n <- Nadtot
    } else { ## point estimate or vector of samples
	if (all(names(Nadtot)==c('mean','se'))) { ## mean-se
	    n <- surv_var_norm_mean_se(nsims, smean=Nadtot['mean'], sse=Nadtot['se'])
        } else {
            if (prod(names(Nadtot)==c('min','max'))) { ## min-max
                n <- runif(nsims, min=Nadtot['min'], max=Nadtot['max'])
            }
        }
    }
    if (length(surv)==1 | is.null(names(surv))) {
        s <- surv
    } else {
	if (prod(names(surv)==c('mean','se'))) {
	    s <- surv_var_norm_mean_se(nsims, smean=surv['mean'], sse=surv['se'])
        } else {
            if (prod(names(surv)==c('min','max'))) {
                s <- runif(nsims, min=surv['min'], max=surv['max'])
            }
        }
    }
    if (length(afr)==1 | is.null(names(afr))) {
        a <- afr
    } else {
	if (prod(names(afr)==c('mean','se'))) {
	    a <- rnorm(nsims, mean=afr['mean'], sd=afr['se'])
        } else {
            if (prod(names(afr)==c('min','max'))) {
                a <- runif(nsims, min=afr['min'], max=afr['max'])
            }
        }
    }

    ## maximum age
    m=1+log(0.02)/log(s)

    ## Indiv/adult ratio
    r = s^(1-a)

    ## Total population
    ntot = n*r

    if (min(ntot)<0)
    print('===================================>>>  WARNING!!! Minimum of Ntot is negative!')

    return(list(all=ntot, min=quantile(ntot,0.2), s=s, a=a, r=r, m=m))
    ## for min: take the lower 60 percentile, following Wade
}

## * South Pole-centered map of grid values

map_grid_values <- function(grid_values, legend.title='', colourscale.trans='log1p', zeros_to_na=T,
                            leg.pos = c(0.95, 0.15),
                            pal=c("#E3F2FD","#BBDEFB","#90CAF9","#64B5F6","#42A5F5","#2196F3","#1E88E5","#1976D2","#1565C0","#0D47A1"),
                            bg.col = 'grey95', graticule.col = '#B0B0B0',
                            highlighted.lat = NA, highlighted.lat.col = 'grey', min0=T, grid = grid_noland, ...) {

    suppressPackageStartupMessages({
        library(data.table)
        library(ggplot2)
        library(colorspace)
        library(sf)
    })
    if (ncol(grid_values) != 2)
        stop('`grid_values` needs to have two columns only: grid ids and values')

    if (any(duplicated(grid_values$grid_id)))
        stop('Duplicated `grid_id` values')

    grid_values <- copy(grid_values)
    setDT(grid_values)
    setnames(grid_values, c('grid_id', 'value'))

    values <- grid_values[match(grid$grid_id, grid_id), value]
    if (zeros_to_na) {
        values[values == 0] <- NA
    }
    grid$value <- values

    logtrans <- grepl('log', colourscale.trans)
    if (logtrans) {

        mx <- max(pretty(c(0, max(grid$value, na.rm=T))))
        z <- round(mx / (10^(-10:10)))
        z <- (-10:10)[min(which(z > 0 & nchar(z) == 1))]
        brks <- c(1, 3) * rep(10^((z-1):z), each=2)

    } else {
        brks <- pretty(grid$value)
    }
    if (min0) {
        brks <- unique(c(0, brks))
    }

    bb <- st_bbox(grid)
    world <- suppressMessages(st_crop(oneworld, bb))
    world <- st_segmentize(world, 100000)

    g <- ggplot() +
        geom_sf(data=grid, aes(fill = value), colour = graticule.col, size = 0.1) +
        scale_fill_gradientn(colours = pal, name = legend.title,
                             na.value='white', limits = c(0, max(brks)),
                             trans = colourscale.trans, breaks = brks)

    if (!is.na(highlighted.lat)) {
        hlat <- st_as_sf(as(SpatialLines(list(Lines(list(Line(cbind(x = seq(0, 360, 1),
                                                                    y = rep(highlighted.lat, 361)))), ID=1)),
                               proj4string=CRS("+init=epsg:4326 +over")), 'SpatialLines'))
        g <- g + geom_sf(dat = hlat, colour = 'grey')
    }

    g <- g +
        ## ** world
        geom_sf(data = world, fill = '#AAAAAA', colour = NA, size = 0.1) +
        theme_void() +
        theme(plot.margin = unit(rep(3, 4), 'mm'),
              legend.position=leg.pos,
              legend.margin = margin(5, 2, 2, 2, unit='mm'),
              legend.background=element_rect(fill = '#FFFFFF44'),
              legend.title.align = 0,
              legend.text.align = 0,
              legend.key.width = unit(0.5, 'cm'),
              plot.background = element_rect(fill = bg.col)) +
        coord_sf(crs="+proj=ortho +y_0=0 +lon_0=178 +lat_0=-90.0", expand=F, datum=NA)

    return(g)
}


#' Function to cluster standard errors for linear models
#'
#' @export
#' @author Sean Brunson
#'
#' @examples
#' \dontrun{
#' model <- lm_cluster(data=data, formula=y ~ x, cluster="cluster_id")
#'
#' }

lm_cluster <- function(data, formula, cluster){
    # Fit linear model:
    model <- stats::lm(data = data, formula = formula)

    # Compute standard errors:
    vcov <- sandwich::vcovCL(x = model, cluster = data[cluster], type = "HC0")

    # Get summary of results:
    coeffs <- broom::tidy(lmtest::coeftest(model, vcov = vcov))
    stats <- broom::glance(model) %>%
        mutate(n = nrow(model$model))

    list(coeffs = coeffs,
         stats = stats)
}


 values=c(7,6,5,4,3,2,1,0)
 indices=c(7,2,8)
 values[sort(indices)]=sort(values[indices])
 print(values)


pGumbel <- function (q, mu = 0, sigma = 1){
  stopifnot(sigma > 0)
  exp(-exp(-((q - mu)/sigma)))
}

#' Take a random draw from a variable variable
#' @param obj Model object of class `lm`, `glm`, `polr` or `multinom`
#' @param data Data frame giving variables used to estimate model
#' @param ret For return a draw from the variable or return the probabilities.
#' @param incl_b_var Logical indicating whether the sampling variable of
#' the coefficients should be incorporated into the simulation.
#' @param ... Other arguments to be passed down, currently not implemented.
#'
#' @importFrom MASS mvrnorm
#' @importFrom stats model.matrix coef vcov rmultinom rbinom rnorm plogis family formula pcauchy pnorm
#' @export
draw_val <- function(obj,
                     data,
                     ret=c("draw", "expected"),
                     incl_b_var = TRUE,
                     ...){
  ret <- match.arg(ret)
  X <- model.matrix(formula(obj), data)
  if(inherits(obj, "multinom")){
    b <- c(t(coef(obj)))
    if(incl_b_var){
      B <- mvrnorm(1, b, vcov(obj))
      B <- cbind(0, matrix(B, ncol=(length(obj$lev)-1)))
    }else{
      B <- cbind(0, t(coef(obj)))
    }
    xb <- X %*% B
    prob <- prop.table(exp(xb), 1)
    tmp <- sapply(1:nrow(prob), function(i)rmultinom(1, 1, prob[i,])  )
    out <- factor(apply(tmp, 2, which.max),
                  levels=1:length(obj$lev),
                  labels=obj$lev)

  }
  if(inherits(obj, "polr")){
    cdf <- switch(obj$method,
                  logistic = plogis,
                  probit = pnorm,
                  cloglog = pGumbel,
                  cauchit = pcauchy)

    X <- X[,-1]
    b <- c(coef(obj), obj$zeta)
    if(incl_b_var){
      B <- mvrnorm(1, b, vcov(obj))
      Z <- B[grep("\\|", names(B))]
      B <- B[-grep("\\|", names(B))]
    }else{
      B <- coef(obj)
      Z <- obj$zeta
    }
    xb <- X %*% B
    Z <- c(-Inf, Z, Inf)
    qs <- sapply(Z, function(z)cdf(z-xb))
    prob <- sapply(2:ncol(qs), function(i)qs[,i] - qs[,(i-1)])
    tmp <- sapply(1:nrow(prob), function(i)rmultinom(1, 1, prob[i,])  )
    out <- factor(apply(tmp, 2, which.max),
                  levels=1:length(obj$lev),
                  labels=obj$lev)
  }
  if(inherits(obj, "glm")){
    if(family(obj)$family == "binomial"){
      if(incl_b_var){
        b <- mvrnorm(1, coef(obj),vcov(obj))
      }else{
        b <- coef(obj)
      }
      prob <- family(obj)$linkinv(X %*% b)
      out <- rbinom(length(prob), 1, prob)
    }else{
      stop(paste0("GLM family ", family(obj)$family, " not currently supported.\n"))
    }
  }
  if(inherits(obj, "lm") & !inherits(obj, "glm")){
    if(incl_b_var){
      b <- mvrnorm(1, coef(obj),vcov(obj))
    }else{
      b <- coef(obj)
    }
    prob <- X %*% b
    out <- rnorm(nrow(X), prob, summary(obj)$sigma)
  }
  if(ret == "draw"){
    out
  }else{
    prob
  }
}

#' Find type of variable
#'
#' Find the variable type to identify the appropriate model for the variable
#'
#' @param x a vector of values to be evaluated
#' @param ... other arguments to be passed down, currently not implemented.
#'
#' @importFrom stats na.omit
#' @export
find_type <- function(x, ...){
  if(is.numeric(x) & length(unique(na.omit(x))) > 2){
    type <- "lm"
  }
  if(length(unique(na.omit(x))) == 2 & !is.character(x)){
    type <- "glm"
  }
  if(is.factor(x)){
    if(is.ordered(x)){
      type <- "polr"
    }else{
      type <- "multinom"
    }
  }
  type
}

#' Specify a Vote Path Analysis
#'
#' The vote path model estimates independent models that would otherwise use a block-recursive
#' structure.  Each model in each block is fit independently using the appropriate error distribution.
#'
#' @param blocks A list in which each element contains a vector of variable names for variables that will represent
#' that block's effects.  The list may be named or not.
#' @param models If `NULL`, the algorithm will use `find_type()` to find the appropriate model.  This assumes that variables
#' that should be estimated using ordinal regression models are ordered factors.  Otherwise, models can be a named vector of
#' model types for some or all of the variables included in the model.
#' @param data A data frame containing all of the variables in the `blocks` list.
#' @param ... Other arguments to be passed down.
#'
#' @importFrom stats lm glm family binomial reformulate
#' @importFrom MASS polr
#' @importFrom nnet multinom
#'
#' @export
vote_path <- function(blocks,
                      models = NULL,
                      data, ...){

  types <- sapply(c(unlist(blocks)), function(nm)find_type(data[[nm]]))
  allvars <- c(unlist(blocks))
  dv <- allvars[length(allvars)]
  if(!is.null(models)){
    types[match(names(models), names(types))] <- models
  }
  res <- vector(mode="list", length=length(blocks)-1)
  for(i in 2:(length(blocks)-1)){
    mlist <- vector(mode="list", length=length(blocks[[i]]))
    for(j in 1:length(blocks[[i]])){
      form <- reformulate(blocks[[(i-1)]], response=blocks[[i]][j])
      arglist <- list(formula = form, data=data)
      if(types[blocks[[i]][j]] %in% c("polr", "multinom")){
        arglist$Hess <- TRUE
      }
      if(types[blocks[[i]][j]] == "multinom"){
        arglist$maxit <- 250
      }
      if(types[blocks[[i]][j]] == "glm"){
        arglist$family <- binomial
      }
      mlist[[j]] <- do.call(types[blocks[[i]][j]], arglist)
      }
    res[[(i-1)]] <- mlist
  }
  fullform <- reformulate(allvars[-length(allvars)],
                          response=dv)
  arglist <- list(formula = fullform,
                  data=data)
  if(types[dv] %in% c("polr", "multinom")){
    arglist$Hess <- TRUE
  }
  if(types[dv] == "multinom"){
    arglist$maxit <- 250
  }
  if(types[dv] == "glm"){
    arglist$family <- binomial
  }
  res[[(length(blocks)-1)]] <- do.call(types[dv], arglist)
  out <- list(models = res, blocks = blocks)
  class(out) <- "votepath"
  out
}

#' Simulate Variable Effect
#'
#' Simulate a variable's effect in a vote path analysis.
#'
#' @param obj An object of class `votepath`
#' @param data A data frame that contains all of the variables form the analysis.
#' @param varname The name of a variable whose effect will be evaluated.
#' @param diffchange The amount to change `varname`.  Changes will be `x-.5*diffchange` and `x+.5*diffchange`.
#' For categorical variables, the first and last categories will be chosen.  The `diffchange` parameter
#' defines the change so long as `vals=NULL`.  If `vals` is not `NULL`, then those values will be used for everyone.
#' @param vals A vector of length 2 giving the values that will be used to evaluate the effect size.  This will override
#' `diffchange`.  The values must be of the same class as the variable being changed.  For example, if the variable being
#' changed is a factor, the `vals` vector also has to be a factor with the same levels as the variable in `varname`.
#' @param b_var Logical indicating whether sampling variability on the coefficients should be incorporated in the simulation.
#' @param R Number of simulations to be conducted.
#' @param lastMod Should the prediction from the last model be a draw or a the expected value?
#' @param ... Other arguments to be passed down.
#'
#' @importFrom progress progress_bar
#' @importFrom stats sd
#' @export
#'
#'
#'
sim_effect <- function(obj,
                       data,
                       varname,
                       diffchange=c("unit", "sd"),
                       vals=NULL,
                       b_var = TRUE,
                       R=100,
                       lastMod = c("expected", "draw"),
                       ...){
  mods <- obj$models
  blocks <- obj$blocks
  lastMod <- match.arg(lastMod)
  dv <- blocks[[length(blocks)]]
  out_i <- out_d <- out_t <- out_br <-  NULL
  pb <- progress_bar$new(total = R)
  if(!is.null(vals) & length(vals) != 2)stop("vals must be a vector of length 2\n")
  if(!is.null(vals) & inherits(data[[varname]], "factor") & !inherits(vals, "factor"))stop("vals must have the same class as varname\n")
  which_block <- min(which(sapply(blocks, function(x)max(varname == x)) == 1))
  if(is.factor(data[[varname]]) & is.null(vals)){
    levs <- levels(data[[varname]])
    vals <- factor(c(1,length(levs)),
                   levels=1:length(levs),
                   labels=levs)
  }
  med <- vector(mode="list", length=length((which_block+1):(length(blocks)-1)))
  brvars <- c(unlist(blocks[1:which_block]))
  br_form <- reformulate(brvars, response=dv)
  dv_type <- find_type(data[[dv]])
  br_args <- list(formula = br_form, data=data)
  if(dv_type %in% c("polr", "multinom")){
    br_args$Hess <- TRUE
  }
  if(dv_type == "multinom"){
    br_args$maxit <- 250
  }
  if(dv_type == "glm"){
    br_args$family <- binomial
  }
  br_mod <- do.call(dv_type, br_args)

  for(r in 1:R){
  new_0 <- new_1 <- br_0 <- br_1 <- data
  if(is.null(vals)){
    delta <- ifelse(diffchange == "sd", sd(data[[varname]], na.rm=TRUE), 1)
    new_0[[varname]] <- br_0[[varname]] <- new_0[[varname]] - .5*delta
    new_1[[varname]] <- br_1[[varname]] <- new_1[[varname]] + .5*delta
  }else{
    new_0[[varname]] <- br_0[[varname]] <-vals[1]
    new_1[[varname]] <- br_1[[varname]] <-vals[2]
  }
  md0 <- md1 <- data
  k <- 1
  for(i in (which_block+1):(length(blocks)-1)){
    for(j in 1:length(blocks[[i]])){
      new_0[[blocks[[i]][j]]] <- md0[[blocks[[i]][j]]] <- draw_val(mods[[(i-1)]][[j]], new_0, incl_b_var = b_var)
      new_1[[blocks[[i]][j]]] <- md1[[blocks[[i]][j]]] <- draw_val(mods[[(i-1)]][[j]], new_1, incl_b_var = b_var)
    }
    tmp0 <- draw_val(mods[[length(mods)]], md0, ret=lastMod, incl_b_var = b_var)
    tmp1 <- draw_val(mods[[length(mods)]], md1, ret=lastMod, incl_b_var = b_var)
    if(!is.matrix(tmp0))tmp0 <- matrix(tmp0, ncol=1)
    if(!is.matrix(tmp1))tmp1 <- matrix(tmp1, ncol=1)
    med[[k]] <- rbind(med[[k]], colMeans(tmp1-tmp0))
    k <- k+1
  }

  res0 <- draw_val(mods[[length(mods)]], new_0, ret=lastMod, incl_b_var = b_var)
  res1 <- draw_val(mods[[length(mods)]], new_1, ret=lastMod, incl_b_var = b_var)
  if(!is.matrix(res0))res0 <- matrix(res0, ncol=1)
  if(!is.matrix(res1))res1 <- matrix(res1, ncol=1)
  total_effect <- res1-res0

  d0 <- draw_val(mods[[length(mods)]], br_0, ret=lastMod, incl_b_var = b_var)
  d1 <- draw_val(mods[[length(mods)]], br_1, ret=lastMod, incl_b_var = b_var)
  if(!is.matrix(d0))d0 <- matrix(d0, ncol=1)
  if(!is.matrix(d1))d1 <- matrix(d1, ncol=1)

  direct_effect <- d1-d0

  indirect_effect <- total_effect - direct_effect

  be0 <- draw_val(br_mod, br_0, ret=lastMod, incl_b_var = b_var)
  be1 <- draw_val(br_mod, br_1, ret=lastMod, incl_b_var = b_var)
  if(!is.matrix(be0))be0 <- matrix(be0, ncol=1)
  if(!is.matrix(be1))be1 <- matrix(be1, ncol=1)

  out_br <- rbind(out_br, colMeans(be1-be0))

  out_t <- rbind(out_t, colMeans(total_effect))
  out_d <- rbind(out_d, colMeans(direct_effect))
  out_i <- rbind(out_i, colMeans(indirect_effect))
  pb$tick()
  }
  res <- list(total = out_t, direct= out_d, indirect=out_i, br = out_br, mediated=med)
}


#  James Rekow

computeInfoWeight = function(docPoint, rollRange = 0.025){

  #  ARGS: docPoint - vector of the form c(over, diss)
  #
  #  RETURNS: localDissMid - midpoint of local dissimilarities (unweighted, not the same as the mean)

  #  extract overlap and dissimilarity of DOC point
  over = docPoint[1]
  diss = docPoint[2]

  #  return 0 if something goes wrong
  if(!is.numeric(over) || !is.numeric(diss)){
    return(0)
  } #  end if

  #  don't count DOC points that have low overlap but 0 dissimilarity, these have 0 diss because they
  #  only share a single species
  if(diss < 0.005){
    if(over < 0.7){
      return(0)
    } #  end if
  } #  end if

  #  identify data frame row indices of DOC points with similar overlap
  similarOver = abs(doc[[1]] - over) < rollRange

  #  create vector of dissimilarities of all DOC points with similar overlap to input docPoint
  localDiss = doc[[2]][similarOver]

  #  compute the midpoint of the local dissimilarities
  localDissMid = 0.5 * {max(localDiss) + min(localDiss)}

  #  compute weighted value whose sign corresponds to whether or not the samples corresponding to the DOC
  #  point are in the same or different subgroups (- same, + different) and whose absolute value
  #  corresponds to how much weight is given to the info from the given DOC point
  infoWeight = diss - localDissMid

  return(infoWeight)

} #  end computeInfoWeight function


# Returns the number and size of the Snowplow event files generated each month
snowplowEventFilesGenerated <- function(events, runsPerDay){
	dataVolume <- sizeOfSnowplowEventFilesGenerated(events)
	numOfFiles <- numOfSnowplowEventFiles(events, runsPerDay)
}

sizeOfSnowplowEventFilesGenerated <- function(events){
	# Results of regression analysis (see 'estimate size of snowplow event files from number of lines of data')
	intercept <- -30329
	gradient <- 710
	toGiga(intercept + events * gradient)
}

numOfSnowplowEventFiles <- function(events, runsPerDay){
	runsPerMonth <- runsPerDay * 30
	eventsPerRun <- events / runsPerMonth
	filesGeneratedPerRun <- numOfSnowplowEventFilesGeneratedPerRun(eventsPerRun)

	# files generated per month = files generated per run x runs per month
	filesGeneratedPerRun * runsPerMonth
}

numOfSnowplowEventFilesGeneratedPerRun <- function(eventsPerRun){
	# Snowplow *should* product 1 event file per 128 MB of data per run
	megabytesPerRun <- sizeOfSnowplowEventFilesGenerated(eventsPerRun)
	ceiling(megabytesPerRun / fromMega(toGiga(128)))
}


# https://www.census.gov/topics/population/genealogy/data/2010_surnames.html

library(readxl)
library(dplyr)
library(purrr)
library(stringr)

#url <- "https://www2.census.gov/topics/genealogy/2010surnames/names.zip"
#destfile <- "data-raw/surnames.zip"
#exdir <- "data-raw/surnames"
#unzip(destfile, exdir = exdir)

url <- "https://www2.census.gov/topics/genealogy/2010surnames/Names_2010Census_Top1000.xlsx"
destfile <- file.path("data-raw", basename(url))

download.file(url, destfile)

# (S) means value surpressed for confidentiality
names_last <- read_excel(destfile, na = c("", "(S)"), skip = 2) %>%
  mutate(across(c("RANK", "FREQUENCY (COUNT)", "CUMULATIVE PROPORTION"), as.integer))

colnames(names_last) <- c(
  "surname", "rank", "n", "n_per_100k", "cumulative_n_per_100k",
  "pct_white", "pct_black", "pct_hawaiian", "pct_american_indian",
  "pct_multiple", "pct_hispanic")

names_last <- names_last %>%
  filter(!is.na(rank)) %>%
  mutate(
    pct = n_per_100k/sum(n_per_100k),
    surname = str_to_title(surname),
    year = 2010
  ) %>%
  mutate(across(starts_with("pct_"), function(x) if_else(is.na(x), 0, x))) %>%
  select(year, everything())

# save data
usethis::use_data(names_last, overwrite = TRUE)

# clean up
unlink(destfile)


library(exptest)

co.exp.test(x, simulate.p.value=FALSE, nrepl=2000)


#!/usr/bin/env Rscript

die = commandArgs(trailingOnly=TRUE)[1]

split_die <- strsplit(die, "d")

rolls <- as.integer(split_die[[1]][1])

if (is.na(rolls)) {
    rolls = 1
}

right_d <- split_die[[1]][2]

matches <- regmatches(right_d, gregexpr("[[:digit:]]+", right_d))
remaining_digits <- as.numeric(unlist(matches))

sides <- remaining_digits[1]

modifier <- remaining_digits[2]

if (is.na(modifier)) {
    modifier <- 0
} else {
    modifier <- as.numeric(modifier)
}

total = 0
roll = 0
while (roll < rolls) {
    total <- total + sample(1:sides, 1)
    roll = roll + 1
}

if (grep("+",right_d) == 1) {
    total = total + modifier
} else if (grep("-",right_d) == 1) {
    total = total - modifier
}

invisible(total)

print(total)


png('esophagus_dilution.png')
hist(log2(eso00$mouse6c),xlim=c(-6,8),freq=F,col=rgb(1,0,0,0.25),main="Esophageal histone dilution",xlab="log2(Histone Intensity)",border=NA)
hist(log2(eso00$mouse6d),xlim=c(-6,8),freq=F,col=rgb(1,0,0,0.25),add=T,border=NA)
hist(log2(eso00$mouse1k),xlim=c(-6,8),freq=F,col=rgb(1,0,0,0.25),add=T,border=NA)

hist(log2(eso07$mouse1c),xlim=c(-6,8),freq=F,col=rgb(0,1,0,0.25),add=T,border=NA)
hist(log2(eso07$mouse1i),xlim=c(-6,8),freq=F,col=rgb(0,1,0,0.25),add=T,border=NA)
hist(log2(eso07$mouse1j),xlim=c(-6,8),freq=F,col=rgb(0,1,0,0.25),add=T,border=NA)

hist(log2(eso12$mouse6e),xlim=c(-6,8),freq=F,col=rgb(0,0,1,0.25),add=T,border=NA)
hist(log2(eso12$mouse6g),xlim=c(-6,8),freq=F,col=rgb(0,0,1,0.25),add=T,border=NA)
hist(log2(eso12$mouse1a),xlim=c(-6,8),freq=F,col=rgb(0,0,1,0.25),add=T,border=NA)

hist(log2(eso18$mouse1d),xlim=c(-6,8),freq=F,col=rgb(1,1,0,0.25),add=T,border=NA)
hist(log2(eso18$mouse1e),xlim=c(-6,8),freq=F,col=rgb(1,1,0,0.25),add=T,border=NA)
legend("topleft", c("0 day", "7 day", "12 day", "18 day"), col=c("red","green","blue","yellow"), lwd=10)
dev.off()


#-------------------------------------------------------------------------------
#
# Bayes-factor correction for gene set analysis (SnpEff gsa)
#
#
#															Pablo Cingolani 2013
#-------------------------------------------------------------------------------

#-------------------------------------------------------------------------------
# Main
#-------------------------------------------------------------------------------

show = TRUE		# Used for debugging
show = FALSE	# Used for production

pvalCoefThreshold = 10^-12	# Adjust only if linearmodel p-value is less than this

#---
# Parse command line arguments
#---
if( ! exists('fileName') ) {
    args <- commandArgs(trailingOnly = TRUE)
    fileName = args[1]
    outFileName = args[2]
    minScoreCount = args[3]
}

#---
# Read data
#---
d = read.table(fileName, sep="\t", header=TRUE)

# p-values or scores.
# Note: the conversion 'as.numeric(as.character())' is necesary
# because R reads '0.6049666666666666' as a number,
# but reads       '0.60496666666666666' as a string (yes, R is amazing!)
p = as.numeric(as.character(d$score))
c = d$scoreCount						# number of variants

keep = (c > 0)

p = p[keep]
mu = mean(p)
sigma = sd(p)
lp = as.vector(scale(p[keep]))		# Scale to mean=0 and var=1 => Convert to z-scores using an inverse normal distribution

c = c[keep]
lc = log10(c)

#---
# Linear model
#---
lmfit = lm( lp ~ lc )
sumLmfit =  summary(lmfit)
pvalCoef = sumLmfit$coefficients[2,4]

res = lmfit$residuals		# Residuals
padj = sigma * res + mu	# Adjusted bayesian factor

# Don't adjust under 'minScoreCount'
padj[ c <= minScoreCount ] = p[ c <= minScoreCount ]

if( show ) {
	print(sumLmfit)
	cat('Slope:\t', sumLmfit$coefficients[2], '\tp-value:\t', pvalCoef, 'File:\t', fileName, '\n');

	par(mfrow=c(2,2))
	smoothScatter( lc, p, main="Z-Scores", xlab="Number of scores", ylab="Z-Score" )
	lines(lowess(lc, p ), col='orange')

	smoothScatter( lc, padj, main="Adjusted Z-Scores", xlab="Number of scores", ylab="Z-Score" )
	lines(lowess(lc, padj ), col='orange')

	plot( density(p) , main="Bayes-Factors distribution", xlab="red:Adjusted black:Unadjusted")
	lines( density(padj) , col='red')

	plot( density(lc) , main="log10(Number of scores)", xlab="")
}

#---
# Decide whether to use corrected scores or not
#---
if( pvalCoef < pvalCoefThreshold ) {
	so = padj		# Significant? Then use correction
	so[ c <= minScoreCount ] = p[ c <= minScoreCount ]
} else {
	so = d$score	# Not very significant? Use original scores
}

#---
# Create output file
#---
dout = data.frame( geneId = d$geneId[keep], score = so )
write.table( dout, file=outFileName, quote=FALSE, row.names = FALSE, col.names = FALSE, sep="\t")


library('RNiftyReg')

regImgToTemplate <- function(imgFilename, templateFilename){
  sourceImage <- readNifti(imgFilename)
  templateImage <- readNifti(templateFilename)

  transform <- niftyreg(sourceImage,targetImage)
}

testImgReg <- function(imgFilename){
  sourceImage <- readNifti(imgFilename)

  # Set dummy transformations and print to screen
  transV <- (runif(3) - 0.5) * 100 # Translations up to 50
  scaleV <- c(1,1,1)    # NO SCALING!
  rotV   <- runif(3) - 0.5        # -0.5 to + 0.5 radians (about 30 degrees max)

#  cat("Translation vector: ", transV, "\n")
#  cat("Scale vector: ", scaleV, "\n")
#  cat("Rotation angles: ", rotV, "\n")

  # Build the affine transform and apply it to the image
  afT = buildAffine(translation=transV, scales=scaleV,angles=rotV,
                    source=sourceImage)
  targetImage <- applyTransform(afT,sourceImage)

  transform <- niftyreg(sourceImage,targetImage)

  decomposed = decomposeAffine(forward(transform))

  deltaTrans = transV - decomposed$translation
  deltaScale = scaleV - decomposed$scales
  deltaAngle = rotV - decomposed$angles

  results = data.frame()
  results['Translation','OrigX'] = transV[1]
  results['Translation','OrigY'] = transV[2]
  results['Translation','OrigZ'] = transV[3]
  results['Translation','CalcX'] = decomposed$translation[1]
  results['Translation','CalcY'] = decomposed$translation[2]
  results['Translation','CalcZ'] = decomposed$translation[3]
  results['Translation','deltaX'] = deltaTrans[1]
  results['Translation','deltaY'] = deltaTrans[2]
  results['Translation','deltaZ'] = deltaTrans[3]

  results['Scaling','OrigX'] = scaleV[1]
  results['Scaling','OrigY'] = scaleV[2]
  results['Scaling','OrigZ'] = scaleV[3]
  results['Scaling','CalcX'] = decomposed$scales[1]
  results['Scaling','CalcY'] = decomposed$scales[2]
  results['Scaling','CalcZ'] = decomposed$scales[3]
  results['Scaling','deltaX'] = deltaScale[1]
  results['Scaling','deltaY'] = deltaScale[2]
  results['Scaling','deltaZ'] = deltaScale[3]

  results['Rotation','OrigX'] = rotV[1]
  results['Rotation','OrigY'] = rotV[2]
  results['Rotation','OrigZ'] = rotV[3]
  results['Rotation','CalcX'] = decomposed$angles[1]
  results['Rotation','CalcY'] = decomposed$angles[2]
  results['Rotation','CalcZ'] = decomposed$angles[3]
  results['Rotation','deltaX'] = deltaAngle[1]
  results['Rotation','deltaY'] = deltaAngle[2]
  results['Rotation','deltaZ'] = deltaAngle[3]

  print(results)

  return(results)
}


days <- read.table('ttl.csv', header=FALSE, sep=',')
d_sncf <- days[which(days$V1=='Disponible' & days$V2 == 'sncf'), ]
d_ratp <- days[which(days$V1=='Disponible' & days$V2 == 'ratp'), ]
hs_ratp <- days[which(days$V1=='Hors service' & days$V2 == 'ratp'), ]
hs_sncf <- days[which(days$V1=='Hors service' & days$V2 == 'sncf'), ]

summary(d_sncf$V3)
summary(d_ratp$V3)
summary(hs_sncf$V3)
summary(hs_ratp$V3)

wilcox.test(d_sncf$V3, d_ratp$V3, conf.int = TRUE, conf.level = 0.99)
wilcox.test(hs_sncf$V3, hs_ratp$V3, conf.int = TRUE, conf.level = 0.99)


library(MASS)

A <- c('m', 'i', 'p', 's', 'k', 'y')
B <- c('a', 'y', 'o', 'i', 'e', 'f', 'x', 's')

isVocal <- function(x) {
  rval <- 0;
  for ( i in 1:length(x) ) {
     if (x[i] %in% c('a', 'e', 'i', 'o', 'u')) {
      rval <- rval+1
    }
  }
  return(rval)
}

print(fractions( isVocal(A) / length(A) ))
print(fractions( 1 - isVocal(B) / length(B) ))
print(fractions( 1 - isVocal(union(A,B)) / length(union(A,B))))
print((fractions( isVocal(intersect(A,B)) / length(intersect(A,B)))))


context("istarmap iterator")

pow <- function(x, y) {
  x^y
}

test_that("istarmap over a list of two numeric vectors of equal length", {
  it <- istarmap(pow, list(c(2, 3, 10), c(5, 2, 3)))

  expect_equal(nextElem(it), 32)
  expect_equal(nextElem(it), 9)
  expect_equal(nextElem(it), 1000)

  expect_error(nextElem(it), "StopIteration")
})

test_that("istarmap over a list of two numeric vectors of unequal length", {
  it <- istarmap(pow, list(c(2, 3, 10), c(5, 2, 3, 42)))

  expect_equal(nextElem(it), 32)
  expect_equal(nextElem(it), 9)
  expect_equal(nextElem(it), 1000)

  expect_error(nextElem(it), "StopIteration")
})

test_that("istarmap over a list of two lists of equal length", {
  it <- istarmap(pow, list(list(2, 3, 10), list(5, 2, 3)))

  expect_equal(nextElem(it), 32)
  expect_equal(nextElem(it), 9)
  expect_equal(nextElem(it), 1000)

  expect_error(nextElem(it), "StopIteration")
})

test_that("istarmap over a list of two lists of unequal length", {
  it <- istarmap(pow, list(list(2, 3, 10), list(5, 2, 3, 42)))

  expect_equal(nextElem(it), 32)
  expect_equal(nextElem(it), 9)
  expect_equal(nextElem(it), 1000)

  expect_error(nextElem(it), "StopIteration")
})

test_that("istarmap over the rows of a data.frame", {
  # Computes sum of each row in the iris data set
  it <- istarmap(sum, iris[, -5])

  expect_equal(nextElem(it), sum(iris[1, -5]))
  expect_equal(nextElem(it), sum(iris[2, -5]))
  expect_equal(nextElem(it), sum(iris[3, -5]))
  expect_equal(nextElem(it), sum(iris[4, -5]))
  expect_equal(nextElem(it), sum(iris[5, -5]))
  expect_equal(nextElem(it), sum(iris[6, -5]))
  # and so on...
})