diff --git a/.gitignore b/.gitignore
index 8bf3ddcf300c5f301031349c7c57347032ad645b..a59d988aed318184e75463c9c6166699fcae0453 100644
--- a/.gitignore
+++ b/.gitignore
@@ -5,4 +5,5 @@ results/
.nextflow*
dataset/
example_of_result/
-other/
\ No newline at end of file
+other/
+dev/
\ No newline at end of file
diff --git a/bin/slith_part1.R b/bin/slith_part1.R
deleted file mode 100755
index a744512e2a99d9e29da933a10382fed75767ca25..0000000000000000000000000000000000000000
--- a/bin/slith_part1.R
+++ /dev/null
@@ -1,7273 +0,0 @@
-#! /usr/bin/Rscript
-
-#########################################################################
-## ##
-## SLITHERINE ##
-## ##
-## Gael A. Millot ##
-## Vittore F. Scolari ##
-## Lyam Baudry ##
-## Mia Legras ##
-## ##
-#########################################################################
-
-
-# Slitherine help to define significant coverage differences when comparing two contact matrices
-
-
-################################ Initialization
-
-
-# R version checking
-if (version$version.string != "R version 3.6.1 (2019-07-05)") {
- cat(
- paste0(
- "\n\nWARNING: THE ",
- version$version.string,
- " IS NOT THE 3.6.1 RECOMMANDED\n\n"
- )
- )
-}
-
-erase.objects = TRUE # write TRUE to erase all the existing objects in R before starting the algorithm and FALSE otherwise. Beginners should use TRUE
-if (erase.objects == TRUE) {
- rm(list = ls())
- erase.objects = TRUE
-}
-erase.graphs = TRUE # write TRUE to erase all the graphic windows in R before starting the algorithm and FALSE otherwise
-script <- "slitherine v2.0.0"
-
-################################ End Initialization
-
-
-################################ Recording of the initial parameters
-
-args <- commandArgs(trailingOnly = TRUE)
-
-path.in <- args[1]
-path.out <- args[2]
-project.name <- args[3]
-# files
-lib.path <- as.null(args[4])
-path.function1 <- args[5]
-file.name1 <- args[6]
-file.name2 <- args[7]
-# matrix struct
-empty.cell.string <- as.numeric(args[8])
-thread.nb <- as.null(args[9])
-# hiccompare
-hiccomp <- as.logical(toupper(args[10]))
-binning <- as.integer(args[11])
-# theor matrix compare
-theo.import <- as.logical(toupper(args[12]))
-n.row <- as.integer(args[13])
-win.size <- as.integer(args[14])
-cv.rho.obtained <- as.logical(toupper(args[15]))
-path.cv.rho <- as.null(args[16])
-correl.mat.obtained <- as.logical(toupper(args[17]))
-path.theo1.theo2 <- as.null(args[18])
-single.corr <- args[19]
-abs.cor.limit <- args[20]
-print.count <- as.integer(args[21])
-keep <- as.logical(toupper(args[22]))
-# signif regions between the 2 compared matrices
-ratio.limit.sig <- as.integer(args[23])
-error <- as.integer(args[24])
-range.split <- as.integer(args[25])
-step.factor <- as.integer(args[26])
-ratio.normalization <- as.logical(toupper(args[27]))
-# graphical and display parameters
-activate.pdf <- as.logical(toupper(args[28]))
-optional.text <- args[29]
-width.wind <- as.integer(args[30])
-height.wind <- as.integer(args[31])
-dot.size <- as.integer(args[32])
-line.size <- as.numeric(args[33])
-heatmap.text.size <- as.integer(args[34])
-text.size <- as.integer(args[35])
-title.text.size <- as.integer(args[36])
-raster <- as.logical(toupper(args[37]))
-transfo <- args[38]
-warn.secu <- as.logical(toupper(args[39]))
-serp.symmet.input <- as.logical(toupper(args[40]))
-adj_mean <- args[41]
-hiccompare_graph <- args[42]
-mask_plot <- args[43]
-if (theo.import) {
- theo.mat.ch1 <- args[44]
- theo.mat.ch2 <- args[45]
- theo.path.in <- args[46]
-}
-
-param.list <- c(
- "erase.objects",
- "erase.graphs",
- "script",
- "args",
- "project.name",
- "file.name1",
- "file.name2",
- "path.in",
- "path.out",
- "lib.path",
- "path.function1",
- "empty.cell.string",
- "thread.nb",
- "serp.symmet.input",
- "hiccomp",
- "binning",
- "theo.import",
- "n.row",
- "win.size",
- "cv.rho.obtained",
- "path.cv.rho",
- "correl.mat.obtained",
- "path.theo1.theo2",
- "single.corr",
- "abs.cor.limit",
- "print.count",
- "keep",
- "ratio.limit.sig",
- "error",
- "range.split",
- "step.factor",
- "ratio.normalization",
- "activate.pdf",
- "optional.text",
- "width.wind",
- "height.wind",
- "dot.size",
- "line.size",
- "heatmap.text.size",
- "text.size",
- "title.text.size",
- "raster",
- "transfo",
- "warn.secu",
- "adj_mean",
- "hiccompare_graph",
- "mask_plot",
- if (theo.import) {
- "theo.file.name1"
- "theo.file.name2"
- "theo.path.in"
- }
-)
-
-if (any(duplicated(param.list))) {
- stop(
- paste0(
- "\n\n================\n\nINTERNAL CODE ERROR IN SLITHERINE\n
- THE param.list OBJECT CONTAINS DUPLICATED ELEMENTS:\n",
- paste(param.list[duplicated(param.list)], collapse = " "),
- "\n\n================\n\n"
- )
- ) # message for developers
-}
-if (erase.objects == TRUE) {
- created.object.control <- ls()[!ls() %in% "param.list"]
- if (!(
- all(created.object.control %in% param.list) &
- all(param.list %in% created.object.control)
- )) {
- stop(
- paste0(
- "\n\n================\n\nINTERNAL CODE ERROR IN SLITHERINE\n
- INCONSISTENCIES BETWEEN THE param.list ELEMENTS AND THE CREATED OBJECTS\n
- THE CREATED OBJECTS (created.object.control) NOT PRESENT IN THE param.list ARE: ",
- paste(created.object.control[!created.object.control %in% param.list], collapse = " "),
- "\nTHE param.list ELEMENTS NOT PRESENT IN THE CREATED OBJECTS (created.object.control) ARE: ",
- paste(param.list[!param.list %in% created.object.control], collapse = " "),
- "\n\n================\n\n"
- )
- ) # message for developers
- }
-}
-char.length <- nchar(param.list)
-space.add <- max(char.length) - char.length + 5
-param.ini.settings <- character(length = length(param.list))
-for (i in 1:length(param.list)) {
- param.ini.settings[i] <-
- paste0("\n",
- param.list[i],
- paste0(rep(" ", space.add[i]), collapse = ""),
- paste0(get(param.list[i]), collapse = ","))
-}
-################################ End Recording of the initial parameters
-
-
-################################ Functions
-
-
-# Functions are built such that they should have no direct use of Global objects (going through the R scope),
-# but use through the function arguments
-
-# 1) Cute little function is sourced for the moment into the .GlobalEnv environment,
-# but may be interesting to put it into a new environement just above .GlobalEnv environment.
-# See https://stackoverflow.com/questions/9002544/how-to-add-functions-in-an-existing-environment
-
-# 2) Argument names of each function must not be a name of Global objects (error message otherwise)
-
-# 3) Argument name of each function ends with "_fun" in the first function, "_2fun" in the second, etc.
-# This prevent conflicts with the argument partial names when using these functions, notably when they are imbricated
-
-source(adj_mean)
-source(mask_plot)
-source(hiccompare_graph)
-
-################ import functions from cute little functions toolbox
-
-
-if (length(path.function1) != 1) {
- stop(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE\npath.function1 PARAMETER MUST BE LENGTH 1: ",
- paste(path.function1, collapse = " "),
- "\n\n============\n\n"
- )
- )
-} else if (grepl(x = path.function1, pattern = "^http")) {
- tempo.try <-
- try(suppressWarnings(source(path.function1, local = .GlobalEnv)), silent = TRUE)
- if (any(grepl(x = tempo.try, pattern = "[Ee]rror"))) {
- stop(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE\n
- HTTP INDICATED IN THE path.function1 PARAMETER DOES NOT EXISTS: ",
- path.function1,
- "\n\n============\n\n"
- )
- )
- } else{
- source(path.function1, local = .GlobalEnv) # source the fun_ functions used below
- }
-} else if (!grepl(x = path.function1, pattern = "^http")) {
- if (!file.exists(path.function1)) {
- stop(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE\n
- FILE INDICATED IN THE path.function1 PARAMETER DOES NOT EXISTS: ",
- path.function1,
- "\n\n============\n\n"
- )
- )
- } else{
- source(path.function1, local = .GlobalEnv) # source the fun_ functions used below
- }
-}
-
-################ function that check the other internal functions of slitherine
-
-
-
-################ local function: package import
-
-
-# R Packages required
-req.package.list <- c("parallel",
- "lubridate",
- "reshape2",
- "ggplot2",
- "Cairo")
-
-## peut etre à enlever
-for (i in 1:length(req.package.list)) {
- suppressMessages((library(req.package.list[i], character.only = TRUE)))
-}
-
-print("library imported")
-################################ End Functions
-
-
-################################ Main code
-
-
-################ Pre-ignition checking
-
-
-warning.message <- NULL
-param.check <- NULL #
-checked.param.names <- NULL #
-ee <- expression(fun_checkparam.check <- c(param.check, tempo$problem), checked.param.names <- c(checked.param.names, tempo$param.name))
-tempo <- fun_check(data = erase.objects, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = erase.graphs, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = script, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = project.name, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = file.name1, class = "vector", mode = "character", fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = file.name2, class = "vector", mode = "character", fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = path.in, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = path.out, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = lib.path, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = path.function1, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee) # full check above
-tempo <- fun_check( data = empty.cell.string, class = "vector", na.contain = TRUE, length = 1, fun.name = "SLITHERINE" ) ; eval(ee)
-tempo <- fun_check( data = thread.nb, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = serp.symmet.input, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = hiccomp, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = binning, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = theo.import, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = n.row, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = win.size, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = cv.rho.obtained, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = path.cv.rho, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = correl.mat.obtained, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = path.theo1.theo2, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = single.corr, options = c("VALUE", "MAX", "DEC1", "QUART1", "MED", "MIN", "NO"), length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = abs.cor.limit, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = print.count, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = keep, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = ratio.limit.sig, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = error, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = range.split, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = step.factor, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = ratio.normalization, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = activate.pdf, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = optional.text, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = width.wind, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = height.wind, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = dot.size, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = line.size, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = heatmap.text.size, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = text.size, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = title.text.size, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = raster, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = transfo, options = c("log2", "log10"), length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = warn.secu, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = theo.file.name1, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = theo.file.name2, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = theo.path.in, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-
-
-
-
-
-if (!is.null(thread.nb)) {
- tempo <- fun_check( data = thread.nb, typeof = "integer", double.as.integer.allowed = TRUE, neg.values = FALSE, length = 1, fun.name = "SLITHERINE" )
- eval(ee)
- if (tempo$problem == FALSE & thread.nb < 1){
- param.check <- c(param.check, TRUE)
- cat( paste0( "\n\n============\n\nERROR IN SLITHERINE: thread.nb PARAMETER MUST EQUAL OR GREATER THAN 1: ", thread.nb, "\n\n============\n\n"))
- }
-}
-tempo <- fun_check( data = hiccomp, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-if (tempo$problem == FALSE & is.null(binning)) {
- if (hiccomp == TRUE) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: binning PARAMETER CANNOT BE NULL IF hiccomp PARAMETER IS TRUE
- \n\n============\n\n"
- )
- )
- }
-}
-if (!is.null(binning)) {
- tempo <- fun_check( data = binning, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, na.contain = FALSE, length = 1, fun.name = "SLITHERINE" )
- eval(ee)
-}
-tempo <- fun_check( data = theo.import, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-if (tempo$problem == FALSE & theo.import == TRUE) {
- tempo <- fun_check( data = theo.file.name1, class = "vector", mode = "character", fun.name = "SLITHERINE" )
- eval(ee)
- if (tempo$problem == FALSE &
- substr(theo.file.name1,
- nchar(theo.file.name1) - 3,
- nchar(theo.file.name1)) != ".txt") {
- tempo.warning <-
- paste0(
- "THE theo.file.name1 OBJECT SETTING SHOULD BE A TXT FILE BUT DOES NOT FINISH BY
- \".txt\" LOWERCASE WRITTEN"
- )
- cat(paste0("\nWARNING: ", tempo.warning, "\n"))
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
- }
- tempo <- fun_check( data = theo.file.name2, class = "vector", mode = "character", fun.name = "SLITHERINE" )
- eval(ee)
- if (tempo$problem == FALSE &
- substr(theo.file.name2,
- nchar(theo.file.name2) - 3,
- nchar(theo.file.name2)) != ".txt") {
- tempo.warning <-
- paste0(
- "THE theo.file.name2 OBJECT SETTING SHOULD BE A TXT FILE BUT DOES NOT FINISH BY
- \".txt\" LOWERCASE WRITTEN"
- )
- cat(paste0("\nWARNING: ", tempo.warning, "\n"))
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
- }
- tempo <- fun_check( data = theo.path.in, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE" )
- eval(ee)
- if (tempo$problem == FALSE & !dir.exists(theo.path.in)) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: DIRECTORY PATH INDICATED IN THE theo.path.in
- PARAMETER DOES NOT EXISTS: ",
- theo.path.in,
- "\n\n============\n\n"
- )
- )
- }
-}
-if (!is.null(n.row)) {
- tempo <- fun_check( data = n.row, typeof = "integer", double.as.integer.allowed = TRUE, neg.values = FALSE, length = 1, fun.name = "SLITHERINE" )
- eval(ee)
-}
-
-if (tempo$problem == FALSE & cv.rho.obtained == TRUE) {
- if (!is.null(path.cv.rho)) {
- tempo <- fun_check( data = path.cv.rho, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE" )
- eval(ee)
- if (tempo$problem == FALSE & !file.exists(path.cv.rho)) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: FILE AND PATH INDICATED IN THE path.cv.rho
- PARAMETER DOES NOT EXISTS: ",
- path.cv.rho,
- "\n\n============\n\n"
- )
- )
- }
- }
-}
-tempo <- fun_check( data = correl.mat.obtained, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-if (tempo$problem == FALSE & correl.mat.obtained == TRUE) {
- if (!is.null(path.theo1.theo2)) {
- tempo <- fun_check( data = path.theo1.theo2, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE" )
- eval(ee)
- if (tempo$problem == FALSE &
- !file.exists(path.theo1.theo2)) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: FILE AND PATH INDICATED IN THE path.theo1.theo2
- PARAMETER DOES NOT EXISTS: ",
- path.theo1.theo2,
- "\n\n============\n\n"
- )
- )
- }
- }
-}
-
-
-if (tempo$problem == FALSE & ratio.limit.sig < 1) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: ratio.limit.sig PARAMETER MUST EQUAL OR GREATER THAN 1: ",
- ratio.limit.sig,
- "\n\n============\n\n"
- )
- )
-}
-tempo <- fun_check( data = error, prop = TRUE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = range.split, class = "vector", mode = "numeric", neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = step.factor, class = "vector", mode = "numeric", neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-if (tempo$problem == FALSE & step.factor < 1) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: step.factor PARAMETER MUST EQUAL OR GREATER THAN 1: ",
- ratio.limit.sig,
- "\n\n============\n\n"
- )
- )
-}
-tempo <- fun_check( data = ratio.normalization, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = activate.pdf, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = optional.text, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = width.wind, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = height.wind, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = dot.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = line.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = heatmap.text.size, class = "vector", mode = "numeric", neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = text.size, class = "vector", neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = title.text.size, class = "vector", neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = raster, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = transfo, options = c("log2", "log10"), length = 1, fun.name = "SLITHERINE") ; eval(ee)
-if (any(param.check) == TRUE) {
- print("line.size")
- print(line.size)
- print(param.check)
- stop() # nothing else because print = TRUE by default in fun_check()
-}
-
-
-
-
-
-
-
-
-
-
-
-if (tempo$problem == FALSE & substr(file.name2, nchar(file.name2) - 3, nchar(file.name2)) != ".txt") {
- tempo.warning <- paste0( "THE file.name2 OBJECT SETTING SHOULD BE A TXT FILE BUT DOES NOT FINISH BY \".txt\" LOWERCASE WRITTEN" )
- cat(paste0("\nWARNING: ", tempo.warning, "\n"))
- warning.message <- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
-}
-tempo <- fun_check( data = path.function1, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee) # full check above
-if (!is.null(empty.cell.string)) {
- tempo <- fun_check( data = empty.cell.string, class = "vector", na.contain = TRUE, length = 1, fun.name = "SLITHERINE" )
- eval(ee)
-}
-if (!is.null(thread.nb)) {
- tempo <- fun_check( data = thread.nb, typeof = "integer", double.as.integer.allowed = TRUE, neg.values = FALSE, length = 1, fun.name = "SLITHERINE" )
- eval(ee)
- if (tempo$problem == FALSE & thread.nb < 1){
- param.check <- c(param.check, TRUE)
- cat( paste0( "\n\n============\n\nERROR IN SLITHERINE: thread.nb PARAMETER MUST EQUAL OR GREATER THAN 1: ", thread.nb, "\n\n============\n\n"))
- }
-}
-tempo <- fun_check( data = hiccomp, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-if (tempo$problem == FALSE & is.null(binning)) {
- if (hiccomp == TRUE) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: binning PARAMETER CANNOT BE NULL IF hiccomp PARAMETER IS TRUE
- \n\n============\n\n"
- )
- )
- }
-}
-if (!is.null(binning)) {
- tempo <- fun_check( data = binning, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, na.contain = FALSE, length = 1, fun.name = "SLITHERINE" )
- eval(ee)
-}
-tempo <- fun_check( data = theo.import, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-if (tempo$problem == FALSE & theo.import == TRUE) {
- tempo <- fun_check( data = theo.file.name1, class = "vector", mode = "character", fun.name = "SLITHERINE" )
- eval(ee)
- if (tempo$problem == FALSE &
- substr(theo.file.name1,
- nchar(theo.file.name1) - 3,
- nchar(theo.file.name1)) != ".txt") {
- tempo.warning <-
- paste0(
- "THE theo.file.name1 OBJECT SETTING SHOULD BE A TXT FILE BUT DOES NOT FINISH BY
- \".txt\" LOWERCASE WRITTEN"
- )
- cat(paste0("\nWARNING: ", tempo.warning, "\n"))
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
- }
- tempo <- fun_check( data = theo.file.name2, class = "vector", mode = "character", fun.name = "SLITHERINE" )
- eval(ee)
- if (tempo$problem == FALSE &
- substr(theo.file.name2,
- nchar(theo.file.name2) - 3,
- nchar(theo.file.name2)) != ".txt") {
- tempo.warning <-
- paste0(
- "THE theo.file.name2 OBJECT SETTING SHOULD BE A TXT FILE BUT DOES NOT FINISH BY
- \".txt\" LOWERCASE WRITTEN"
- )
- cat(paste0("\nWARNING: ", tempo.warning, "\n"))
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
- }
- tempo <- fun_check( data = theo.path.in, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE" )
- eval(ee)
- if (tempo$problem == FALSE & !dir.exists(theo.path.in)) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: DIRECTORY PATH INDICATED IN THE theo.path.in
- PARAMETER DOES NOT EXISTS: ",
- theo.path.in,
- "\n\n============\n\n"
- )
- )
- }
-}
-if (!is.null(n.row)) {
- tempo <- fun_check( data = n.row, typeof = "integer", double.as.integer.allowed = TRUE, neg.values = FALSE, length = 1, fun.name = "SLITHERINE" )
- eval(ee)
-}
-tempo <- fun_check( data = win.size, typeof = "integer", double.as.integer.allowed = TRUE, neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = cv.rho.obtained, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-if (tempo$problem == FALSE & cv.rho.obtained == TRUE) {
- if (!is.null(path.cv.rho)) {
- tempo <- fun_check( data = path.cv.rho, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE" )
- eval(ee)
- if (tempo$problem == FALSE & !file.exists(path.cv.rho)) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: FILE AND PATH INDICATED IN THE path.cv.rho
- PARAMETER DOES NOT EXISTS: ",
- path.cv.rho,
- "\n\n============\n\n"
- )
- )
- }
- }
-}
-tempo <- fun_check( data = correl.mat.obtained, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-if (tempo$problem == FALSE & correl.mat.obtained == TRUE) {
- if (!is.null(path.theo1.theo2)) {
- tempo <- fun_check( data = path.theo1.theo2, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE" )
- eval(ee)
- if (tempo$problem == FALSE &
- !file.exists(path.theo1.theo2)) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: FILE AND PATH INDICATED IN THE path.theo1.theo2
- PARAMETER DOES NOT EXISTS: ",
- path.theo1.theo2,
- "\n\n============\n\n"
- )
- )
- }
- }
-}
-tempo <- fun_check( data = single.corr, options = c("VALUE", "MAX", "DEC1", "QUART1", "MED", "MIN", "NO"), length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = print.count, typeof = "integer", double.as.integer.allowed = TRUE, neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = keep, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = ratio.limit.sig, class = "vector", mode = "numeric", neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-if (tempo$problem == FALSE & ratio.limit.sig < 1) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: ratio.limit.sig PARAMETER MUST EQUAL OR GREATER THAN 1: ",
- ratio.limit.sig,
- "\n\n============\n\n"
- )
- )
-}
-tempo <- fun_check( data = error, prop = TRUE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = range.split, class = "vector", mode = "numeric", neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = step.factor, class = "vector", mode = "numeric", neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-if (tempo$problem == FALSE & step.factor < 1) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: step.factor PARAMETER MUST EQUAL OR GREATER THAN 1: ",
- ratio.limit.sig,
- "\n\n============\n\n"
- )
- )
-}
-tempo <- fun_check( data = ratio.normalization, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = activate.pdf, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = optional.text, class = "vector", typeof = "character", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = width.wind, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = height.wind, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = dot.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = line.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = heatmap.text.size, class = "vector", mode = "numeric", neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = text.size, class = "vector", neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = title.text.size, class = "vector", neg.values = FALSE, length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = raster, class = "vector", typeof = "logical", length = 1, fun.name = "SLITHERINE") ; eval(ee)
-tempo <- fun_check( data = transfo, options = c("log2", "log10"), length = 1, fun.name = "SLITHERINE") ; eval(ee)
-if (any(param.check) == TRUE) {
- print("line.size")
- print(line.size)
- print(param.check)
- stop() # nothing else because print = TRUE by default in fun_check()
-}
-
-################ End pre-ignition checking
-
-
-################ Ignition
-
-
-function.name <- "slitherine.R EXECUTION"
-set.seed(1014)
-options(scipen = 7)
-analysis.nb <-
- trunc(as.numeric(Sys.time())) # to provide a specific number ot each analysis
-log.file <- paste0(project.name, "_", analysis.nb, "_report.txt")
-name.dir <- paste0(project.name, "_", analysis.nb)
-## peut etre à enlever
-if (dir.exists(path.out)) {
- tempo.cat <- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: DIRECTORY ALREADY EXISTS: ",
- path.out,
- "\n\n============\n\n"
- )
- stop(tempo.cat)
-} else{
- suppressWarnings(dir.create(path.out))
-}
-cat("\nSLITHERINE IGNITION\n")
-fun_report(
- data = paste0(
- "\n\n################################ ",
- log.file,
- " ################"
- ),
- output = log.file,
- no.overwrite = FALSE,
- path = path.out,
- sep = 4
-)
-ini.date <- Sys.time()
-ini.time <-
- as.numeric(ini.date) # time of process begin, converted into seconds
-fun_report(
- "\n\n################################ RUNNING DATE AND STARTING TIME",
- output = log.file,
- path = path.out
-)
-fun_report(
- data = ini.date,
- path = path.out,
- output = log.file,
- vector.cat = TRUE
-)
-cat("\nINITIAL SETTINGS AND DATA MODIFICATIONS\n")
-fun_report(
- data = "\n\n################################ INITIAL SETTINGS AND DATA MODIFICATIONS",
- path = path.out,
- output = log.file,
- sep = 4
-)
-if (optional.text != "") {
- fun_report(data = "OPTIONAL TEXT: ",
- path = path.out,
- output = log.file)
- fun_report(data = optional.text,
- path = path.out,
- output = log.file)
-}
-
-################ End ignition
-
-
-################ Graphical parameter initialization
-
-fun_open(pdf.disp = activate.pdf, pdf.name.file = "initialization")
-par.ini <-
- par(no.readonly = TRUE) # to recover the initial graphical parameters if required (reset)
-invisible(dev.off()) # close the new window
-if (activate.pdf == TRUE) {
- invisible(file.remove("/initialization.pdf"))
-}
-zone.ini <- matrix(1, ncol = 1)
-if (erase.graphs == TRUE) {
- graphics.off()
-} else{
- tempo.warning <-
- paste0("GRAPHICS HAVE NOT BEEN ERASED. GRAPHICAL PARAMETERS MAY HAVE NOT BEEN REINITIALIZED")
- fun_report(data = tempo.warning,
- path = path.out,
- output = log.file)
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
-}
-
-################ End graphical parameter initialization
-
-
-################ Data import
-
-mat1.obs.ini <-
- as.matrix(read.table(paste0(path.in, "/", file.name1)))
-mat2.obs.ini <-
- as.matrix(read.table(paste0(path.in, "/", file.name2)))
-if (theo.import == TRUE) {
- mat1.mix <-
- as.matrix(read.table(paste0(theo.path.in, "/", theo.file.name1)))
- mat2.mix <-
- as.matrix(read.table(paste0(theo.path.in, "/", theo.file.name2)))
- tempo.warning <-
- paste0(
- "IMPORT OF THEORETICAL MATRICES, WHICH WOULD MEAN THAT THE OBSERVED
- MATRICES IMPORTED HAVE ALREADY BEEN BINNED USING SERPENTINE"
- )
- cat(paste0("\nWARNING: ", tempo.warning, "\n"))
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
-
-}
-
-print("end data import")
-################ End data import
-
-
-################ Checking
-
-
-param.check <- NULL #
-checked.param.names <- NULL #
-ee <-
- expression(
- param.check <-
- c(param.check, tempo$problem) ,
- checked.param.names <-
- c(checked.param.names, tempo$param.name)
- )
-for (i0 in 1:2) {
- if (theo.import == FALSE) {
- # obs matrix must be integer for serpentine binning or for theoretical matrix design
- tempo <-
- fun_check(
- data = get(paste0("mat", i0, ".obs.ini")),
- data.name = paste0("mat", i0, ".obs.ini"),
- typeof = "integer",
- double.as.integer.allowed = TRUE,
- neg.values = FALSE,
- fun.name = "SLITHERINE"
- )
- eval(ee)
- if (tempo$problem == TRUE &
- all(typeof(get(paste0(
- "mat", i0, ".obs.ini"
- ))) %in% "character")) {
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: IMPORTED MATRIX IS TYPE \"CHARACTER\".
- CHECK THAT IT HAS NO ROW OR COLUMN NAMES, WHICH WOULD HAMPER THE MATRIX IMPORT:
- \n\nMATRIX ",
- i0,
- " (",
- get(paste0("file.name", i0)),
- "):\n\n"
- )
- )
- print(fun_head(get(paste0(
- "mat", i0, ".obs.ini"
- ))))
- cat("\n\n============\n\n")
- } else if (tempo$problem == TRUE &
- all(typeof(get(paste0(
- "mat", i0, ".obs.ini"
- ))) %in% "double")) {
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: IMPORTED MATRIX ",
- get(paste0("file.name", i0)),
- " HAS DECIMAL VALUES (TYPE \"DOUBLE\"),\nWHILE THE GENERATION OF THEORETICAL MATRICES
- REQUIRES INTEGERS (USE OF DISCRETE DISTRIBUTIONS).\nARE YOU SURE THAT theo.import PARAMETER IS
- CORRECTLY SET TO FALSE?\n\n"
- )
- )
- print(fun_head(get(paste0(
- "mat", i0, ".obs.ini"
- ))))
- cat("\n\n============\n\n")
- } else if (tempo$problem == TRUE) {
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: ",
- get(paste0("file.name", i0)),
- " PARAMETER MUST BE INTEGER MATRIX (OR DECIMAL MATRIX IF ALREADY SERPENTINE BINNED): ",
- paste(typeof(get(
- paste0("mat", i0, ".obs.ini")
- )), collapse = " "),
- "\n\n============\n\n"
- )
- )
- }
- } else{
- # obs matrix can be decimal (serpentine binned matrix imported), but theo.import must be TRUE
- tempo <-
- fun_check(
- data = get(paste0("mat", i0, ".obs.ini")),
- data.name = paste0("mat", i0, ".obs.ini"),
- class = "matrix",
- mode = "numeric",
- neg.values = FALSE,
- fun.name = "SLITHERINE"
- )
- eval(ee)
- if (tempo$problem == TRUE &
- all(typeof(get(paste0(
- "mat", i0, ".obs.ini"
- ))) %in% "character")) {
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: IMPORTED MATRIX IS TYPE \"CHARACTER\".
- CHECK THAT IT HAS NO ROW OR COLUMN NAMES, WHICH WOULD HAMPER THE MATRIX IMPORT:
- \n\nMATRIX ",
- i0,
- " (",
- get(paste0("file.name", i0)),
- "):\n\n"
- )
- )
- print(fun_head(get(paste0(
- "mat", i0, ".obs.ini"
- ))))
- cat("\n\n============\n\n")
- }
- tempo <-
- fun_check(
- data = get(paste0("mat", i0, ".obs.ini")),
- data.name = paste0("mat", i0, ".obs.ini"),
- class = "matrix",
- typeof = "integer",
- double.as.integer.allowed = TRUE,
- neg.values = FALSE,
- fun.name = "SLITHERINE",
- print = FALSE
- )
- if (tempo$problem == FALSE &
- all(typeof(get(paste0(
- "mat", i0, ".obs.ini"
- ))) %in% "integer")) {
- tempo.cat <-
- paste0(
- "OBSERVED MATRIX ",
- i0,
- " MADE OF INTEGERS WHILE THEORETICAL MATRICES IMPORTED.
- ARE YOU SURE THAT OBSERVED MATRICES ARE ALREADY SERPENTINE BINNED?"
- )
- cat(paste0("\nWARNING: ", tempo.cat, "\n"))
- fun_report(data = tempo.cat,
- path = path.out,
- output = log.file)
- warning.message <-
- paste0(warning.message,
- ifelse(is.null(warning.message), "", "\n"),
- tempo.warning)
- }
- tempo <-
- fun_check(
- data = get(paste0("mat", i0, ".mix")),
- data.name = paste0("mat", i0, ".mix"),
- class = "matrix",
- mode = "numeric",
- double.as.integer.allowed = TRUE,
- neg.values = FALSE,
- fun.name = "SLITHERINE"
- )
- eval(ee)
- if (tempo$problem == TRUE &
- all(typeof(get(paste0(
- "mat", i0, ".mix"
- ))) %in% "character")) {
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: IMPORTED MATRIX IS TYPE \"CHARACTER\".
- CHECK THAT IT HAS NO ROW OR COLUMN NAMES, WHICH WOULD HAMPER THE MATRIX IMPORT:\n\n
- MATRIX ",
- i0,
- " (",
- get(paste0("file.name", i0)),
- "):\n\n"
- )
- )
- print(fun_head(get(paste0(
- "mat", i0, ".mix"
- ))))
- cat("\n\n============\n\n")
- } else if (tempo$problem == TRUE &
- !all(mode(get(paste0(
- "mat", i0, ".mix"
- ))) %in% "numeric")) {
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: ",
- paste0("theo.file.name", i0),
- " PARAMETER MUST BE DECIMAL MATRIX: ",
- paste(mode(get(
- paste0("mat", i0, ".mix")
- )),
- collapse = " "),
- "\n\n============\n\n"
- )
- )
- }
- }
-}
-tempo <- fun_comp_2d(mat1.obs.ini, mat2.obs.ini)
-if (tempo$same.dim == FALSE) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: DIMENSIONS OF MATRIX 1 AND 2 MUST BE THE SAME.
- \n\nMATRIX 1: ",
- paste(dim(mat1.obs.ini), collapse = " "),
- "\n\nMATRIX 2: ",
- paste(dim(mat2.obs.ini), collapse = " "),
- "\n\n============\n\n"
- )
- )
-} else if (tempo$dim[1] != tempo$dim[2]) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: MATRIX 1 AND 2 MUST BE SQUARE MATRICES.
- HERE DIMENSIONS ARE: ",
- paste(tempo$dim, collapse = " "),
- "\n\n============\n\n"
- )
- )
-} else if (tempo$identical.content == TRUE) {
- tempo.cat <- paste0("MATRIX 1 AND 2 HAVE IDENTICAL CONTENT")
- cat(paste0("\nWARNING: ", tempo.cat, "\n"))
- fun_report(data = tempo.cat,
- path = path.out,
- output = log.file)
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
-}
-if (theo.import == TRUE) {
- # check the variable names. Still mix ?
- for (i0 in 1:2) {
- tempo <-
- fun_check(
- data = get(paste0("mat", i0, ".mix")),
- data.name = paste0("mat", i0, ".mix"),
- class = "matrix",
- mode = "numeric",
- neg.values = FALSE,
- fun.name = "SLITHERINE"
- )
- eval(ee) # not necessary integer because serpentine binned matrices are means of binning
- if (tempo$problem == TRUE &
- all(typeof(get(paste0(
- "mat", i0, ".mix"
- ))) %in% "character")) {
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: IMPORTED MATRIX IS TYPE \"CHARACTER\".
- CHECK THAT IT HAS NO ROW OR COLUMN NAMES, WHICH WOULD HAMPER THE MATRIX IMPORT:
- \n\nMATRIX ",
- i0,
- " (",
- get(paste0("mat", i0, ".mix")),
- "):\n\n"
- )
- )
- print(fun_head(get(paste0(
- "mat", i0, ".mix"
- ))))
- cat("\n\n============\n\n")
- }
- }
- tempo <- fun_comp_2d(mat1.mix, mat2.mix)
- if (tempo$same.dim == FALSE) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: DIMENSIONS OF THEORETICAL MATRIX 1 AND 2
- MUST BE THE SAME.\n\nMATRIX 1: ",
- paste(dim(mat1.mix), collapse = " "),
- "\n\nMATRIX 2: ",
- paste(dim(mat2.mix), collapse = " "),
- "\n\n============\n\n"
- )
- )
- } else if (tempo$identical.content == TRUE) {
- tempo.cat <-
- paste0("THEORETICAL MATRIX 1 AND 2 HAVE IDENTICAL CONTENT")
- cat(paste0("\nWARNING: ", tempo.cat, "\n"))
- fun_report(data = tempo.cat,
- path = path.out,
- output = log.file)
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
- }
- if (ncol(mat1.mix) != ncol(mat1.obs.ini)) {
- param.check <- c(param.check, TRUE)
- cat(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE: NUMBER OF COLUMN MUST BE THE SAME BETWEEN THEORETICAL
- AND OBSERVED MATRICE.\n\nMATRIX 1: ",
- paste(ncol(mat1.mix), collapse = " "),
- "\n\nTHEO MATRIX 1: ",
- paste(ncol(mat1.obs.ini), collapse = " "),
- "\n\n============\n\n"
- )
- )
- }
-}
-if (any(param.check) == TRUE) {
- stop() # nothing else because print = TRUE by default in fun_check()
-}
-
-print("end data check")
-################ Info
-
-
-fun_report(
- data = "MATRIX 1 INFO:",
- path = path.out,
- output = log.file,
- sep = 1
-)
-fun_report(
- data = fun_info(mat1.obs.ini)[c("CLASS",
- "TYPE",
- "DIMENSION",
- "SUM",
- "RANGE",
- "MEAN",
- "NA.NB",
- "INF.NB")],
- path = path.out,
- output = log.file,
- sep = 1
-)
-fun_report(
- data = "MATRIX 2 INFO:",
- path = path.out,
- output = log.file,
- sep = 1
-)
-fun_report(
- data = fun_info(mat2.obs.ini)[c("CLASS",
- "TYPE",
- "DIMENSION",
- "SUM",
- "RANGE",
- "MEAN",
- "NA.NB",
- "INF.NB")],
- path = path.out,
- output = log.file,
- sep = 1
-)
-
-print("end info")
-################ End Info
-
-
-################ Modification of imported matrices
-
-
-# detection of half matrix
-mat1.modif <- FALSE
-mat2.modif <- FALSE
-if (!is.null(empty.cell.string)) {
- if (!any(mat1.obs.ini %in% empty.cell.string)) {
- # works for NA, Inf, etc.
- stop(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE\nPARAMETER empty.cell.string SET TO ",
- empty.cell.string,
- ", WHICH IS NOT PRESENT IN THE IMPORTED MATRIX 1\n\n============\n\n"
- )
- )
- }
- tempo.mat1.obs <-
- fun_mat_fill(mat = mat1.obs.ini, empty.cell.string = empty.cell.string)
- if (!is.null(tempo.mat1.obs$warn)) {
- mat1.modif <- TRUE
- fun_report(data = tempo.mat1.obs$warn,
- path = path.out,
- output = log.file)
- warning.message <-
- paste0(warning.message,
- ifelse(is.null(warning.message), "", "\n"),
- tempo.mat1.obs$warn)
- } else{
- fun_report(
- data = paste0("MATRIX 1 DETECTED AS SYMMETRIC"),
- path = path.out,
- output = log.file
- )
- }
- mat1.obs <- tempo.mat1.obs$mat
- if (!any(mat2.obs.ini %in% empty.cell.string)) {
- # works for NA, Inf, etc.
- stop(
- paste0(
- "\n\n============\n\nERROR IN SLITHERINE\nPARAMETER empty.cell.string SET TO ",
- empty.cell.string,
- ", WHICH IS NOT PRESENT IN THE IMPORTED MATRIX 2\n\n============\n\n"
- )
- )
- }
- tempo.mat2.obs <-
- fun_mat_fill(mat = mat2.obs.ini, empty.cell.string = empty.cell.string)
- if (!is.null(tempo.mat2.obs$warn)) {
- mat2.modif <- TRUE
- fun_report(data = tempo.mat2.obs$warn,
- path = path.out,
- output = log.file)
- warning.message <-
- paste0(warning.message,
- ifelse(is.null(warning.message), "", "\n"),
- tempo.mat2.obs$warn) #
- } else{
- fun_report(
- data = paste0("MATRIX 2 DETECTED AS SYMMETRIC"),
- path = path.out,
- output = log.file
- )
- }
- mat2.obs <- tempo.mat2.obs$mat
-} else{
- mat1.obs <- mat1.obs.ini
- mat2.obs <- mat2.obs.ini
- tempo.warning <-
- paste0(
- "IMPORTED MATRICES NOT DECLARED HALF FILLED BY THE USER
- (empty.cell.string PARAMETER SET TO NULL)"
- )
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning)
- fun_report(data = tempo.warning,
- path = path.out,
- output = log.file)
-}
-# detection of the matrix orientation, and t() potentially to always have the same orientation? -> done with the message provided by fun_mat_fill() and the rotate option of fun_heatmap()
-# end detection of half matrix
-
-# diagonal removal
-if (!all(unique(as.matrix(as.data.frame(
- list(1:nrow(mat1.obs), 1:ncol(mat1.obs))
-))) == 0)) {
- mat1.obs[as.matrix(as.data.frame(list(1:nrow(mat1.obs), 1:ncol(mat1.obs))))] <-
- 0
- mat1.modif <- TRUE
- tempo.warning <-
- paste0("MAIN DIAGONAL OF MATRIX 1 HAS BEEN REPLACED BY 0")
- fun_report(data = tempo.warning,
- path = path.out,
- output = log.file)
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
-}
-if (!all(unique(as.matrix(as.data.frame(
- list(1:nrow(mat2.obs), 1:ncol(mat2.obs))
-))) == 0)) {
- mat2.obs[as.matrix(as.data.frame(list(1:nrow(mat2.obs), 1:ncol(mat2.obs))))] <-
- 0
- mat2.modif <- TRUE
- tempo.warning <-
- paste0("MAIN DIAGONAL OF MATRIX 2 HAS BEEN REPLACED BY 0")
- fun_report(data = tempo.warning,
- path = path.out,
- output = log.file)
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
-}
-# end diagonal removal
-
-# heatmap: matrix checking
-if (theo.import == FALSE) {
- loop.mat.names <-
- c("mat1.obs.ini", "mat1.obs", "mat2.obs.ini", "mat2.obs")
- loop.heatmap.title <-
- c(
- "MATRIX 1 IMPORTED",
- "MATRIX 1 AFTER MODIFICATIONS",
- "MATRIX 2 IMPORTED",
- "MATRIX 2 AFTER MODIFICATIONS"
- )
-} else{
- loop.mat.names <-
- c("mat1.obs.ini",
- "mat1.obs",
- "mat2.obs.ini",
- "mat2.obs",
- "mat1.mix",
- "mat2.mix")
- loop.heatmap.title <-
- c(
- "MATRIX 1 IMPORTED",
- "MATRIX 1 AFTER MODIFICATIONS",
- "MATRIX 2 IMPORTED",
- "MATRIX 2 AFTER MODIFICATIONS",
- "THEORETICAL MATRIX 1 IMPORTED",
- "THEORETICAL MATRIX 2 IMPORTED"
- )
- s.both.heatmap.range.pre <- NULL
-}
-# graphic range (min and max value inside matrix) recovering: to have same matrix resolution
-# BEWARE: this means that I take the log2(... + 1) of the matrix that I normalize by the mean of this. Thus, I plot log2(... + 1) on get(loop.mat.names[i0]) / mean(get(loop.mat.names[i0]), na.rm = TRUE)
-s.obs.heatmap.range.pre <- NULL
-for (i0 in 1:length(loop.mat.names)) {
- # data transformtation
- if (grepl(x = loop.mat.names[i0], pattern = ".mix$")) {
- tempo.data.plot <-
- get(loop.mat.names[i0]) / adj.mean.fun(x_3fun = get(loop.mat.names[i0]),
- text_3fun = "JUST AFTER IMPORT THEO HEATMAP NORMALIZATION ACCORDING TO THE WEIGHTED DIAGONAL MEAN") # weighted diag for theo only
- } else{
- tempo.data.plot <-
- get(loop.mat.names[i0]) / mean(get(loop.mat.names[i0])[is.finite(get(loop.mat.names[i0]))],
- na.rm = TRUE) # mean normalization obs matrices
- }
- if (transfo != "no") {
- tempo.data.plot <- get(transfo)(tempo.data.plot + 1) # log transfo
- }
- # end data transformtation
- if (grepl(x = loop.mat.names[i0], pattern = ".mix$")) {
- # if theo.import == FALSE, then no.mix matrices and this condition is not filled
- s.both.heatmap.range.pre <-
- range(
- c(
- s.obs.heatmap.range.pre,
- s.both.heatmap.range.pre,
- tempo.data.plot
- ),
- na.rm = TRUE,
- finite = TRUE
- )
- } else{
- s.obs.heatmap.range.pre <-
- range(
- c(s.obs.heatmap.range.pre, tempo.data.plot),
- na.rm = TRUE,
- finite = TRUE
- )
- }
-}
-# end graphic range (min and max value inside matrix) recovering: to have same matrix resolution
-# heatmap
-loop.heatmap.title <- paste0(
- loop.heatmap.title,
- "\n",
- if (transfo == "log2") {
- "LOG2(x + 1) "
- } else if (transfo == "log10") {
- "LOG10(x + 1) "
- } else{
- "NO "
- },
- "TRANSFORMATION\nSCALE RANGE: ",
- paste(fun_round(s.obs.heatmap.range.pre, 2), collapse = " , "),
- "\nNORMALIZED DISPLAY (GLOBAL MEAN DIVISION, WHICH WOULD EXPLAIN INTENSITY VARIATION)"
-)
-for (i0 in 1:length(loop.mat.names)) {
- # data transformtation
- if (grepl(x = loop.mat.names[i0], pattern = ".mix$")) {
- tempo.data.plot <-
- get(loop.mat.names[i0]) / adj.mean.fun(x_3fun = get(loop.mat.names[i0]),
- text_3fun = "JUST AFTER IMPORT THEO HEATMAP NORMALIZATION ACCORDING TO THE WEIGHTED DIAGONAL MEAN") # weighted diag for theo only
- tempo.range <- s.both.heatmap.range.pre
- } else{
- tempo.data.plot <-
- get(loop.mat.names[i0]) / mean(get(loop.mat.names[i0])[is.finite(get(loop.mat.names[i0]))],
- na.rm = TRUE) # mean normalization obs matrices
- tempo.range <- s.obs.heatmap.range.pre
- }
- if (transfo != "no") {
- tempo.data.plot <- get(transfo)(tempo.data.plot + 1)
- }
- # end data transformation
- if (activate.pdf == TRUE) {
- if (i0 == 1) {
- fun_open(
- pdf.disp = activate.pdf,
- fun.path = path.out,
- pdf.name.file = paste0("plots_", analysis.nb),
- width.fun = width.wind,
- height.fun = height.wind
- )
- pdf.nb <- dev.cur()
- } else{
- invisible(dev.set(pdf.nb))
- }
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- if (i0 == 1) {
- fun_gg_empty_graph(text = "MATRIX MODIFICATION\nCHECKING", text.size = 3)
- }
- if ((loop.mat.names[i0] == "mat1.obs" &
- mat1.modif == FALSE) |
- (loop.mat.names[i0] == "mat2.obs" & mat2.modif == FALSE)) {
- fun_gg_empty_graph(
- title = loop.heatmap.title[i0],
- text = "NO MODIFICATION OF THE IMPORTED MATRIX\n
- (HALF FILLING\n&\nMAIN DIAGONAL REPLACEMENT BY ZERO",
- text.size = 3,
- title.size = title.text.size
- )
- } else{
- fun_gg_heatmap(
- data1 = tempo.data.plot,
- legend.name = "",
- limit1 = tempo.range,
- midpoint1 = mean(tempo.range, na.rm = TRUE),
- title = loop.heatmap.title[i0],
- text.size = heatmap.text.size,
- title.text.size = title.text.size
- )
- }
-}
-if (keep == FALSE) {
- rm(list = c("mat1.obs.ini", "mat2.obs.ini")) # not saved because initial matrices
-}
-# end heatmap
-# end heatmap: matrix checking
-
-write.table(
- mat1.obs,
- file = paste0("mat1.obs.txt"),
- row.names = FALSE,
- col.names = FALSE,
- append = FALSE,
- quote = FALSE,
- sep = "\t"
-)
-write.table(
- mat2.obs,
- file = paste0("mat2.obs.txt"),
- row.names = FALSE,
- col.names = FALSE,
- append = FALSE,
- quote = FALSE,
- sep = "\t"
-)
-
-# end export of matrices
-################ end modification of imported matrices
-
-
-################ detection of diagonales with mean zero
-
-
-if (theo.import == FALSE) {
- # means of matrix diagonales will then be modified such as when one is mean zero, the other one is also mean zero
- tempo.cat <-
- "MEANS OF MATRIX DIAGONALES ARE MODIFIED SUCH AS WHEN ONE IS MEAN ZERO, THE OTHER ONE IS ALSO MEAN ZERO"
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- # Means and sd are computed for each diagonal
- tempo.coord <-
- row(mat1.obs) - col(mat1.obs) # BEWARE: diag 0 is first diagonal and diag n-1 is last diagonal !! row(pmat)-col(pmat) generate a matrix with same number on upleft/rightdown diag, with 0 for main diag and negative number for half right part
- diag.mean.mat1.obs <-
- sapply(
- 0:-(nrow(mat1.obs) - 1),
- FUN = function(x) {
- mean(mat1.obs[tempo.coord == x], na.rm = TRUE)
- }
- ) # work on the diagonales
- diag.mean.mat2.obs <-
- sapply(
- 0:-(nrow(mat2.obs) - 1),
- FUN = function(x) {
- mean(mat2.obs[tempo.coord == x], na.rm = TRUE)
- }
- ) # work on the diagonales
- common.null.mean.pos <-
- diag.mean.mat1.obs == 0 | diag.mean.mat2.obs == 0
-
-
- ################ Analysis of observed matrices and data extraction
-
-
- # MATRIX 1
- cat("\nCOLLECTION OF DIAGONAL PARAMETERS FROM OBSERVED MATRICES\n")
- fun_report(
- data = "\n\n################################ COLLECTION OF DIAGONAL PARAMETERS FROM OBSERVED MATRICES",
- path = path.out,
- output = log.file,
- sep = 4
- )
- # Means and sd are computed for each diagonal
- tempo.coord <-
- row(mat1.obs) - col(mat1.obs) # row(pmat)-col(pmat) generate a matrix with same number on upleft/rightdown diag, with 0 for main diag and negative number for half right part
- # diag.mean.mat1.obs already obtained above
- diag.sd.mat1.obs <-
- sapply(
- 0:-(nrow(mat1.obs) - 1),
- FUN = function(x) {
- sd(mat1.obs[tempo.coord == x], na.rm = TRUE)
- }
- ) # BEWARE: the last is NA because a single value for this corner diag
- diag.cor.mat1.obs <-
- suppressWarnings(sapply(
- 0:-(nrow(mat1.obs) - 1),
- FUN = function(x) {
- cor(
- x = mat1.obs[tempo.coord == x],
- y = mat2.obs[tempo.coord == x],
- use = "pairwise.complete.obs",
- method = "spearman"
- )
- }
- )) # BEWARE: the last is NA because a single value for this corner diag # to remove the sd null message
- mean.sd.cv.cor.mat1.obs <-
- as.matrix(
- data.frame(
- MEAN = diag.mean.mat1.obs,
- SD = diag.sd.mat1.obs,
- CV = diag.sd.mat1.obs / diag.mean.mat1.obs,
- COR = diag.cor.mat1.obs
- )
- )
-
- # replacement of the NA SD CV and CORR on the last line by ZER0: no consequence because we do not use SD, we use CV for taking one of them among the max and CORR we also use high values
- if (!all(is.na(mean.sd.cv.cor.mat1.obs[nrow(mean.sd.cv.cor.mat1.obs), c("SD", "CV", "COR")]))) {
- tempo.cat <-
- paste0(
- "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\nTHE LAST LINE (I.E., CORNER DIAGONAL)
- OF mean.sd.cv.cor.mat1.obs SHOULD BE NA FOR SD, CV AND CORR, BECAUSE A SINGLE VALUE
- IN THE CORNER DIAGONAL\n\n========\n\n"
- )
- cat(tempo.cat)
- print(mean.sd.cv.cor.mat1.obs[nrow(mean.sd.cv.cor.mat1.obs),])
- stop()
- } else{
- mean.sd.cv.cor.mat1.obs[nrow(mean.sd.cv.cor.mat1.obs), c("SD", "CV", "COR")] <-
- 0
- tempo.cat <-
- paste0(
- "FOR SD, CV AND CORR COLUMNS, REPLACEMENT OF the NA IN THE LAST LINE
- (I.E., CORNER DIAGONAL) OF mean.sd.cv.cor.mat1.obs BY ZERO\nNO CONSEQUENCE BECAUSE
- WE DO NOT USE SD, WE USE CV FOR TAKING ONE OF THEM AMONG THE MAX
- AND FOR CORR WE ALSO USE HIGH VALUES\n"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(
- data = mean.sd.cv.cor.mat1.obs[nrow(mean.sd.cv.cor.mat1.obs),],
- output = log.file,
- path = path.out,
- rownames.kept = TRUE
- )
- }
-
- tempo.detect <-
- apply(mean.sd.cv.cor.mat1.obs, 2, FUN = "%in%", c(-Inf, NA, Inf)) # in the matrix
- if (all(is.na(tempo.detect[nrow(tempo.detect), c("SD", "CV", "COR")])) == TRUE &
- (tempo.detect[nrow(tempo.detect), "MEAN"] == FALSE)) {
- tempo.cat <- paste0(
- "THE LAST LINE (I.E., CORNER DIAGONAL) OF
- mean.sd.cv.cor.mat1.obs IS NA FOR SD, CV and CORR, BUT THIS IS EXPECTED BECAUSE
- A SINGLE VALUE IN THE CORNER DIAGONAL"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(data = mean.sd.cv.cor.mat1.obs[tempo.detect,],
- output = log.file,
- path = path.out)
- } else if (all(is.na(tempo.detect[nrow(tempo.detect), c("SD", "CV", "COR")])) == TRUE &
- (tempo.detect[nrow(tempo.detect), "MEAN"] == TRUE)) {
- tempo.cat <-
- paste0(
- "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\nTHE LAST LINE (I.E., CORNER DIAGONAL)
- OF mean.sd.cv.cor.mat1.obs CANNOT BE -Inf, NA OR Inf FOR THE MEAN COLUMN\n\n========\n\n"
- )
- cat(tempo.cat)
- print(mean.sd.cv.cor.mat1.obs[nrow(tempo.detect),])
- stop()
- } else if (any(tempo.detect[-nrow(tempo.detect),]) == TRUE |
- any(tempo.detect[nrow(tempo.detect), "MEAN"]) == TRUE) {
- tempo.cat <-
- paste0(
- "BEWARE: EXCEPT THE LAST ROW (I.E., CORNER DIAGONAL), ALSO PRESENCE OF -Inf, NA, OR
- Inf DETECTED IN mean.sd.cv.cor.mat1.obs, WHICH WILL PUT NA IN THEORETICAL MATRIX 1,
- WHICH IS NOT COMPATIBLE WITH SERPENTINE. REPLACEMENT OF NA WILL BE MADE THENAFTER"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(
- data = mean.sd.cv.cor.mat1.obs[apply(tempo.detect, 1, FUN = any),],
- output = log.file,
- path = path.out,
- rownames.kept = TRUE
- )
- mean.sd.cv.cor.mat1.obs[tempo.detect] <-
- NA # NA, -Inf and Inf replaced by NA
- }
-
- mean.sd.cv.cor.mat1.obs <-
- as.data.frame(mean.sd.cv.cor.mat1.obs)
- # end replacement of c(-Inf, NA, Inf) by NA
- # replacement of mean, sd, cor by zero if common null diag between mat1.obs and mat2.obs
- if (any(common.null.mean.pos)) {
- mean.sd.cv.cor.mat1.obs[common.null.mean.pos, c("MEAN", "SD", "COR")] <-
- 0
- tempo.cat <-
- paste0(
- "BEWARE: IF AT LEAST ONE OF THE OBSERVED DIAG MEAN IS ZERO,
- THE CODE WILL CONSIDER THAT THE DIAG MEANS, SD, AND CORR ARE ZERO FOR THE TWO THEO
- CORRESPONDING DIAGONALES"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- tempo.cat <- "REPLACEMENT BY ZERO IN THE THEO MAT 1"
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(
- data = mean.sd.cv.cor.mat1.obs[common.null.mean.pos,],
- output = log.file,
- path = path.out,
- rownames.kept = TRUE
- )
- }
- # end replacement of mean, sd, cor by zero if common null diag between mat1.obs and mat2.obs
- # END MATRIX 1
-
- # MATRIX 2
- # Means and sd are computed for each diagonal
- tempo.coord <-
- row(mat2.obs) - col(mat2.obs) # row(pmat)-col(pmat) generate a matrix with same number on upleft/rightdown diag, with 0 for main diag and negative number for half right part
- # diag.mean.mat2.obs already obtained above
- diag.sd.mat2.obs <- sapply(
- 0:-(nrow(mat2.obs) - 1),
- FUN = function(x) {
- sd(mat2.obs[tempo.coord == x], na.rm = TRUE)
- }
- ) # BEWARE: the last is NA because a single value for this corner diag
- diag.cor.mat2.obs <-
- suppressWarnings(sapply(
- 0:-(nrow(mat2.obs) - 1),
- FUN = function(x) {
- cor(
- x = mat1.obs[tempo.coord == x],
- y = mat2.obs[tempo.coord == x],
- use = "pairwise.complete.obs",
- method = "spearman"
- )
- }
- )) # BEWARE: the last is NA because a single value for this corner diag # to remove the sd null message
- mean.sd.cv.cor.mat2.obs <-
- as.matrix(
- data.frame(
- MEAN = diag.mean.mat2.obs,
- SD = diag.sd.mat2.obs,
- CV = diag.sd.mat2.obs / diag.mean.mat2.obs,
- COR = diag.cor.mat2.obs
- )
- )
-
- # replacement of the NA SD CV and CORR on the last line by ZER0: no consequence because we do not use SD, we use CV for taking one of them among the max and CORR we also use high values
- if (!all(is.na(mean.sd.cv.cor.mat2.obs[nrow(mean.sd.cv.cor.mat2.obs), c("SD", "CV", "COR")]))) {
- tempo.cat <-
- paste0(
- "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- THE LAST LINE (I.E., CORNER DIAGONAL) OF mean.sd.cv.cor.mat2.obs SHOULD BE NA FOR SD,
- CV AND CORR, BECAUSE A SINGLE VALUE IN THE CORNER DIAGONAL\n\n========\n\n"
- )
- cat(tempo.cat)
- print(mean.sd.cv.cor.mat2.obs[nrow(mean.sd.cv.cor.mat2.obs),])
- stop()
- } else{
- mean.sd.cv.cor.mat2.obs[nrow(mean.sd.cv.cor.mat2.obs), c("SD", "CV", "COR")] <-
- 0
- tempo.cat <-
- paste0(
- "FOR SD, CV AND CORR COLUMNS, REPLACEMENT OF the NA IN THE LAST LINE
- (I.E., CORNER DIAGONAL) OF mean.sd.cv.cor.mat2.obs BY ZERO\n
- NO CONSEQUENCE BECAUSE WE DO NOT USE SD, WE USE CV FOR TAKING ONE OF THEM AMONG
- THE MAX AND FOR CORR WE ALSO USE HIGH VALUES\n"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(
- data = mean.sd.cv.cor.mat2.obs[nrow(mean.sd.cv.cor.mat2.obs),],
- output = log.file,
- path = path.out,
- rownames.kept = TRUE
- )
- }
-
- tempo.detect <-
- apply(mean.sd.cv.cor.mat2.obs, 2, FUN = "%in%", c(-Inf, NA, Inf)) # in the matrix
- if (all(is.na(tempo.detect[nrow(tempo.detect), c("SD", "CV", "COR")])) == TRUE &
- (tempo.detect[nrow(tempo.detect), "MEAN"] == FALSE)) {
- tempo.cat <-
- paste0(
- "THE LAST LINE (I.E., CORNER DIAGONAL) OF mean.sd.cv.cor.mat2.obs IS NA FOR SD,
- CV and CORR, BUT THIS IS EXPECTED BECAUSE A SINGLE VALUE IN THE CORNER DIAGONAL"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(data = mean.sd.cv.cor.mat2.obs[tempo.detect,],
- output = log.file,
- path = path.out)
- } else if (all(is.na(tempo.detect[nrow(tempo.detect), c("SD", "CV", "COR")])) == TRUE &
- (tempo.detect[nrow(tempo.detect), "MEAN"] == TRUE)) {
- tempo.cat <-
- paste0(
- "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- THE LAST LINE (I.E., CORNER DIAGONAL) OF mean.sd.cv.cor.mat2.obs CANNOT BE
- -Inf, NA OR Inf FOR THE MEAN COLUMN\n\n========\n\n"
- )
- cat(tempo.cat)
- print(mean.sd.cv.cor.mat2.obs[nrow(tempo.detect),])
- stop()
- } else if (any(tempo.detect[-nrow(tempo.detect),]) == TRUE |
- any(tempo.detect[nrow(tempo.detect), "MEAN"]) == TRUE) {
- tempo.cat <-
- paste0(
- "BEWARE: EXCEPT THE LAST ROW (I.E., CORNER DIAGONAL), ALSO PRESENCE OF
- -Inf, NA, OR Inf DETECTED IN mean.sd.cv.cor.mat2.obs, WHICH WILL PUT NA IN THEORETICAL MATRIX 2,
- WHICH IS NOT COMPATIBLE WITH SERPENTINE. REPLACEMENT OF NA WILL BE MADE THENAFTER"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(
- data = mean.sd.cv.cor.mat2.obs[apply(tempo.detect, 1, FUN = any),],
- output = log.file,
- path = path.out,
- rownames.kept = TRUE
- )
- mean.sd.cv.cor.mat2.obs[tempo.detect] <-
- NA # NA, -Inf and Inf replaced by NA
- }
-
- mean.sd.cv.cor.mat2.obs <-
- as.data.frame(mean.sd.cv.cor.mat2.obs)
- # end replacement of c(-Inf, NA, Inf) by NA
- # replacement of mean, sd, cor by zero if common null diag between mat2.obs and mat2.obs
- if (any(common.null.mean.pos)) {
- mean.sd.cv.cor.mat2.obs[common.null.mean.pos, c("MEAN", "SD", "COR")] <-
- 0
- tempo.cat <-
- paste0(
- "BEWARE: IF AT LEAST ONE OF THE OBSERVED DIAG MEAN IS ZERO,
- THE CODE WILL CONSIDER THAT THE DIAG MEANS, SD, AND CORR ARE ZERO
- FOR THE TWO THEO CORRESPONDING DIAGONALES"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- tempo.cat <- "REPLACEMENT BY ZERO IN THE THEO MAT 2"
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(
- data = mean.sd.cv.cor.mat2.obs[common.null.mean.pos,],
- output = log.file,
- path = path.out,
- rownames.kept = TRUE
- )
- }
- # end replacement of mean, sd, cor by zero if common null diag between mat2.obs and mat2.obs
- # END MATRIX 2
-
- ################ End Analysis of observed matrices and data extraction
-
-
- ################ detection of diagonales with NA correlation
-
-
- # replacement of cor by zero if any NA correlation diag between mat1.obs and mat2.obs
- common.na.cor.pos <-
- is.na(mean.sd.cv.cor.mat1.obs$COR) |
- is.na(mean.sd.cv.cor.mat2.obs$COR)
- if (any(common.na.cor.pos)) {
- mean.sd.cv.cor.mat1.obs[common.na.cor.pos, "COR"] <- 0
- mean.sd.cv.cor.mat2.obs[common.na.cor.pos, "COR"] <- 0
- tempo.cat <-
- paste0(
- "BEWARE: IF AT LEAST ONE OF THE OBSERVED DIAG CORRELATION IS NA
- (POSSIBLE IF ONE SD IS 0, I.E., IDENTICAL VALUES IN THE DIAGONAL),
- THE CODE WILL CONSIDER THAT THE DIAG CORR ARE ZERO FOR THE TWO THEO CORRESPONDING DIAGONALES"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- tempo.cat <- "REPLACEMENT BY ZERO IN THE THEO MAT 1"
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(
- data = mean.sd.cv.cor.mat1.obs[common.na.cor.pos,],
- output = log.file,
- path = path.out,
- rownames.kept = TRUE
- )
- tempo.cat <- "REPLACEMENT BY ZERO IN THE THEO MAT 2"
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(
- data = mean.sd.cv.cor.mat2.obs[common.na.cor.pos,],
- output = log.file,
- path = path.out,
- rownames.kept = TRUE
- )
- }
- # end replacement of cor by zero if any NA correlation diag between mat1.obs and mat2.obs
-
- print("end detect diag NA corr")
- ################ end detection of diagonales with NA correlation
-
-
- ################ plot verification
-
- print("plot verif")
- # homogeneous scale
- m_sd.coord.obs <-
- fun_gg_scatter(
- data1 = list(L1 = if (transfo != "no") {
- get(transfo)(mean.sd.cv.cor.mat1.obs[, c("MEAN", "SD")])
- } else{
- mean.sd.cv.cor.mat1.obs[, c("MEAN", "SD")]
- }, L2 = if (transfo != "no") {
- get(transfo)(mean.sd.cv.cor.mat2.obs[,
- c("MEAN", "SD")])
- } else{
- mean.sd.cv.cor.mat2.obs[, c("MEAN", "SD")]
- }),
- x = list(L1 = "MEAN", L2 = "MEAN"),
- y = list(L1 = "SD", L2 = "SD"),
- geom = list("geom_point", "geom_point"),
- alpha = list(0.5, 0.5),
- x.log = transfo,
- y.log = transfo,
- plot = FALSE,
- return = TRUE
- )
- m_sd.x.range <- m_sd.coord.obs$axes$x.range
- m_sd.y.range <- m_sd.coord.obs$axes$y.range
- m_cor.coord.obs <- fun_gg_scatter(
- data1 = list(
- L1 = data.frame(MEAN = if (transfo != "no") {
- get(transfo)(mean.sd.cv.cor.mat1.obs[, "MEAN"])
- } else{
- mean.sd.cv.cor.mat1.obs[, "MEAN"]
- }, mean.sd.cv.cor.mat1.obs["COR"]),
- L2 = data.frame(MEAN = if (transfo != "no") {
- get(transfo)(mean.sd.cv.cor.mat2.obs[, "MEAN"])
- } else{
- mean.sd.cv.cor.mat2.obs[, "MEAN"]
- }, mean.sd.cv.cor.mat2.obs["COR"])
- ),
- x = list(L1 = "MEAN", L2 = "MEAN"),
- y = list(L1 = "COR", L2 = "COR"),
- geom = list("geom_point", "geom_point"),
- alpha = list(0.5, 0.5),
- x.log = transfo,
- y.log = "no",
- plot = FALSE,
- return = TRUE,
- y.lim = c(-1, 1)
- )
- m_cor.x.range <- m_cor.coord.obs$axes$x.range
- m_cor.y.range <- m_cor.coord.obs$axes$y.range
- m_cv.coord.obs <- fun_gg_scatter(
- data1 = list(L1 = if (transfo != "no") {
- get(transfo)(mean.sd.cv.cor.mat1.obs[, c("MEAN", "CV")])
- } else{
- mean.sd.cv.cor.mat1.obs[, c("MEAN", "CV")]
- },
- L2 = if (transfo != "no") {
- get(transfo)(mean.sd.cv.cor.mat2.obs[, c("MEAN", "CV")])
- } else{
- mean.sd.cv.cor.mat2.obs[, c("MEAN", "CV")]
- }),
- x = list(L1 = "MEAN", L2 = "MEAN"),
- y = list(L1 = "CV", L2 = "CV"),
- geom = list("geom_point", "geom_point"),
- alpha = list(0.5, 0.5),
- x.log = transfo,
- y.log = transfo,
- plot = FALSE,
- return = TRUE
- )
- m_cv.x.range <- m_cv.coord.obs$axes$x.range
- m_cv.y.range <- m_cv.coord.obs$axes$y.range
- # end homogeneous scale
- print("mada daijoubu")
- # MATRIX1
- # heatmap: matrix checking
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- fun_gg_empty_graph(text = "OBSERVED MATRIX 1:\nCOLLECTION OF DIAGONAL PARAMETERS", text.size = 3)
-
- tempo.data.plot <- mean.sd.cv.cor.mat1.obs
- tempo.data.plot2 <-
- data.frame(
- MEAN = tempo.data.plot$MEAN,
- MEAN.MINUS.SD = tempo.data.plot$MEAN - tempo.data.plot$SD,
- MEAN.PLUS.SD = tempo.data.plot$MEAN + tempo.data.plot$SD
- ) # created here to be before log transformation
- if (transfo != "no") {
- tempo.data.plot[, c("MEAN", "SD", "CV")] <-
- get(transfo)(tempo.data.plot[, c("MEAN", "SD", "CV")]) # log(x + 1) only for heatmap
- tempo.data.pois <-
- data.frame(
- x.pois = tempo.data.plot$MEAN,
- y.sd.pois = tempo.data.plot$MEAN / 2,
- y.cv.pois = get(transfo)(1) - tempo.data.plot$MEAN / 2
- ) # because poisson distrib is mean = variance, thus sd = mean ^0.5, ie each mean as x is square rooted for y and then x.MEAN / 2 because log2(mean^0.5) = 0.5 * log2(mean). For cv, cv = sd/m -> log(cv) = log(sd/m) = log(m/m^0.5) = log(1/m^0.5) = log(1) - log(m^0.5) = log(1) - log(m)/2
- } else{
- tempo.data.pois <-
- data.frame(
- x.pois = tempo.data.plot$MEAN,
- y.sd.pois = tempo.data.plot$MEAN ^ 0.5,
- y.cv.pois = 1 / tempo.data.plot$MEAN ^
- 0.5
- )
- }
-
- # mean versus index plot
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- if (transfo != "no") {
- tempo.data.plot2 <-
- suppressWarnings(get(transfo)(tempo.data.plot2)) # log(x + 1) only for heatmap
- if (any(is.na(tempo.data.plot2$MEAN.MINUS.SD))) {
- tempo.data.plot2$MEAN.MINUS.SD[is.na(tempo.data.plot2$MEAN.MINUS.SD)] <-
- tempo.data.plot2$MEAN[is.na(tempo.data.plot2$MEAN.MINUS.SD)]
- }
- }
-
- tempo.data.plot2 <-
- data.frame(COLUMN_NB = 1:nrow(tempo.data.plot2), tempo.data.plot2)
- tempo.title <-
- paste0(
- "MAT1 OBS\nMEAN PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x)\n
- ABSENT SD IF LOG2(M - SD) < 0 "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x)
- \nABSENT SD IF LOG10(M - SD) < 0 "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nDIAGONAL NB FROM MAIN TO CORNER\nX SCALE RANGE: ",
- paste(range(
- 1:nrow(tempo.data.plot2),
- na.rm = TRUE,
- finite = TRUE
- ), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.x.range, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot2),
- x = list("COLUMN_NB"),
- y = list("MEAN"),
- color = list(grey(0.40)),
- geom = list("geom_point"),
- alpha = list(0.5),
- dot.size = dot.size,
- line.size = line.size,
- x.log = "no",
- x.lab = "DIAGONAL NB",
- x.tick.nb = 8,
- y.log = transfo,
- y.lab = "MEAN",
- y.lim = m_sd.x.range,
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- add = paste0(
- '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot2$COLUMN_NB,
- xend = tempo.data.plot2$COLUMN_NB, y = tempo.data.plot2$MEAN.MINUS.SD, yend = tempo.data.plot2$MEAN.PLUS.SD),
- ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
- )
- )
- # end mean versus index plot
-
- # Mean Deviation (MD) plot of the observed matrix
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.title <- paste0(
- "MAT1 OBS\nMEAN DEVIATION (MD) PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_sd.x.range, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.y.range, 2), collapse = " , "),
- "\nRED LINE: POISSON DISTRIB\n"
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot, tempo.data.pois),
- x = list("MEAN", "x.pois"),
- y = list("SD", "y.sd.pois"),
- color = list(grey(0.40), "red"),
- geom = list("geom_point", "geom_line"),
- alpha = list(0.5, 1),
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_sd.x.range,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_sd.y.range,
- y.log = transfo,
- y.lab = "SD",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
- # end Mean Deviation (MD) plot of the observed matrix
-
- # mean / cor of the observed matrix
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.title <-
- paste0(
- "MAT1 OBS\nMEAN VERSUS MAT1 OBS / MAT2 OBS SPEARMAN CORRELATION\n",
- if (transfo == "log2") {
- "MEAN LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_cor.x.range, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_cor.y.range, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = tempo.data.plot,
- x = "MEAN",
- y = "COR",
- color = grey(0.40),
- geom = "geom_point",
- alpha = 0.5,
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_cor.x.range,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_cor.y.range,
- y.log = "no",
- y.lab = "CORRELATION",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
- # end mean / cor of the observed matrix
-
- # mean / cv of the observed matrix
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.title <- paste0(
- "MAT1 OBS\nMEAN DEVIATION (MD) PLOT\n",
- if (transfo == "log2") {
- "MEAN AND CV LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND CV LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_cv.x.range, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_cv.y.range, 2), collapse = " , "),
- "\nRED LINE: POISSON DISTRIB\n"
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot, tempo.data.pois),
- x = list("MEAN", "x.pois"),
- y = list("CV", "y.cv.pois"),
- color = list(grey(0.40), "red"),
- geom = list("geom_point", "geom_line"),
- alpha = list(0.5, 1),
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_cv.x.range,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_cv.y.range,
- y.log = transfo,
- y.lab = "CV",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_cv.coord.obs
- # end mean / cv of the observed matrix
-
- # cv selection using increasing windows to detect the average constant cv
- tempo.cv.mean.mat <- mean.sd.cv.cor.mat1.obs[!(
- mean.sd.cv.cor.mat1.obs$CV == 0 |
- mean.sd.cv.cor.mat1.obs$MEAN == 0 |
- is.na(mean.sd.cv.cor.mat1.obs$MEAN) |
- is.na(mean.sd.cv.cor.mat1.obs$CV)
- ),] # remove 0 and NA in mean and CV
- sort.cv1 <- sort(tempo.cv.mean.mat$CV)
- sort.mean <-
- tempo.cv.mean.mat$MEAN[order(tempo.cv.mean.mat$CV, na.last = NA)] # means sorted like cv
- # n.cv <- length(sort.cv1)
- win.size.ini <- win.size
- if (win.size >= length(sort.cv1)) {
- tempo.warning <-
- paste0(
- "THE win.size PARAMETER SETTING (",
- win.size,
- ") IS OVER OR
- EQUAL TO THE NUMBER OF NON NA DIAGONAL CV OF THE OBSERVED MATRIX 1 (",
- length(sort.cv1),
- ")\nTHE win.size PARAMETER HAS BEEN RESET TO VALUE: ",
- length(sort.cv1) - 1
- )
- cat(paste0("\nWARNING: ", tempo.warning, "\n"))
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
- win.size <- length(sort.cv1) - 1
- fun_report(data = tempo.warning,
- output = log.file,
- path = path.out)
- }
- if (win.size < 2) {
- tempo.cat <-
- paste0(
- "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\nwin.size IS LESS THAN 2.
- NO BEST CV CAN BE COMPUTED\n\n========\n\n"
- )
- stop(tempo.cat)
- }
- if (win.size < length(sort.cv1)) {
- cv.win.mean <-
- vector("numeric", win.size - 1) # mean cv in the increasing window of the sorted cv
- cv.win.mean[] <- NA
- cv.win.sd <-
- vector("numeric", win.size - 1) # sd cv in the increasing window of the sorted cv
- cv.win.sd[] <- NA
- mean.win.median <-
- vector("numeric", win.size - 1) # median in the increasing window of the sorted mean
- mean.win.median[] <- NA
- mean.win.mean <-
- vector("numeric", win.size - 1) # for the cv selection: mean in the increasing window of the sorted mean
- mean.win.mean[] <- NA
- for (i0 in 2:win.size) {
- # to take at least 2 values, to avoid a first NA
- cv.win.mean[i0 - 1] <-
- mean(sort.cv1[1:i0], na.rm = TRUE)
- cv.win.sd[i0 - 1] <- sd(sort.cv1[1:i0], na.rm = TRUE)
- mean.win.median[i0 - 1] <-
- median(sort.mean[1:i0], na.rm = TRUE)
- mean.win.mean[i0 - 1] <-
- mean(sort.mean[1:i0], na.rm = TRUE)
- }
- if (any(is.na(cv.win.mean))) {
- tempo.cat <-
- paste0(
- "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- cv.win.mean SHOULD NOT HAVE ANY NA\n\n========\n\n"
- )
- stop(tempo.cat)
- }
- }
-
- if (any(is.na(cumsum(diff(
- cv.win.sd / mean.win.mean
- ))))) {
- tempo.cat <-
- paste0(
- "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- NO NA SHOULD BE PRESENT IN cv.win.sd / mean.win.mean\n\n========\n\n"
- )
- cat(tempo.cat)
- print(cv.win.sd / mean.win.mean)
- stop()
- } else{
- cv.select.nb <- which.min(cumsum(diff(cv.win.sd / mean.win.mean)))
- }
- i0 <- 1
- while (median(sort.cv1[i0:cv.select.nb], na.rm = TRUE) == 0 |
- median(sort.mean[i0:cv.select.nb], na.rm = TRUE) == 0) {
- # loop to avoid to take zero values in sort.cv1 and sort.mean
- i0 <- i0 + 1
- cv.select.nb <- cv.select.nb + 1
- }
- cv.select.mat1.obs <-
- median(sort.cv1[i0:cv.select.nb], na.rm = TRUE) # cv selected is the median of the xxx first cv
- mean.select.mat1.obs <-
- median(sort.mean[i0:cv.select.nb], na.rm = TRUE)
-
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.title <- paste0(
- "MAT1 OBS\nSLIDING CV COMPUTATION\n
- BLUE DOTS: MEAN+/-SD OF CV IN INCREASING WINDOWS OF CV VALUES\n
- GREEN LINE: SELECTED CV VALUE IS ",
- round(cv.select.mat1.obs, 2),
- ", BASED ON MEDIAN OF ",
- cv.select.nb,
- " BLUE DOTS\nRED LINE: POISSON DISTRIB\n",
- if (transfo == "log2") {
- "LOG2(x) "
- } else if (transfo == "log10") {
- "LOG10(x) "
- } else{
- "NO "
- },
- "TRANSFORMATION"
- )
-
- fun_gg_scatter(
- data1 = list(tempo.data.plot, tempo.data.pois),
- x = list("MEAN", "x.pois"),
- y = list("CV", "y.cv.pois"),
- color = list(grey(0.40), "red"),
- geom = list("geom_point", "geom_line"),
- alpha = list(0.5, 1),
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_cv.x.range,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_cv.y.range,
- y.log = transfo,
- y.lab = "CV",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0,
- add = paste0(
- '+ ggplot2::geom_point(data = data.frame(x = get(transfo)(mean.win.median),
- y = get(transfo)(cv.win.mean)), ggplot2::aes(x = x, y = y), color = "blue",
- size = dot.size, alpha = 0.3) + ggplot2::geom_segment(data = data.frame(x = get(transfo)(mean.win.median),
- xend = get(transfo)(mean.win.median), y = get(transfo)(cv.win.mean - cv.win.sd),
- yend = get(transfo)(cv.win.mean + cv.win.sd)), ggplot2::aes(x = x, y = y, xend = xend, yend = yend),
- color = "blue", alpha = 0.3) + ggplot2::geom_hline(data = data.frame(y = get(transfo)(cv.select.mat1.obs)),
- ggplot2::aes(yintercept = y), color = "green", size = line.size) + ggplot2::theme_classic(base_size = text.size)',
- if (raster == TRUE) {
- '+ ggplot2::theme(text = ggplot2::element_text(size = text.size),
- plot.title = ggplot2::element_text(size = title.text.size), aspect.ratio = 1)'
- } else{
- '+ ggplot2::theme(text = ggplot2::element_text(size = text.size),
- plot.title = ggplot2::element_text(size = title.text.size))'
- }
- )
- )
-
- # cv selection using increasing windows to detect the average constant cv
- # END MATRIX 1
-
-
- # MATRIX2
- # heatmap: matrix checking
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- fun_gg_empty_graph(text = "OBSERVED MATRIX 2:\nCOLLECTION OF DIAGONAL PARAMETERS", text.size = 3)
-
- tempo.data.plot <- mean.sd.cv.cor.mat2.obs
- tempo.data.plot2 <-
- data.frame(
- MEAN = tempo.data.plot$MEAN,
- MEAN.MINUS.SD = tempo.data.plot$MEAN - tempo.data.plot$SD,
- MEAN.PLUS.SD = tempo.data.plot$MEAN + tempo.data.plot$SD
- ) # created here to be before log transformation
- if (transfo != "no") {
- tempo.data.plot[, c("MEAN", "SD", "CV")] <-
- get(transfo)(tempo.data.plot[, c("MEAN", "SD", "CV")]) # log(x + 1) only for heatmap
- tempo.data.pois <-
- data.frame(
- x.pois = tempo.data.plot$MEAN,
- y.sd.pois = tempo.data.plot$MEAN / 2,
- y.cv.pois = get(transfo)(1) - tempo.data.plot$MEAN / 2
- ) # because poisson distrib is mean = variance, thus sd = mean ^0.5, ie each mean as x is square rooted for y and then x.MEAN / 2 because log2(mean^0.5) = 0.5 * log2(mean). For cv, cv = sd/m -> log(cv) = log(sd/m) = log(m/m^0.5) = log(1/m^0.5) = log(1) - log(m^0.5) = log(1) - log(m)/2
- } else{
- tempo.data.pois <-
- data.frame(
- x.pois = tempo.data.plot$MEAN,
- y.sd.pois = tempo.data.plot$MEAN ^ 0.5,
- y.cv.pois = 1 / tempo.data.plot$MEAN ^
- 0.5
- )
- }
-
-
- # mean versus index plot
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- if (transfo != "no") {
- tempo.data.plot2 <-
- suppressWarnings(get(transfo)(tempo.data.plot2)) # log(x + 1) only for heatmap
- if (any(is.na(tempo.data.plot2$MEAN.MINUS.SD))) {
- tempo.data.plot2$MEAN.MINUS.SD[is.na(tempo.data.plot2$MEAN.MINUS.SD)] <-
- tempo.data.plot2$MEAN[is.na(tempo.data.plot2$MEAN.MINUS.SD)]
- }
- }
- tempo.data.plot2 <-
- data.frame(COLUMN_NB = 1:nrow(tempo.data.plot2), tempo.data.plot2)
- tempo.title <-
- paste0(
- "MAT2 OBS\nMEAN PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x)\n
- ABSENT SD IF LOG2(M - SD) < 0 "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x)\n
- ABSENT SD IF LOG10(M - SD) < 0 "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nDIAGONAL NB FROM MAIN TO CORNER\nX SCALE RANGE: ",
- paste(range(
- 1:nrow(tempo.data.plot2),
- na.rm = TRUE,
- finite = TRUE
- ),
- collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.x.range, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot2),
- x = list("COLUMN_NB"),
- y = list("MEAN"),
- color = list(grey(0.40)),
- geom = list("geom_point"),
- alpha = list(0.5),
- dot.size = dot.size,
- line.size = line.size,
- x.log = "no",
- x.lab = "DIAGONAL NB",
- x.tick.nb = 8,
- y.log = transfo,
- y.lab = "MEAN",
- y.lim = m_sd.x.range,
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- add = paste0(
- '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot2$COLUMN_NB,
- xend = tempo.data.plot2$COLUMN_NB, y = tempo.data.plot2$MEAN.MINUS.SD, yend = tempo.data.plot2$MEAN.PLUS.SD),
- ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
- )
- )
- # end mean versus index plot
- # Mean Deviation (MD) plot of the observed matrix
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.title <- paste0(
- "MAT2 OBS\nMEAN DEVIATION (MD) PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_sd.x.range, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.y.range, 2), collapse = " , "),
- "\nRED LINE: POISSON DISTRIB\n"
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot, tempo.data.pois),
- x = list("MEAN", "x.pois"),
- y = list("SD", "y.sd.pois"),
- color = list(grey(0.40), "red"),
- geom = list("geom_point", "geom_line"),
- alpha = list(0.5, 1),
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_sd.x.range,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_sd.y.range,
- y.log = transfo,
- y.lab = "SD",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
- # end Mean Deviation (MD) plot of the observed matrix
-
- # mean / cor of the observed matrix
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.title <-
- paste0(
- "MAT2 OBS\nMEAN VERSUS MAT1 OBS / MAT2 OBS SPEARMAN CORRELATION\n",
- if (transfo == "log2") {
- "MEAN LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_cor.x.range, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_cor.y.range, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = tempo.data.plot,
- x = "MEAN",
- y = "COR",
- color = grey(0.40),
- geom = "geom_point",
- alpha = 0.5,
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_cor.x.range,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_cor.y.range,
- y.log = "no",
- y.lab = "CORRELATION",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
- # end mean / cor of the observed matrix
-
- # mean / cv of the observed matrix
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.title <- paste0(
- "MAT2 OBS\nMEAN DEVIATION (MD) PLOT\n",
- if (transfo == "log2") {
- "MEAN AND CV LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND CV LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_cv.x.range, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_cv.y.range, 2), collapse = " , "),
- "\nRED LINE: POISSON DISTRIB\n"
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot, tempo.data.pois),
- x = list("MEAN", "x.pois"),
- y = list("CV", "y.cv.pois"),
- color = list(grey(0.40), "red"),
- geom = list("geom_point", "geom_line"),
- alpha = list(0.5, 1),
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_cv.x.range,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_cv.y.range,
- y.log = transfo,
- y.lab = "CV",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_cv.coord.obs
- # end mean / cv of the observed matrix
-
- # cv selection using increasing windows to detect the average constant cv
- tempo.cv.mean.mat <- mean.sd.cv.cor.mat2.obs[!(
- mean.sd.cv.cor.mat2.obs$CV == 0 |
- mean.sd.cv.cor.mat2.obs$MEAN == 0 |
- is.na(mean.sd.cv.cor.mat2.obs$MEAN) |
- is.na(mean.sd.cv.cor.mat2.obs$CV)
- ),] # remove 0 and NA in mean and CV
- sort.cv2 <- sort(tempo.cv.mean.mat$CV)
- sort.mean <-
- tempo.cv.mean.mat$MEAN[order(tempo.cv.mean.mat$CV, na.last = NA)] # means sorted like cv
- win.size <-
- win.size.ini # in case modified during first MAT1 analysis
- if (win.size >= length(sort.cv2)) {
- tempo.warning <-
- paste0(
- "THE win.size PARAMETER SETTING (",
- win.size,
- ")
- IS OVER OR EQUAL TO THE NUMBER OF NON NA DIAGONAL CV OF THE OBSERVED MATRIX 2 (",
- length(sort.cv2),
- ")\nTHE win.size PARAMETER HAS BEEN RESET TO VALUE: ",
- length(sort.cv2) - 1
- )
- cat(paste0("\nWARNING: ", tempo.warning, "\n"))
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
- win.size <- length(sort.cv2) - 1
- fun_report(data = tempo.warning,
- output = log.file,
- path = path.out)
- }
- if (win.size < 2) {
- tempo.cat <-
- paste0(
- "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- win.size IS LESS THAN 2. NO BEST CV CAN BE COMPUTED\n\n========\n\n"
- )
- stop(tempo.cat)
- }
-
- if (win.size < length(sort.cv2)) {
- cv.win.mean <-
- vector("numeric", win.size - 1) # mean cv in the increasing window of the sorted cv
- cv.win.mean[] <- NA
- cv.win.sd <-
- vector("numeric", win.size - 1) # sd cv in the increasing window of the sorted cv
- cv.win.sd[] <- NA
- mean.win.median <-
- vector("numeric", win.size - 1) # median in the increasing window of the sorted mean
- mean.win.median[] <- NA
- mean.win.mean <-
- vector("numeric", win.size - 1) # for the cv selection: mean in the increasing window of the sorted mean
- mean.win.mean[] <- NA
- for (i0 in 2:win.size) {
- # to take at least 2 values, to avoid a first NA
- cv.win.mean[i0 - 1] <-
- mean(sort.cv2[1:i0], na.rm = TRUE)
- cv.win.sd[i0 - 1] <- sd(sort.cv2[1:i0], na.rm = TRUE)
- mean.win.median[i0 - 1] <-
- median(sort.mean[1:i0], na.rm = TRUE)
- mean.win.mean[i0 - 1] <-
- mean(sort.mean[1:i0], na.rm = TRUE)
- }
- if (any(is.na(cv.win.mean))) {
- tempo.cat <-
- paste0(
- "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\ncv.win.mean SHOULD NOT HAVE ANY NA
- \n\n========\n\n"
- )
- cat(tempo.cat)
- stop()
- }
- }
-
- if (any(is.na(cumsum(diff(
- cv.win.sd / mean.win.mean
- ))))) {
- tempo.cat <-
- paste0(
- "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- NO NA SHOULD BE PRESENT IN cv.win.sd / mean.win.mean\n\n========\n\n"
- )
- cat(tempo.cat)
- print(cv.win.sd / mean.win.mean)
- stop()
- } else{
- cv.select.nb <- which.min(cumsum(diff(cv.win.sd / mean.win.mean)))
- }
-
- i0 <- 1
- while (median(sort.cv2[i0:cv.select.nb], na.rm = TRUE) == 0 |
- median(sort.mean[i0:cv.select.nb], na.rm = TRUE) == 0) {
- # loop to avoid to take zero values in sort.cv2 and sort.mean
- i0 <- i0 + 1
- cv.select.nb <- cv.select.nb + 1
- }
- cv.select.mat2.obs <-
- median(sort.cv2[i0:cv.select.nb], na.rm = TRUE) # cv selected is the median of the xxx first cv
- mean.select.mat2.obs <-
- median(sort.mean[i0:cv.select.nb], na.rm = TRUE)
-
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
-
- tempo.title <- paste0(
- "MAT2 OBS\nSLIDING CV COMPUTATION\n
- BLUE DOTS: MEAN+/-SD OF CV IN INCREASING WINDOWS OF CV VALUES\n
- GREEN LINE: SELECTED CV VALUE IS ",
- round(cv.select.mat2.obs, 2),
- ", BASED ON MEDIAN OF ",
- cv.select.nb,
- " BLUE DOTS\nRED LINE: POISSON DISTRIB\n",
- if (transfo == "log2") {
- "LOG2(x) "
- } else if (transfo == "log10") {
- "LOG10(x) "
- } else{
- "NO "
- },
- "TRANSFORMATION"
- )
-
- fun_gg_scatter(
- data1 = list(tempo.data.plot, tempo.data.pois),
- x = list("MEAN", "x.pois"),
- y = list("CV", "y.cv.pois"),
- color = list(grey(0.40), "red"),
- geom = list("geom_point", "geom_line"),
- alpha = list(0.5, 1),
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_cv.x.range,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_cv.y.range,
- y.log = transfo,
- y.lab = "CV",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0,
- add = paste0(
- '+ ggplot2::geom_point(data = data.frame(x = get(transfo)(mean.win.median),
- y = get(transfo)(cv.win.mean)), ggplot2::aes(x = x, y = y), color = "blue", size = dot.size, alpha = 0.3) +
- ggplot2::geom_segment(data = data.frame(x = get(transfo)(mean.win.median), xend = get(transfo)(mean.win.median),
- y = get(transfo)(cv.win.mean - cv.win.sd), yend = get(transfo)(cv.win.mean + cv.win.sd)),
- ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = "blue", alpha = 0.3) +
- ggplot2::geom_hline(data = data.frame(y = get(transfo)(cv.select.mat2.obs)),
- ggplot2::aes(yintercept = y), color = "green", size = line.size) + ggplot2::theme_classic(base_size = text.size)',
- if (raster == TRUE) {
- '+ ggplot2::theme(text = ggplot2::element_text(size = text.size),
- plot.title = ggplot2::element_text(size = title.text.size), aspect.ratio = 1)'
- } else{
- '+ ggplot2::theme(text = ggplot2::element_text(size = text.size),
- plot.title = ggplot2::element_text(size = title.text.size))'
- }
- )
- )
- # cv selection using increasing windows to detect the average constant cv
- # END MATRIX 2
-
-
- ################ End plot verification
- print("end plot verif")
-
- ################ Theoretical matrices
-
-
- # MATRIX 1
- cat("\nTHEORETICAL MATRIX DESIGN\n")
- fun_report(
- data = "\n\n################################ THEORETICAL MATRIX DESIGN",
- path = path.out,
- output = log.file,
- sep = 4
- )
- n1 <- nrow(mean.sd.cv.cor.mat1.obs)
- mu1 <-
- sort(mean.sd.cv.cor.mat1.obs$MEAN,
- decreasing = TRUE,
- na.last = TRUE) # need the ordering to work on correlation (see below), decreasing = TRUE to have the first column in theo1 as the main diagonal. For non sorting: mu1 <- mean.sd.cv.cor.mat1.obs$MEAN # no sorting anymore
-
- if (cv.rho.obtained == TRUE) {
- source(path.cv.rho) #
- tempo.cat <-
- paste0(
- "BEWARE: THE SAVED FILE:\n",
- "cv1_cv2_rho1_rho2_backup.RData",
- "\nIS MAD OF VALUES COMING FROM THE DOWNLOAD OF:\n",
- path.cv.rho
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- } else{
- rho1 <-
- mean.sd.cv.cor.mat1.obs$COR[order(mean.sd.cv.cor.mat1.obs$MEAN,
- decreasing = TRUE,
- na.last = TRUE)] # for non sorting: rho1 <- mean.sd.cv.cor.mat1.obs$COR
- cv1 <- cv.select.mat1.obs # see above
- }
- # mean correction before subsampling
- # Subsampling is necessary because we cannot have any mean of a diagonal less than t = 1/cv1^2.
- # Thus, we have to multiply all the value to increase diagonal means, then use the BN law, and then subsample to go back to the initial means
- # see Negative binomial law, CV m relationship and subsampling.docx do understand the origin of these formula (equation numbers)
- t1 <- 1 / cv1 ^ 2 # equation (1)
- p1 <-
- exp(-t1 / mu1) # equation (8). Related to equation (9). In these equations, m cannot go below mt, but we do not care here for the correction
- r1 <- t1 / p1 # equation (7)
- # Beware: one sub.factor per diagonal: meaning that we do not apply the same up raising and dowsampling coeff for all the diag
- sub.factor1 = t1 / (mu1 * (1 - p1)) # equation (9), with mt = m1 (obs) and m = mean.nb1 (theo mean of NB). equation (9) / m1 -> t1 / ( mu1 * ( 1 - exp(-t1/mu1))) and sub.factor1 = m / mt, ie, sub.factor1 = mean.nb1 / m1. Thus, for the down sampling, to go back to m1, we will have to divide by sub.factor1
- mean.nb1 <- p1 * r1 / (1 - p1) # equation (2), just for graphs
- sd.nb1 <-
- (p1 * r1 / (1 - p1) ^ 2) ^ 0.5 # equation (3), just for graphs
- # end mean correction before subsampling
- # because in two contact matrix, the values in the largest diagonal, where the mean is the biggest, are very correlated, and because this correlation decreases in other diagonales when taking distance from the largest diag, we have to sort the generated values by the neg binom distrib, more or less depending on the mean used.
-
- if (is.null(n.row)) {
- n.row <- n1
- }
- mat1.ini <-
- matrix(NA, nrow = n.row, ncol = n1) # each column of mat1.ini is filled with random values according to neg binom distrib, with mean increasing for each column of mat1.ini
- # solving the fact that when p is less than 1e-16, 1-p is rounded by R to 1, which results in prob = 1 in the rnbinom() function and only 0 returned
- p1.rd <- p1
- r1.rd <- r1
- cutoff.pb <- 1e-13 # cut-off at which p is ok
- if (any(p1.rd < cutoff.pb & p1.rd > 0)) {
- cutoff.pos1 <- which.max(p1.rd < cutoff.pb & p1.rd > 0) - 1
- if (cutoff.pos1 == 0) {
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- CODE CANNOT WORK IF cutoff.pos1 IS EQUAL TO ZERO\n\n============\n\n"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- stop("\n", tempo.cat, "\n")
- } else{
- r1.rd[p1.rd < cutoff.pb &
- p1.rd > 0] <- r1.rd[cutoff.pos1] # beware: must be before p2.rd
- p1.rd[p1.rd < cutoff.pb &
- p1.rd > 0] <- p1.rd[cutoff.pos1]
- }
- }
-
- # end solving the fact that when p is less than 1e-16, 1-p is rounded by R to 1, which results in prob = 1 in the rnbinom() function and only 0 returned
- for (i1 in 1:length(mu1)) {
- if (mu1[i1] != 0) {
- # otherwise cannot compute rnbinom() because p Infinite
- mat1.ini[, i1] <-
- rnbinom(n = n.row,
- size = r1.rd[i1],
- prob = 1 - p1.rd[i1]) # because prob is the proba of success in R, while it is the proba of failure in the equation
- } else{
- mean.nb1[i1] <- 0 # just for graphs
- sd.nb1[i1] <- NA # just for graphs
- mat1.ini[, i1] <- 0
- tempo.cat <-
- paste0(
- "BEWARE: IN LOOP ",
- i1,
- ", mu1 HAS A ZERO VALUE: NO NEG BINOM LAW USED ->
- MATRIX COLUMN FILLED WITH ZERO"
- )
- # cat(paste0("\n", tempo.cat, "\n"))
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- }
- }
-
- cv.nb1 <- sd.nb1 / mean.nb1 # just for graphs
- options.ini <- options()$digits
- options(digits = 22)
- if (any((cv1 ^ 2 < 1 / mean.nb1[!(is.na(mean.nb1) |
- !is.finite(1 / mean.nb1))]) | (sapply(FUN = all.equal, 1 / mean.nb1[!(is.na(mean.nb1) |
- !is.finite(1 / mean.nb1))], cv1 ^ 2) == TRUE))) {
- # because we need sigma^2 > mean.nb1 for neg binom (otherwise, we have to use poisson)
- # Then sigma^2 / mean.nb1^2 < mean.nb1 / mean.nb1^2 -> cv1^2 > 1/mean.nb1
- tempo.cat <-
- paste0(
- "\n\n========\n\nPROBLEM: cv1 PARAMETER MUST BE SUCH THAT cv1^2 > 1/mean.nb1\ncv1 : ",
- cv1,
- "\ncv1^2 : ",
- cv1 ^ 2,
- "\nmean.nb1 VALUES DO NOT RESPECTING THE FORMULA (ZERO NOT CONSIDERED): ",
- paste(mean.nb1[!(is.na(mean.nb1) |
- !is.finite(1 / mean.nb1))][cv1 ^ 2 <= 1 / mean.nb1[!(is.na(mean.nb1) |
- !is.finite(1 / mean.nb1))]], collapse = " "),
- "\n1/mean.nb1: ",
- paste(1 / mean.nb1[!(is.na(mean.nb1) |
- !is.finite(1 / mean.nb1))][cv1 ^ 2 <= 1 / mean.nb1[!(is.na(mean.nb1) |
- !is.finite(1 / mean.nb1))]], collapse = " "),
- "\n\n========\n\n"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- }
- options(digits = options.ini)
-
-
- # MATRIX 2
- # see matrix1 for the explanaition
- n2 <- nrow(mean.sd.cv.cor.mat2.obs)
- if (!identical(n1, n2)) {
- # important
- tempo.cat <-
- paste0(
- "\n\n================\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- THE TWO ROW NUMBERS OF OBS MAT1 AND MAT2 ARE DIFFERENT: ",
- paste(c(n1, n2), collapse = " "),
- "\n\n================\n\n"
- ) # message for developers
- stop(tempo.cat)
- }
- mu2 <-
- sort(mean.sd.cv.cor.mat2.obs$MEAN,
- decreasing = TRUE,
- na.last = TRUE) # need the ordering to work on correlation (see below). For non sorting: mu2 <- mean.sd.cv.cor.mat2.obs$MEAN # no sorting anymore
- if (cv.rho.obtained == TRUE) {
-
- } else{
- rho2 <-
- mean.sd.cv.cor.mat2.obs$COR[order(mean.sd.cv.cor.mat2.obs$MEAN,
- decreasing = TRUE,
- na.last = TRUE)] # rho2 <- mean.sd.cv.cor.mat2.obs$COR
- cv2 <- cv.select.mat2.obs # see above
- }
-
- if (!identical(sort(rho1), sort(rho2))) {
- # important because rho1 will be modified, and rho2 kept as the initial correlation between obs mat1 and mat2
- tempo.cat <-
- paste0(
- "\n\n================\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- THE TWO CORRELATIONS rho1 AND rho2 ARE NOT IDENTICAL\n\n================\n\n"
- ) # message for developers
- stop(tempo.cat)
- }
- save(list = c("cv1", "rho1", "cv2", "rho2"),
- file = "cv1_cv2_rho1_rho2_backup.RData")
- tempo.cat <-
- paste0(
- "CORRELATIONS AND SELECTED COEFFICIENTS OF VARIATION SAVED IN: ",
- "cv1_cv2_rho1_rho2_backup.RData"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
-
- t2 <- 1 / cv2 ^ 2 # equation (1)
- p2 <-
- exp(-t2 / mu2) # equation (8). Related to equation (9). In these equations, m cannot go below mt, but we do not care here for the correction
- r2 <- t2 / p2 # equation (7)
- sub.factor2 = t2 / (mu2 * (1 - p2)) # equation (9), with mt = m2 (obs) and m = mean.nb2 (theo mean of NB). equation (9) / m2 -> t2 / ( mu2 * ( 1 - exp(-t2/mu2))) and sub.factor2 = m / mt, ie, sub.factor2 = mean.nb2 / m2. Thus, for the down sampling, to go back to m2, we will have to divide by sub.factor2
- mean.nb2 <- p2 * r2 / (1 - p2) # equation (2), just for graphs
- sd.nb2 <-
- (p2 * r2 / (1 - p2) ^ 2) ^ 0.5 # equation (3), just for graphs
- mat2.ini <-
- matrix(NA, nrow = n.row, ncol = n2) # each column of mat2.ini is filled with random values according to neg binom distrib, with mean increasing for each column of mat2.ini. n.row defined above
- # solving the fact that when p is less than 1e-16, 1-p is rounded by R to 1, which results in prob = 1 in the rnbinom() function and only 0 returned
- p2.rd <- p2
- r2.rd <- r2
- # cutoff.pb # defined above for Mat1
- if (any(p2.rd < cutoff.pb & p2.rd > 0)) {
- cutoff.pos2 <- which.max(p2.rd < cutoff.pb & p2.rd > 0) - 1
- if (cutoff.pos2 == 0) {
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- CODE CANNOT WORK IF cutoff.pos2 IS EQUAL TO ZERO\n\n============\n\n"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- stop("\n", tempo.cat, "\n")
- } else{
- r2.rd[p2.rd < cutoff.pb &
- p2.rd > 0] <- r2.rd[cutoff.pos2] # beware: must be before p2.rd
- p2.rd[p2.rd < cutoff.pb &
- p2.rd > 0] <- p2.rd[cutoff.pos2]
- }
- }
-
- # end solving the fact that when p is less than 1e-16, 1-p is rounded by R to 1, which results in prob = 1 in the rnbinom() function and only 0 returned
- for (i1 in 1:length(mu2)) {
- if (mu2[i1] != 0) {
- # otherwise cannot compute rnbinom() because p Infinite
- mat2.ini[, i1] <-
- rnbinom(n = n.row,
- size = r2.rd[i1],
- prob = 1 - p2.rd[i1]) # because prob is the proba of success in R, while it is the proba of failure in the equation
- } else{
- mean.nb2[i1] <- 0
- sd.nb2[i1] <- NA
- mat2.ini[, i1] <- 0
- tempo.cat <-
- paste0(
- "BEWARE: IN LOOP ",
- i1,
- ", mu2 HAS A ZERO VALUE: NO NEG BINOM LAW USED ->
- MATRIX COLUMN FILLED WITH ZERO"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- }
- }
- cv.nb2 <- sd.nb2 / mean.nb2
- options.ini <- options()$digits
- options(digits = 22)
- if (any((cv2 ^ 2 < 1 / mean.nb2[!(is.na(mean.nb2) |
- !is.finite(1 / mean.nb2))]) |
- (sapply(FUN = all.equal, 1 / mean.nb2[!(is.na(mean.nb2) |
- !is.finite(1 / mean.nb2))], cv2 ^ 2) == TRUE))) {
- # because we need sigma^2 > mean.nb2 for neg binom (otherwise, we have to use poisson)
- # Then sigma^2 / mean.nb2^2 > mean.nb2 / mean.nb2^2 -> cv2^2 > 1/mean.nb2
- tempo.cat <-
- paste0(
- "\n\n========\n\nPROBLEM: cv2 PARAMETER MUST BE SUCH THAT cv2^2 > 1/mean.nb2\ncv2 : ",
- cv2,
- "\ncv2^2 : ",
- cv2 ^ 2,
- "\nmean.nb2 VALUES DO NOT RESPECTING THE FORMULA (ZERO NOT CONSIDERED): ",
- paste(mean.nb2[!(is.na(mean.nb2) |
- !is.finite(1 / mean.nb2))][cv2 ^ 2 <= 1 / mean.nb2[!(is.na(mean.nb2) |
- !is.finite(1 / mean.nb2))]], collapse = " "),
- "\n1/mean.nb2: ",
- paste(1 / mean.nb2[!(is.na(mean.nb2) |
- !is.finite(1 / mean.nb2))][cv2 ^ 2 <= 1 / mean.nb2[!(is.na(mean.nb2) |
- !is.finite(1 / mean.nb2))]], collapse = " "),
- "\n\n========\n\n"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- }
- options(digits = options.ini)
- print("end theorical matrices")
-
- ################ End Theoretical matrices
-
-
- ################ plot verification
-
- print("plot verif")
- # homogeneous scale
- # heatmap range
- loop.mat.names <- c("mat1.ini", "mat2.ini")
- s.both.heatmap.range.pre <- NULL
- for (i0 in 1:length(loop.mat.names)) {
- # data transformtation
- tempo.data.plot <-
- get(loop.mat.names[i0]) / adj.mean.fun(x_3fun = get(loop.mat.names[i0]),
- text_3fun = "JUST AFTER CREATION OF THEO, HEATMAP NORMALIZATION ACCORDING TO THE WEIGHTED DIAGONAL MEAN") # weighted diag for theo only
- if (transfo != "no") {
- tempo.data.plot <- get(transfo)(tempo.data.plot + 1) # log transfo
- }
- # end data transformtation
- s.both.heatmap.range.pre <-
- range(
- c(
- s.obs.heatmap.range.pre,
- s.both.heatmap.range.pre,
- tempo.data.plot
- ),
- na.rm = TRUE,
- finite = TRUE
- )
- }
-
- # end heatmap range
- # sd homogeneous scale
- tempo1 <-
- data.frame(
- MEAN = apply(
- X = mat1.ini,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ),
- SD = apply(
- mat1.ini,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- )
- )
- tempo2 <-
- data.frame(
- MEAN = apply(
- X = mat2.ini,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ),
- SD = apply(
- mat2.ini,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- )
- )
- tempo.range <-
- fun_gg_scatter(
- data1 = list(L1 = if (transfo != "no") {
- get(transfo)(tempo1)
- } else{
- tempo1
- },
- L2 = if (transfo != "no") {
- get(transfo)(tempo2)
- } else{
- tempo2
- }),
- x = list(L1 = "MEAN", L2 = "MEAN"),
- y = list(L1 = "SD", L2 = "SD"),
- geom = list("geom_point", "geom_point"),
- alpha = list(0.5, 0.5),
- x.log = transfo,
- y.log = transfo,
- plot = FALSE,
- return = TRUE
- )
- m_sd.x.range2 <-
- range(c(m_sd.x.range, tempo.range$axes$x.range),
- na.rm = TRUE,
- finite = TRUE)
- m_sd.y.range2 <-
- range(c(m_sd.y.range, tempo.range$axes$y.range),
- na.rm = TRUE,
- finite = TRUE)
- # end sd homogeneous scale
- # cv homogeneous scale
- tempo1 <- tempo1$SD / tempo1$MEAN
- tempo2 <- tempo2$SD / tempo2$MEAN
- m_cv.x.range2 <-
- range(c(m_cv.x.range, tempo1, tempo2),
- na.rm = TRUE,
- finite = TRUE)
- m_cv.y.range2 <-
- range(c(m_cv.y.range, tempo1, tempo2),
- na.rm = TRUE,
- finite = TRUE)
- # cor homogeneous scale
- m_cor.x.range2 <-
- range(c(m_cor.x.range, m_cv.x.range2),
- na.rm = TRUE,
- finite = TRUE) # because same x-axis
- m_cor.y.range2 <- m_cor.y.range # because same x-axis
- # end cor homogeneous scale
- # end sd homogeneous scale
-
- # MATRIX 1
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- fun_gg_empty_graph(text = "THEORETICAL MATRIX 1 DESIGN", text.size = 3)
- # heatmap
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.title <-
- paste0(
- "MAT1 THEO\nEACH COLUMN REPRESENTS A DIAGONAL OF MAT1 OBS (MAIN DIAG FULL OF ZERO INCLUDED)\n",
- if (transfo == "log2") {
- "LOG2(x + 1) "
- } else if (transfo == "log10") {
- "LOG10(x + 1) "
- } else{
- "NO "
- },
- "TRANSFORMATION\nSCALE RANGE: ",
- paste(fun_round(s.both.heatmap.range.pre, 2),
- collapse = " , "),
- "\nNORMALIZED DISPLAY (GLOBAL MEAN DIVISION)"
- )
- tempo.data.plot <-
- mat1.ini / adj.mean.fun(
- x_3fun = mat1.ini,
- text_3fun = "JUST AFTER CREATION,
- THEO HEATMAP NORMALIZATION ACCORDING TO THE WEIGHTED DIAGONAL MEAN"
- ) # was not here before. I tried that
- if (transfo != "no") {
- tempo.data.plot <- get(transfo)(tempo.data.plot + 1)
- }
- fun_gg_heatmap(
- data1 = tempo.data.plot,
- legend.name = "",
- limit1 = s.both.heatmap.range.pre,
- midpoint1 = mean(s.both.heatmap.range.pre, na.rm = TRUE),
- title = tempo.title,
- text.size = heatmap.text.size,
- title.text.size = title.text.size
- )
- # end heatmap
-
- # Mean Deviation (MD) plot
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- data.frame(
- MEAN = apply(
- X = mat1.ini,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ),
- SD = apply(
- mat1.ini,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- )
- )
- if (transfo != "no") {
- tempo.data.plot <-
- get(transfo)(tempo.data.plot) # log(x + 1) only for heatmap
- tempo.data.pois <-
- data.frame(
- x.pois = tempo.data.plot$MEAN,
- y.sd.pois = tempo.data.plot$MEAN / 2,
- y.cv.pois = get(transfo)(1) - tempo.data.plot$MEAN / 2
- ) # because poisson distrib is mean = variance, thus sd = mean ^0.5, ie each mean as x is square rooted for y and then x.MEAN / 2 because log2(mean^0.5) = 0.5 * log2(mean). For cv, cv = sd/m -> log(cv) = log(sd/m) = log(m/m^0.5) = log(1/m^0.5) = log(1) - log(m^0.5) = log(1) - log(m)/2
- tempo.data.negbinom <-
- data.frame(
- x.green = get(transfo)(mean.nb1),
- y.green = get(transfo)(cv.nb1 * mean.nb1)
- ) # neg binomiale distrib
- } else{
- tempo.data.pois <-
- data.frame(
- x.pois = tempo.data.plot$MEAN,
- y.sd.pois = tempo.data.plot$MEAN ^ 0.5,
- y.cv.pois = 1 / tempo.data.plot$MEAN ^
- 0.5
- )
- tempo.data.negbinom <-
- data.frame(x.green = mean.nb1, y.green = cv.nb1 * mean.nb1) # neg binomiale distrib
- }
- tempo.title <- paste0(
- "MAT1 THEO\nMEAN DEVIATION (MD) PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_sd.x.range2, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.y.range2, 2), collapse = " , "),
- "\nRED LINE: POISSON DISTRIB\nGREEN LINE: NEG BINOM DISTRIB"
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot, tempo.data.pois, tempo.data.negbinom),
- x = list("MEAN", "x.pois", "x.green"),
- y = list("SD", "y.sd.pois", "y.green"),
- color = list(grey(0.40), "red", "green"),
- geom = list("geom_point", "geom_line", "geom_line"),
- alpha = list(0.5, 1, 1),
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_sd.x.range2,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_sd.y.range2,
- y.log = transfo,
- y.lab = "SD",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
- # end Mean Deviation (MD) plot of the observed matrix
-
- # mean versus index plot
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- data.frame(
- MEAN = apply(
- X = mat1.ini,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ),
- MEAN.MINUS.SD = apply(
- X = mat1.ini,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ) - apply(
- mat1.ini,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- ),
- MEAN.PLUS.SD = apply(
- X = mat1.ini,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ) + apply(
- mat1.ini,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- )
- )
- if (transfo != "no") {
- tempo.data.plot <-
- suppressWarnings(get(transfo)(tempo.data.plot)) # log(x + 1) only for heatmap
- if (any(is.na(tempo.data.plot$MEAN.MINUS.SD))) {
- tempo.data.plot$MEAN.MINUS.SD[is.na(tempo.data.plot$MEAN.MINUS.SD)] <-
- tempo.data.plot$MEAN[is.na(tempo.data.plot$MEAN.MINUS.SD)]
- }
- }
- tempo.data.plot <-
- data.frame(COLUMN_NB = 1:nrow(tempo.data.plot), tempo.data.plot)
- tempo.title <- paste0(
- "MAT1 THEO\nMEAN PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x)\nABSENT SD IF LOG2(M - SD) < 0 "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x)\nABSENT SD IF LOG10(M - SD) < 0 "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(range(
- 1:nrow(tempo.data.plot),
- na.rm = TRUE,
- finite = TRUE
- ), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.y.range2, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot),
- x = list("COLUMN_NB"),
- y = list("MEAN"),
- color = list(grey(0.40)),
- geom = list("geom_point"),
- alpha = list(0.5),
- dot.size = dot.size,
- line.size = line.size,
- x.log = "no",
- x.lab = "COLUMN NB",
- x.tick.nb = 8,
- y.log = transfo,
- y.lab = "MEAN",
- y.lim = m_sd.y.range2,
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- add = paste0(
- '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot$COLUMN_NB,
- xend = tempo.data.plot$COLUMN_NB, y = tempo.data.plot$MEAN.MINUS.SD, yend = tempo.data.plot$MEAN.PLUS.SD),
- ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
- )
- )
- # end mean versus index plot
-
-
- # MATRIX 2
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- fun_gg_empty_graph(text = "THEORETICAL MATRIX 2 DESIGN", text.size = 3)
- # heatmap
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.title <-
- paste0(
- "MAT2 THEO\nEACH COLUMN REPRESENTS A DIAGONAL OF MAT2 OBS (MAIN DIAG FULL OF ZERO INCLUDED)\n",
- if (transfo == "log2") {
- "LOG2(x + 1) "
- } else if (transfo == "log10") {
- "LOG10(x + 1) "
- } else{
- "NO "
- },
- "TRANSFORMATION\nSCALE RANGE: ",
- paste(fun_round(s.both.heatmap.range.pre, 2),
- collapse = " , "),
- "\nNORMALIZED DISPLAY (GLOBAL MEAN DIVISION)"
- )
- tempo.data.plot <-
- mat2.ini / adj.mean.fun(
- x_3fun = mat2.ini,
- text_3fun = "JUST AFTER CREATION,
- THEO HEATMAP NORMALIZATION ACCORDING TO THE WEIGHTED DIAGONAL MEAN"
- ) # was not here before. I tried that
- if (transfo != "no") {
- tempo.data.plot <- get(transfo)(tempo.data.plot + 1)
- }
- fun_gg_heatmap(
- data1 = tempo.data.plot,
- legend.name = "",
- limit1 = s.both.heatmap.range.pre,
- midpoint1 = mean(s.both.heatmap.range.pre, na.rm = TRUE),
- title = tempo.title,
- text.size = heatmap.text.size,
- title.text.size = title.text.size
- )
- # end heatmap
-
- # Mean Deviation (MD) plot
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- data.frame(
- MEAN = apply(
- X = mat2.ini,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ),
- SD = apply(
- mat2.ini,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- )
- )
- if (transfo != "no") {
- tempo.data.plot <-
- get(transfo)(tempo.data.plot) # log(x + 1) only for heatmap
- tempo.data.pois <-
- data.frame(
- x.pois = tempo.data.plot$MEAN,
- y.sd.pois = tempo.data.plot$MEAN / 2,
- y.cv.pois = get(transfo)(1) - tempo.data.plot$MEAN / 2
- ) # because poisson distrib is mean = variance, thus sd = mean ^0.5, ie each mean as x is square rooted for y and then x.MEAN / 2 because log2(mean^0.5) = 0.5 * log2(mean). For cv, cv = sd/m -> log(cv) = log(sd/m) = log(m/m^0.5) = log(1/m^0.5) = log(1) - log(m^0.5) = log(1) - log(m)/2
- tempo.data.negbinom <-
- data.frame(
- x.green = get(transfo)(mean.nb2),
- y.green = get(transfo)(cv.nb2 * mean.nb2)
- ) # neg binomiale distrib
- } else{
- tempo.data.pois <-
- data.frame(
- x.pois = tempo.data.plot$MEAN,
- y.sd.pois = tempo.data.plot$MEAN ^ 0.5,
- y.cv.pois = 1 / tempo.data.plot$MEAN ^
- 0.5
- )
- tempo.data.negbinom <-
- data.frame(x.green = mean.nb2, y.green = cv.nb2 * mean.nb2) # neg binomiale distrib
- }
- tempo.title <- paste0(
- "MAT2 THEO\nMEAN DEVIATION (MD) PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_sd.x.range2, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.y.range2, 2), collapse = " , "),
- "\nRED LINE: POISSON DISTRIB\nGREEN LINE: NEG BINOM DISTRIB"
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot, tempo.data.pois, tempo.data.negbinom),
- x = list("MEAN", "x.pois", "x.green"),
- y = list("SD", "y.sd.pois", "y.green"),
- color = list(grey(0.40), "red", "green"),
- geom = list("geom_point", "geom_line", "geom_line"),
- alpha = list(0.5, 1, 1),
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_sd.x.range2,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_sd.y.range2,
- y.log = transfo,
- y.lab = "SD",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
- # end Mean Deviation (MD) plot
-
- # mean versus index plot
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- data.frame(
- MEAN = apply(
- X = mat2.ini,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ),
- MEAN.MINUS.SD = apply(
- X = mat2.ini,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ) - apply(
- mat2.ini,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- ),
- MEAN.PLUS.SD = apply(
- X = mat2.ini,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ) + apply(
- mat2.ini,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- )
- )
- if (transfo != "no") {
- tempo.data.plot <-
- suppressWarnings(get(transfo)(tempo.data.plot)) # log(x + 1) only for heatmap
- if (any(is.na(tempo.data.plot$MEAN.MINUS.SD))) {
- tempo.data.plot$MEAN.MINUS.SD[is.na(tempo.data.plot$MEAN.MINUS.SD)] <-
- tempo.data.plot$MEAN[is.na(tempo.data.plot$MEAN.MINUS.SD)]
- }
- }
- tempo.data.plot <-
- data.frame(COLUMN_NB = 1:nrow(tempo.data.plot), tempo.data.plot)
- tempo.title <- paste0(
- "MAT2 THEO\nMEAN PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x)\nABSENT SD IF LOG2(M - SD) < 0 "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x)\nABSENT SD IF LOG10(M - SD) < 0 "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(range(
- 1:nrow(tempo.data.plot),
- na.rm = TRUE,
- finite = TRUE
- ), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.y.range2, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot),
- x = list("COLUMN_NB"),
- y = list("MEAN"),
- color = list(grey(0.40)),
- geom = list("geom_point"),
- alpha = list(0.5),
- dot.size = dot.size,
- line.size = line.size,
- x.log = "no",
- x.lab = "COLUMN NB",
- x.tick.nb = 8,
- y.log = transfo,
- y.lab = "MEAN",
- y.lim = m_sd.y.range2,
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- add = paste0(
- '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot$COLUMN_NB,
- xend = tempo.data.plot$COLUMN_NB, y = tempo.data.plot$MEAN.MINUS.SD, yend = tempo.data.plot$MEAN.PLUS.SD),
- ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
- )
- )
- # end mean versus index plot
-
-
- ################ End plot verification
- print("end plot verif")
-
- ################ Taking correlation into account
-
-
- cat("\nINCLUDING THE OBS MAT1 / MAT2 DIAGONAL CORRELATIONS INTO THEO MATRICES\n")
- fun_report(
- data = "\n\n################################ INCLUDING THE OBS MAT1 / MAT2 DIAGONAL CORRELATIONS INTO
- THEO MATRICES",
- path = path.out,
- output = log.file,
- sep = 4
- )
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- fun_gg_empty_graph(text = "INCLUDING THE OBS\nMAT1 / MAT2\nDIAGONAL CORRELATIONS\nINTO THEO MATRICES", text.size = 3)
- # mean / cor of the observed matrix
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- data.frame(
- MEAN = (
- mean.sd.cv.cor.mat1.obs$MEAN + mean.sd.cv.cor.mat2.obs$MEAN
- ) / 2,
- COR = mean.sd.cv.cor.mat1.obs$COR
- )
- if (transfo != "no") {
- tempo.data.plot[, "MEAN"] <-
- get(transfo)(tempo.data.plot[, "MEAN"]) # log(x + 1) only for heatmap
- }
- print("mada daijoubu 1?")
- tempo.title <-
- paste0(
- "(MAT1 OBS / MAT2 OBS) MEAN VERSUS (MAT1 OBS / MAT2 OBS) SPEARMAN CORRELATION\n",
- if (transfo == "log2") {
- "MEAN LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_cor.x.range2, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_cor.y.range2, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = tempo.data.plot,
- x = "MEAN",
- y = "COR",
- color = grey(0.40),
- geom = "geom_point",
- alpha = 0.5,
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_cor.x.range2,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_cor.y.range2,
- y.log = "no",
- y.lab = "CORRELATION",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
- # end mean / cor of the observed matrix
- print("mada daijoubu 2?")
- # mean / cor of the theoretical matrices
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- suppressWarnings(data.frame(
- MEAN = (
- apply(X = mat1.ini, MARGIN = 2, FUN = "mean") +
- apply(X = mat2.ini, MARGIN = 2, FUN = "mean")
- ) / 2,
- COR = mapply(
- FUN = "cor",
- x = as.data.frame(mat1.ini),
- y = as.data.frame(mat2.ini),
- use = "pairwise.complete.obs",
- method = "spearman",
- SIMPLIFY = TRUE
- )
- ))
- if (transfo != "no") {
- tempo.data.plot[, "MEAN"] <-
- get(transfo)(tempo.data.plot[, "MEAN"]) # log(x + 1) only for heatmap
- }
- tempo.title <-
- paste0(
- "(MAT1 THEO / MAT2 THEO) MEAN VERSUS (MAT1 THEO / MAT2 THEO) SPEARMAN CORRELATION\n",
- if (transfo == "log2") {
- "MEAN LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_cor.x.range2, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_cor.y.range2, 2), collapse = " , ")
- )
- print("mada daijoubu 3?")
- fun_gg_scatter(
- data1 = tempo.data.plot,
- x = "MEAN",
- y = "COR",
- color = grey(0.40),
- geom = "geom_point",
- alpha = 0.5,
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_cor.x.range2,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_cor.y.range2,
- y.log = "no",
- y.lab = "CORRELATION",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
- # Permutation of the mat1.ini values to have the mat1.obs correlation on the diagonales between mat1 and mat2
- if (correl.mat.obtained == TRUE) {
- tempo.cat <-
- paste0(
- "BEWARE: mat1.ini, mat1.perm, mat2.ini and mat2.perm THERORETICAL MATRICES
- USED HAVE BEEN DOWNLOADED FROM:\n",
- path.theo1.theo2
- )
- cat(paste0("\n", tempo.cat, "\n"))
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- load(paste0(path.theo1.theo2))
- } else{
- if (any(is.na(mat1.ini))) {
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- SHOULD NOT HAVE ANY NA IN mat1.ini\n\n============\n\n"
- )
- cat(tempo.cat)
- stop()
- }
- if (any(is.na(mat2.ini))) {
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- SHOULD NOT HAVE ANY NA IN mat2.ini\n\n============\n\n"
- )
- cat(tempo.cat)
- stop()
- }
- print("mada daijoubu 4?")
- mat1.perm <- mat1.ini
- mat2.perm <- mat2.ini
- # modifiying rho1
- if (single.corr == "VALUE") {
- # all the observed corr between mat1.obs and mat2.obs replaced by abs.corr.limit
- rho1[!is.na(rho1)] <- abs.corr.limit
- tempo.cat <-
- paste0(
- "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND mat2.obs REPLACED BY abs.corr.limit"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- } else if (single.corr == "MAX") {
- rho1[!is.na(rho1)] <- max(rho1, na.rm = TRUE)
- tempo.cat <-
- paste0(
- "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND
- mat2.obs REPLACED BY MAX CORRELATION OF rho1: ",
- max(rho1, na.rm = TRUE)
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- } else if (single.corr == "DEC1") {
- rho1[!is.na(rho1)] <-
- quantile(rho1,
- probs = 0.1,
- type = 7,
- na.rm = TRUE)
- tempo.cat <-
- paste0(
- "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND
- mat2.obs REPLACED BY FIRST DECILE CORRELATION OF rho1: ",
- quantile(
- rho1,
- probs = 0.1,
- type = 7,
- na.rm = TRUE
- )
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- } else if (single.corr == "QUART1") {
- rho1[!is.na(rho1)] <-
- quantile(rho1,
- probs = 0.25,
- type = 7,
- na.rm = TRUE)
- tempo.cat <-
- paste0(
- "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND mat2.obs
- REPLACED BY FIRST QUARTILE CORRELATION OF rho1: ",
- quantile(
- rho1,
- probs = 0.25,
- type = 7,
- na.rm = TRUE
- )
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- } else if (single.corr == "MED") {
- rho1[!is.na(rho1)] <- median(rho1, na.rm = TRUE)
- tempo.cat <-
- paste0(
- "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND mat2.obs
- REPLACED BY THE MEDIAN CORRELATION OF rho1: ",
- median(rho1, na.rm = TRUE)
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- } else if (single.corr == "MIN") {
- rho1[!is.na(rho1)] <- min(rho1, na.rm = TRUE)
- tempo.cat <-
- paste0(
- "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND mat2.obs
- REPLACED BY MIN CORRELATION OF rho1: ",
- min(rho1, na.rm = TRUE)
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- } else if (single.corr == "NO") {
- tempo.cat <-
- paste0(
- "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND mat2.obs
- WILL BE USED FOR THE PERMUTATIONS, EXCEPT THOSE BELOW abs.corr.limit: ",
- abs.corr.limit
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- } else{
- tempo.cat <-
- paste0("\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n\n============\n\n")
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- stop("\n", tempo.cat, "\n")
- }
- # end modifiying rho1
- print("mada daijoubu 5?")
- # sorting mat1 according to the rho1 values
- for (i0 in 1:ncol(mat1.perm)) {
- if (is.na(rho1[i0])) {
- if (!all(mat1.perm[, i0] == 0)) {
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\nrho1 IS NA AND COLUMN ",
- i0,
- " OF mat1.perm IS NOT ZERO FOR LOOP:",
- i0,
- "\n\n============\n\n"
- )
- cat(tempo.cat)
- stop()
- }
- } else if (any(is.na(mat1.perm[, i0]))) {
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\nSHOULD NOT HAVE NA IN COLUMN ",
- i0,
- " OF mat1.perm\n\n============\n\n"
- )
- cat(tempo.cat)
- stop()
- } else if (rho1[i0] < 0) {
- mat1.perm[, i0] <-
- sort(mat1.perm[, i0], decreasing = TRUE) # Beware: decreasing order here because we want a negative correlation with mat2[, i0] starting at -1, and increasing during permut
- } else if (rho1[i0] >= 0) {
- mat1.perm[, i0] <-
- sort(mat1.perm[, i0], decreasing = FALSE) # Beware: increasing order here because we want a positive correlation with mat2[, i0] starting at 1, and decreasing during permut
- } else{
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n\n============\n\n"
- )
- cat(tempo.cat)
- stop()
- }
- }
- # end sorting mat1 according to the rho1 values
- # sorting mat2.perm systematically in the ascending order
- for (i0 in 1:ncol(mat2.perm)) {
- if (is.na(rho2[i0])) {
- if (!all(mat2.perm[, i0] == 0)) {
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\nrho2 IS NA AND COLUMN ",
- i0,
- " OF mat2.perm IS NOT ZERO FOR LOOP:",
- i0,
- "\n\n============\n\n"
- )
- cat(tempo.cat)
- stop()
- }
- } else if (any(is.na(mat2.perm[, i0]))) {
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\nSHOULD NOT HAVE NA IN COLUMN ",
- i0,
- " OF mat2.perm\n\n============\n\n"
- )
- cat(tempo.cat)
- stop()
- } else{
- mat2.perm[, i0] <- sort(mat2.perm[, i0], decreasing = FALSE)
- }
- }
- # end sorting mat2.perm systematically in the ascending order
- # parallelization
- perm.ini.date <-
- Sys.time() # time of process begin, converted into seconds
- perm.ini.time <-
- as.numeric(perm.ini.date) # time of process begin, converted into seconds
- tempo.cat <-
- paste0(
- "PERMUTATION RUN INITIATED ON THEO MATRICES (DIMENSION ",
- paste(dim(mat1.perm), collapse = " x "),
- ") AT: ",
- perm.ini.date
- )
- cat(paste0("\n", tempo.cat, "\n"))
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- tempo.thread.nb = parallel::detectCores(all.tests = FALSE, logical = TRUE) # detect the number of threads
- if (is.null(thread.nb)) {
- thread.nb <- tempo.thread.nb - 1
- } else if (tempo.thread.nb < thread.nb) {
- thread.nb <- tempo.thread.nb
- }
- tempo.cat <- paste0("NUMBER OF THREADS USED: ", thread.nb)
- cat(paste0("\n ", tempo.cat, "\n"))
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- # trick to correctly dispatch the amount of work per cpu
- pos.rho1.decrease <-
- order(rho1, decreasing = TRUE, na.last = NA) # remove the NA positions
- tempo.list <-
- vector("list", thread.nb) # will contain a good repartition of the higher corr per cpu
- count <- 0
- for (i0 in 1:length(pos.rho1.decrease)) {
- count <- count + 1
- tempo.list[[count]] <-
- c(tempo.list[[count]], pos.rho1.decrease[i0])
- if (count == thread.nb) {
- count <- 0
- }
- }
- tempo.list <- unlist(tempo.list)
- print("mada daijoubu 6?")
- # end trick to correctly dispatch the amount of work per cpu
- Clust <-
- parallel::makeCluster(thread.nb, outfile = "cor_parall_log.txt") # outfile to print or cat during parallelization (only possible in a file, outfile = "" do not work on windowsâ—‹)
- tempo.cat <-
- paste0("COLUMN NUMBER SPLIT FOR PARALLELISATION")
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(
- data = parallel::clusterSplit(Clust, tempo.list),
- output = log.file,
- path = path.out
- )
- paral.output.list <-
- parallel::clusterApply(
- # paral.output.list is a list made of thread.nb compartments, each made of n / thread.nb (mat theo column number) compartment. Each compartment receive the corresponding results of fun_permut(), i.e., data (permuted mat1.perm), warning message, cor (final correlation) and count (number of permutations)
- cl = Clust,
- x = parallel::clusterSplit(Clust, tempo.list),
- # split 1:ncol(mat1.perm) vector according to the number of cluster and put into x for each cpu. Allow to take only the column of mat1.perm with no NA corr
- rho1 = rho1,
- mat1.perm = mat1.perm,
- mat2.perm = mat2.perm,
- print.count = print.count,
- # very important because another R
- path.function1 = path.function1,
- req.package.list = req.package.list,
- lib.path = lib.path,
- # end very important because another R
- fun = function(x,
- mat1.perm,
- mat2.perm,
- rho1,
- print.count,
- path.function1,
- req.package.list,
- lib.path) {
- # check again: very important because another R
- process.id <- Sys.getpid()
- source(path.function1, local = .GlobalEnv)
- fun_pack(req.package = req.package.list,
- lib.path = lib.path,
- load = TRUE) # load = TRUE to be sure that functions are present in the environment. And this prevent to use R.lib.path argument of fun_python_pack()
- # end check again: very important because another R
- output <- vector("list", length(x))
- names(output) <- as.character(x) # paste0("V", x)
- # see also Protocol 100-rev0 Parallelization in R.docx
- if (exists(".Random.seed", envir = .GlobalEnv)) {
- # if .Random.seed does not exists, it means that no random operation has been performed yet in any R environment
- tempo.random.seed <- .Random.seed
- on.exit(assign(".Random.seed", tempo.random.seed, env = .GlobalEnv))
- } else{
- on.exit(set.seed(NULL)) # inactivate seeding -> return to complete randomness
- }
- for (i0 in 1:length(x)) {
- if (i0 == 1) {
- set.seed(x[i0]) # take the first number of x for seed, which is different for each parallelization
- }
- tempo.cor <-
- suppressWarnings(
- cor(
- mat1.perm[, x[i0]],
- mat2.perm[, x[i0]],
- use = "pairwise.complete.obs",
- method = "spearman"
- )
- )
- if (length(table(mat1.perm[, x[i0]])) == 1) {
- output[[i0]] <- list(
- data = mat1.perm[, x[i0]],
- warnings = paste0(
- "NO PERMUTATION PERFORMED BECAUSE MAT1 MADE OF IDENTICAL ELEMENTS: ",
- names(table(mat1.perm[, x[i0]]))
- ),
- cor = NA,
- count = 0
- )
- } else if (length(table(mat2.perm[, x[i0]])) == 1) {
- output[[i0]] <- list(
- data = mat1.perm[, x[i0]],
- warnings = paste0(
- "NO PERMUTATION PERFORMED BECAUSE MAT2 MADE OF IDENTICAL ELEMENTS: ",
- names(table(mat2.perm[, x[i0]]))
- ),
- cor = NA,
- count = 0
- )
- } else if (tempo.cor <= rho1[x[i0]]) {
- output[[i0]] <- list(
- data = mat1.perm[, x[i0]],
- warnings = paste0(
- "NO PERMUTATION PERFORMED BECAUSE THE ABSOLUTE VALUE OF THE CORRELATION ",
- fun_round(tempo.cor),
- " BETWEEN MAT1 AND MAT2 HAS BEEN DETECTED AS BELOW THE CORRELATION LIMIT PARAMETER ",
- fun_round(rho1[x[i0]])
- ),
- cor = tempo.cor,
- count = 0
- )
- } else{
- output[[i0]] <-
- fun_permut(
- data1 = mat1.perm[, x[i0]],
- data2 = mat2.perm[, x[i0]],
- seed = NULL,
- text.print = paste0("PROCESS ", process.id, " | DIAG NB ", x[i0]),
- print.count = print.count,
- cor.method = "spearman",
- cor.limit = rho1[x[i0]]
- ) # with seed = NULL, take the global random seed that already exist because set above
- }
- }
- return(output)
- }
- )
- print("mada daijoubu 7?")
- parallel::stopCluster(Clust)
- tempo.date <- Sys.time()
- tempo.time <- as.numeric(tempo.date)
- tempo.lapse <-
- round(lubridate::seconds_to_period(tempo.time - perm.ini.time))
- tempo.cat <-
- paste0(
- "PERMUTATION RUN ON THEO MATRICES ACHIEVED AT: ",
- tempo.date,
- " | TIME LAPSE: ",
- tempo.lapse
- )
- cat(paste0("\n", tempo.cat, "\n"))
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- # end parallelization
- # recover the results
- permut.list <-
- vector("list", ncol(mat1.perm)) # list containing all the columns of mat.perm permuted
- warning.list <-
- vector("list", ncol(mat1.perm)) # list containing the corresponding warnings messages
- cor.list <-
- vector("list", ncol(mat1.perm)) # list containing the corresponding final correlations
- count.list <-
- vector("list", ncol(mat1.perm)) # list containing the corresponding permutation count
- # BEWARE: erratic situations when NULL is assigned to a list. See https://stackoverflow.com/questions/7944809/assigning-null-to-a-list-element-in-r
- for (i0 in 1:length(paral.output.list)) {
- # compartment relatives to each parallelization
- for (i1 in 1:length(paral.output.list[[i0]])) {
- # compartment relatives to each diagonal inside parallelization
- permut.list[[as.integer(names(paral.output.list[[i0]])[i1])]] <-
- paral.output.list[[i0]][[i1]]$data
- names(permut.list)[as.integer(names(paral.output.list[[i0]])[i1])] <-
- names(paral.output.list[[i0]])[i1]
- warning.list[[as.integer(names(paral.output.list[[i0]])[i1])]] <-
- if (is.null(paral.output.list[[i0]][[i1]]$warn)) {
- "NO WARNING"
- } else{
- paral.output.list[[i0]][[i1]]$warn
- } # no NULL assignation in list
- names(warning.list)[as.integer(names(paral.output.list[[i0]])[i1])] <-
- names(paral.output.list[[i0]])[i1]
- cor.list[[as.integer(names(paral.output.list[[i0]])[i1])]] <-
- paral.output.list[[i0]][[i1]]$cor
- names(cor.list)[as.integer(names(paral.output.list[[i0]])[i1])] <-
- names(paral.output.list[[i0]])[i1]
- count.list[[as.integer(names(paral.output.list[[i0]])[i1])]] <-
- paral.output.list[[i0]][[i1]]$count
- names(count.list)[as.integer(names(paral.output.list[[i0]])[i1])] <-
- names(paral.output.list[[i0]])[i1]
- }
- }
- if (!identical(as.integer(names(permut.list)), sort(unlist(
- parallel::clusterSplit(Clust, tempo.list)
- )))) {
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- names(permut.list) AND sort(unlist(parallel::clusterSplit(Clust, tempo.list)))
- SHOULD BE IDENTICAL\n\n============\n\n"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- stop("\n", tempo.cat, "\n")
- }
- if (!identical(names(permut.list), names(warning.list))) {
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- names(permut.list) AND names(warning.list) SHOULD BE IDENTICAL\n\n============\n\n"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- stop("\n", tempo.cat, "\n")
- }
- if (!identical(names(permut.list), names(cor.list))) {
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- names(permut.list) AND names(cor.list) SHOULD BE IDENTICAL\n\n============\n\n"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- stop("\n", tempo.cat, "\n")
- }
- if (!identical(names(permut.list), names(count.list))) {
- tempo.cat <-
- paste0(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- names(permut.list) AND names(count.list) SHOULD BE IDENTICAL\n\n============\n\n"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- stop("\n", tempo.cat, "\n")
- }
- # end recover the results
- # result print
- tempo.cat <-
- paste0(
- "THE CORRELATION THRESHOLD SET FOR THE PERMUTATION STEP IS: ",
- paste(fun_round(as.numeric(names(
- table(rho1)
- ))), collapse = " ")
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- tempo.cat <-
- paste0(
- "THE FINAL CORRELATION BETWEEN THE COLUMNS OF MAT THEO 1 AND 2
- (OBS CORRESPONDING DIAGONAL CORRELATION) ARE:\nCOLUMN\tCORR\n",
- paste(
- names(cor.list),
- fun_round(unlist(cor.list)),
- sep = "\t",
- collapse = "\n"
- )
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- tempo.cat <-
- paste0(
- "THE ASSOCIATED WARNING MESSAGES FROM THE fun_permut() FUNCTION ARE:\n",
- paste(
- "COLUMN NB ",
- names(unlist(warning.list)),
- ": ",
- unlist(warning.list),
- collapse = "\n"
- )
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_open(
- pdf.disp = TRUE,
- fun.path = path.out,
- pdf.name.file = paste0("correlation_plots_", analysis.nb),
- width.fun = width.wind,
- height.fun = height.wind
- )
- tempo.max <-
- max(as.integer(names(permut.list)), na.rm = TRUE)
- if (tempo.max > 40) {
- cor.print.loop <- c(1:20, (tempo.max - 19):tempo.max)
- tempo.max <- 40
- tempo.cat <-
- paste0(
- "ONLY THE 20 FIRST AND 20 LAST DIAGONALS ARE PLOTTED IN THE correlation_plots.pdf FILE"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- } else{
- cor.print.loop <- 1:tempo.max
- }
- print("mada daijoubu 8?")
- count.loop <- 0
- for (i0 in cor.print.loop) {
- count.loop <- count.loop + 1
- tempo.data.plot <-
- data.frame(MAT1 = mat1.perm[, i0], MAT2 = mat2.perm[, i0])
- x.tempo.range <-
- range(tempo.data.plot[, "MAT1"], na.rm = TRUE, finite = TRUE)
- y.tempo.range <-
- range(tempo.data.plot[, "MAT2"], na.rm = TRUE, finite = TRUE)
- tempo.cor <-
- suppressWarnings(
- cor(
- x = tempo.data.plot[, "MAT1"],
- y = tempo.data.plot[, "MAT2"],
- use = "pairwise.complete.obs",
- method = "spearman"
- )
- )
- tempo.title <-
- paste0(
- "BEFORE PERMUTATION | (MAT1 THEO / MAT2 THEO) SPEARMAN CORRELATION\n
- OBS MATRIX CORRESPONDING DIAGONAL NUMBER: ",
- i0,
- "\nCORRELATION VALUE: ",
- if (is.na(tempo.cor)) {
- NA
- } else{
- fun_round(tempo.cor)
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(x.tempo.range, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(y.tempo.range, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = tempo.data.plot,
- x = "MAT1",
- y = "MAT2",
- color = grey(0.40),
- geom = "geom_point",
- alpha = 0.5,
- dot.size = dot.size,
- x.lim = if (diff(x.tempo.range) == 0) {
- c(unique(x.tempo.range) - 1, unique(x.tempo.range) + 1)
- } else{
- x.tempo.range
- },
- x.tick.nb = 8,
- y.lim = if (diff(y.tempo.range) == 0) {
- c(unique(y.tempo.range) - 1, unique(y.tempo.range) + 1)
- } else{
- y.tempo.range
- },
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = FALSE
- )
- tempo.data.plot <-
- data.frame(MAT1 = permut.list[[i0]], MAT2 = mat2.perm[, i0])
- x.tempo.range <-
- range(tempo.data.plot[, "MAT1"], na.rm = TRUE, finite = TRUE)
- y.tempo.range <-
- range(tempo.data.plot[, "MAT2"], na.rm = TRUE, finite = TRUE)
- tempo.cor <-
- suppressWarnings(
- cor(
- x = tempo.data.plot[, "MAT1"],
- y = tempo.data.plot[, "MAT2"],
- use = "pairwise.complete.obs",
- method = "spearman"
- )
- )
- tempo.title <-
- paste0(
- "AFTER PERMUTATION | (MAT1 THEO / MAT2 THEO) SPEARMAN CORRELATION\n
- OBS MATRIX CORRESPONDING DIAGONAL NUMBER: ",
- i0,
- "\nCORRELATION VALUE: ",
- if (is.na(tempo.cor)) {
- NA
- } else{
- fun_round(tempo.cor)
- },
- "\nCORRELATION INDICATED BY THE fun_permut() FUNCTION: ",
- if (is.na(cor.list[[i0]])) {
- NA
- } else{
- fun_round(cor.list[[i0]])
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(x.tempo.range, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(y.tempo.range, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = tempo.data.plot,
- x = "MAT1",
- y = "MAT2",
- color = fun_gg_palette(1),
- geom = "geom_point",
- alpha = 0.5,
- dot.size = dot.size,
- x.lim = if (diff(x.tempo.range) == 0) {
- c(unique(x.tempo.range) - 1, unique(x.tempo.range) + 1)
- } else{
- x.tempo.range
- },
- x.tick.nb = 8,
- y.lim = if (diff(y.tempo.range) == 0) {
- c(unique(y.tempo.range) - 1, unique(y.tempo.range) + 1)
- } else{
- y.tempo.range
- },
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = FALSE
- )
- cat(paste0(
- "\nPRINT CORR GRAPH NB ",
- count.loop,
- " / ",
- tempo.max,
- " (DIAG NB ",
- i0,
- ")"
- ))
- }
- cat("\n")
- dev.off()
- # end result print
- # mat1.perm filling
- for (i0 in 1:ncol(mat1.perm)) {
- mat1.perm[, i0] <-
- permut.list[[i0]] # final permutation of the values using the permuted positions
- }
- # end mat1.perm filling
- }
- print("mada daijoubu 9?")
- if (keep == FALSE) {
- tempo.list <- c("mat1.ini", "mat1.perm", "mat2.ini", "mat2.perm")
- tempo.cat <-
- paste0(
- "INITIAL AND PERMUTED THEO MATRICES SAVED IN: ",
- paste0(tempo.list, collapse = "_"),
- "_backup.RData"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- save(list = tempo.list,
- file = paste0(tempo.list, collapse = "_"),
- "_backup.RData")
- rm(list = c("mat1.ini", "mat2.ini")) # .perm still needed
- }
- # end Permutation of the mat1.ini values to have the mat1.obs correlation on the diagonales between mat1 and mat2
- # mean / cor of the theoretical matrices
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- suppressWarnings(data.frame(
- MEAN = (
- apply(X = mat1.perm, MARGIN = 2, FUN = "mean") +
- apply(X = mat2.perm, MARGIN = 2, FUN = "mean")
- ) / 2,
- COR = mapply(
- FUN = "cor",
- x = as.data.frame(mat1.perm),
- y = as.data.frame(mat2.perm),
- use = "pairwise.complete.obs",
- method = "spearman",
- SIMPLIFY = TRUE
- )
- ))
- if (transfo != "no") {
- tempo.data.plot[, "MEAN"] <-
- get(transfo)(tempo.data.plot[, "MEAN"]) # log(x + 1) only for heatmap
- }
- tempo.title <- paste0(
- "AFTER PERMUTATION\n
- (MAT1 THEO / MAT2 THEO) MEAN VERSUS (MAT1 THEO / MAT2 THEO) SPEARMAN CORRELATION\n",
- if (transfo == "log2") {
- "MEAN LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_cor.x.range2, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_cor.y.range2, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = tempo.data.plot,
- x = "MEAN",
- y = "COR",
- color = grey(0.40),
- geom = "geom_point",
- alpha = 0.5,
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_cor.x.range2,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_cor.y.range2,
- y.log = "no",
- y.lab = "CORRELATION",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
- # end mean / cor of the theoretical matrices
- print("mada daijoubu 10?")
- # correlation versus index before and after permutation
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- if (length(rho2) != length(unlist(cor.list))) {
- # important because rho1 will be modified, and rho2 kept as the initial correlation between obs mat1 and mat2
- tempo.cat <-
- paste0(
- "\n\n================\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- THE TWO CORRELATIONS rho2 AND cor.list DO NOT HAVE THE SAME LENGTH\n\n================\n\n"
- ) # message for developers
- stop(tempo.cat)
- }
- tempo.data.plot <-
- data.frame(
- CORRELATION = c(rho2, unlist(cor.list)),
- COLUMN_NB = c(1:length(rho2), 1:length(rho2)),
- KIND = rep(c("OBS", "THEO"), each = length(rho2))
- )
- tempo.title <-
- paste0(
- "SPEARMAN CORRELATION BETWEEN MAT1 OBS / MAT2 OBS\n
- COMPARISON WITH MAT1 THEO / MAT2 THEO AFTER PERMUTATION\nX SCALE RANGE: ",
- paste(range(
- 1:length(rho2), na.rm = TRUE, finite = TRUE
- ), collapse = " , "),
- "\nY SCALE RANGE: -1, 1"
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot),
- x = list("COLUMN_NB"),
- y = list("CORRELATION"),
- categ = list("KIND"),
- geom = list("geom_point"),
- alpha = list(0.5),
- dot.size = dot.size,
- line.size = line.size,
- x.log = "no",
- x.lab = "DIAGONAL INDEX",
- x.tick.nb = 8,
- y.log = "no",
- y.lab = "CORRELATION",
- y.lim = c(-1, 1),
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster
- )
- # end correlation versus index before and after permutation
-
- print("mada daijoubu 11?")
- ################ End Taking correlation into account
-
-
- ################ sub sampling
-
-
- cat("\nTHEO MATRICES SUBSAMPLING\n")
- fun_report(
- data = "\n\n################################ THEO MATRICES SUBSAMPLING",
- path = path.out,
- output = log.file,
- sep = 4
- )
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- fun_gg_empty_graph(text = "THEO MATRICES\nSUBSAMPLING", text.size = 3)
-
-
- # theoretical matrix subsampling (this allow to have smaller values on the mean x of the MD plot)
- # division of the coverage in each cell of column i0 of theo mat by sub.factor1[i0] (reduction of the coverage), and then random sampling of one value considering that the coverage is a mean coverage of the poisson law (is poisson law, lamnda = mean = variance). Thus, sapply(lambda, FUN = rpois, n = 1)
- mat1.down <- mat1.perm
- for (i0 in 1:ncol(mat1.down)) {
- if (!all(is.na(mat1.down[, i0]))) {
- mat1.down[, i0] <-
- sapply(mat1.down[, i0] / sub.factor1[i0], FUN = rpois, n = 1)
- }
- }
- mat2.down <- mat2.perm
- for (i0 in 1:ncol(mat2.down)) {
- if (!all(is.na(mat2.down[, i0]))) {
- mat2.down[, i0] <-
- sapply(mat2.down[, i0] / sub.factor2[i0], FUN = rpois, n = 1)
- }
- }
- # randomize the mat1.down row values in each column, to break the order in the first matrix, and use the same row order in mat2.down before using serpentine to keep the correlation between columns intact
- # In fact, change nothing to shuffle or not
- if (nrow(mat1.down) > 1) {
- shuffled.row.pos <-
- sample(
- x = 1:nrow(mat1.down),
- size = nrow(mat1.down),
- replace = FALSE
- )
- } else{
- stop(
- "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- A SINGLE DIAGONAL PRESENT IN THEO MATRIX 1 (mat1.down)\n\n============\n\n"
- )
- }
- # shuffling the rows of mat1.down and mat2.down (same repositionning for both matrix, to keep the relationship between rows (correlation))
- mat1.mix <- mat1.down[shuffled.row.pos,]
- mat2.mix <- mat2.down[shuffled.row.pos,]
- if (keep == FALSE) {
- tempo.list <- c("mat1.down", "mat2.down")
- tempo.cat <- paste0(
- "DOWNSAMPLED THEO MATRICES SAVED IN: ",
- paste0(tempo.list, collapse = "_"),
- "_backup.RData"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- save(list = tempo.list,
- file = paste0(tempo.list, collapse = "_"),
- "_backup.RData")
- rm(list = tempo.list) # not saved because initial matrices
- }
- # export of theo matrices before binning
-
- # end export of theo matrices before binning
- # end theoretical matrix subsampling (this allow to have smaller values on the mean x of the MD plot)
-
-
- # mean versus index plot before sub sampling
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- data.frame(
- MEAN = apply(
- X = mat1.perm,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ),
- MEAN.MINUS.SD = apply(
- X = mat1.perm,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ) -
- apply(
- mat1.perm,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- ),
- MEAN.PLUS.SD = apply(
- X = mat1.perm,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ) +
- apply(
- mat1.perm,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- )
- )
- if (transfo != "no") {
- tempo.data.plot <-
- suppressWarnings(get(transfo)(tempo.data.plot)) # log(x + 1) only for heatmap
- if (any(is.na(tempo.data.plot$MEAN.MINUS.SD))) {
- tempo.data.plot$MEAN.MINUS.SD[is.na(tempo.data.plot$MEAN.MINUS.SD)] <-
- tempo.data.plot$MEAN[is.na(tempo.data.plot$MEAN.MINUS.SD)]
- }
- }
- tempo.data.plot <-
- data.frame(COLUMN_NB = 1:nrow(tempo.data.plot), tempo.data.plot)
- tempo.title <-
- paste0(
- "MAT1 THEO\nAFTER PERMUTATION AND BEFORE SUB SAMPLING\nMEAN PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x)\nABSENT SD IF LOG2(M - SD) < 0 "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x)\nABSENT SD IF LOG10(M - SD) < 0 "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(range(
- 1:nrow(tempo.data.plot),
- na.rm = TRUE,
- finite = TRUE
- ), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.y.range2, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot),
- x = list("COLUMN_NB"),
- y = list("MEAN"),
- color = list(grey(0.40)),
- geom = list("geom_point"),
- alpha = list(0.5),
- dot.size = dot.size,
- line.size = line.size,
- x.log = "no",
- x.lab = "COLUMN NB",
- x.tick.nb = 8,
- y.log = transfo,
- y.lab = "MEAN",
- y.lim = m_sd.y.range2,
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- add = paste0(
- '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot$COLUMN_NB,
- xend = tempo.data.plot$COLUMN_NB, y = tempo.data.plot$MEAN.MINUS.SD, yend = tempo.data.plot$MEAN.PLUS.SD),
- ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
- )
- )
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- data.frame(
- MEAN = apply(
- X = mat2.perm,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ),
- MEAN.MINUS.SD = apply(
- X = mat2.perm,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ) -
- apply(
- mat2.perm,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- ),
- MEAN.PLUS.SD = apply(
- X = mat2.perm,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ) +
- apply(
- mat2.perm,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- )
- )
- if (transfo != "no") {
- tempo.data.plot <-
- suppressWarnings(get(transfo)(tempo.data.plot)) # log(x + 1) only for heatmap
- if (any(is.na(tempo.data.plot$MEAN.MINUS.SD))) {
- tempo.data.plot$MEAN.MINUS.SD[is.na(tempo.data.plot$MEAN.MINUS.SD)] <-
- tempo.data.plot$MEAN[is.na(tempo.data.plot$MEAN.MINUS.SD)]
- }
- }
- tempo.data.plot <-
- data.frame(COLUMN_NB = 1:nrow(tempo.data.plot), tempo.data.plot)
- tempo.title <-
- paste0(
- "MAT2 THEO\nAFTER PERMUTATION AND BEFORE SUB SAMPLING\nMEAN PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x)\nABSENT SD IF LOG2(M - SD) < 0 "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x)\nABSENT SD IF LOG10(M - SD) < 0 "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(range(
- 1:nrow(tempo.data.plot),
- na.rm = TRUE,
- finite = TRUE
- ),
- collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.y.range2, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot),
- x = list("COLUMN_NB"),
- y = list("MEAN"),
- color = list(grey(0.40)),
- geom = list("geom_point"),
- alpha = list(0.5),
- dot.size = dot.size,
- line.size = line.size,
- x.log = "no",
- x.lab = "COLUMN NB",
- x.tick.nb = 8,
- y.log = transfo,
- y.lab = "MEAN",
- y.lim = m_sd.y.range2,
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- add = paste0(
- '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot$COLUMN_NB,
- xend = tempo.data.plot$COLUMN_NB, y = tempo.data.plot$MEAN.MINUS.SD, yend = tempo.data.plot$MEAN.PLUS.SD),
- ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
- )
- )
- # end mean versus index plot before sub sampling
- if (keep == FALSE) {
- tempo.list <- c("mat1.perm", "mat2.perm")
- # save(list = tempo.list, file = "", paste0(tempo.list, collapse = "_"), "_backup.RData") # not saved here because already saved before
- rm(list = tempo.list) # not saved because initial matrices
- }
- # mean versus index plot after sub sampling
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- data.frame(
- MEAN = apply(
- X = mat1.mix,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ),
- MEAN.MINUS.SD = apply(
- X = mat1.mix,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ) -
- apply(
- mat1.mix,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- ),
- MEAN.PLUS.SD = apply(
- X = mat1.mix,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ) +
- apply(
- mat1.mix,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- )
- )
- if (transfo != "no") {
- tempo.data.plot <-
- suppressWarnings(get(transfo)(tempo.data.plot)) # log(x + 1) only for heatmap
- if (any(is.na(tempo.data.plot$MEAN.MINUS.SD))) {
- tempo.data.plot$MEAN.MINUS.SD[is.na(tempo.data.plot$MEAN.MINUS.SD)] <-
- tempo.data.plot$MEAN[is.na(tempo.data.plot$MEAN.MINUS.SD)]
- }
- }
- tempo.data.plot <-
- data.frame(COLUMN_NB = 1:nrow(tempo.data.plot), tempo.data.plot)
- tempo.title <-
- paste0(
- "MAT1 THEO\nAFTER PERMUTATION AND AFTER SUB SAMPLING\nMEAN PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x)\nABSENT SD IF LOG2(M - SD) < 0 "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x)\nABSENT SD IF LOG10(M - SD) < 0 "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(range(
- 1:nrow(tempo.data.plot),
- na.rm = TRUE,
- finite = TRUE
- ),
- collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.y.range2, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot),
- x = list("COLUMN_NB"),
- y = list("MEAN"),
- color = list(grey(0.40)),
- geom = list("geom_point"),
- alpha = list(0.5),
- dot.size = dot.size,
- line.size = line.size,
- x.log = "no",
- x.lab = "COLUMN NB",
- x.tick.nb = 8,
- y.log = transfo,
- y.lab = "MEAN",
- y.lim = m_sd.y.range2,
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- add = paste0(
- '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot$COLUMN_NB,
- xend = tempo.data.plot$COLUMN_NB, y = tempo.data.plot$MEAN.MINUS.SD, yend = tempo.data.plot$MEAN.PLUS.SD),
- ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
- )
- )
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- data.frame(
- MEAN = apply(
- X = mat2.mix,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ),
- MEAN.MINUS.SD = apply(
- X = mat2.mix,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ) -
- apply(
- mat2.mix,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- ),
- MEAN.PLUS.SD = apply(
- X = mat2.mix,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- ) +
- apply(
- mat2.mix,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE
- )
- )
- if (transfo != "no") {
- tempo.data.plot <-
- suppressWarnings(get(transfo)(tempo.data.plot)) # log(x + 1) only for heatmap
- if (any(is.na(tempo.data.plot$MEAN.MINUS.SD))) {
- tempo.data.plot$MEAN.MINUS.SD[is.na(tempo.data.plot$MEAN.MINUS.SD)] <-
- tempo.data.plot$MEAN[is.na(tempo.data.plot$MEAN.MINUS.SD)]
- }
- }
- tempo.data.plot <-
- data.frame(COLUMN_NB = 1:nrow(tempo.data.plot), tempo.data.plot)
- tempo.title <-
- paste0(
- "MAT2 THEO\nAFTER PERMUTATION AND AFTER SUB SAMPLING\nMEAN PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x)\nABSENT SD IF LOG2(M - SD) < 0 "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x)\nABSENT SD IF LOG10(M - SD) < 0 "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(range(
- 1:nrow(tempo.data.plot),
- na.rm = TRUE,
- finite = TRUE
- ),
- collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.y.range2, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot),
- x = list("COLUMN_NB"),
- y = list("MEAN"),
- color = list(grey(0.40)),
- geom = list("geom_point"),
- alpha = list(0.5),
- dot.size = dot.size,
- line.size = line.size,
- x.log = "no",
- x.lab = "COLUMN NB",
- x.tick.nb = 8,
- y.log = transfo,
- y.lab = "MEAN",
- y.lim = m_sd.y.range2,
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- add = paste0(
- '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot$COLUMN_NB,
- xend = tempo.data.plot$COLUMN_NB, y = tempo.data.plot$MEAN.MINUS.SD, yend = tempo.data.plot$MEAN.PLUS.SD),
- ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
- )
- )
- # end mean versus index plot after sub sampling
-
-
- # MD plot for the theoretical matrix 1 after sub sampling and permutation
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- x.MEAN <-
- apply(
- X = mat1.mix,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- )
- y.SD <- apply(mat1.mix,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE)
- tempo.data.plot <- data.frame(MEAN = x.MEAN, SD = y.SD)
- if (transfo != "no") {
- tempo.data.plot <-
- get(transfo)(tempo.data.plot) # log(x + 1) only for heatmap
- tempo.data.pois <-
- data.frame(
- x.pois = tempo.data.plot$MEAN,
- y.sd.pois = tempo.data.plot$MEAN / 2,
- y.cv.pois = get(transfo)(1) - tempo.data.plot$MEAN / 2
- ) # because poisson distrib is mean = variance, thus sd = mean ^0.5, ie each mean as x is square rooted for y and then x.MEAN / 2 because log2(mean^0.5) = 0.5 * log2(mean). For cv, cv = sd/m -> log(cv) = log(sd/m) = log(m/m^0.5) = log(1/m^0.5) = log(1) - log(m^0.5) = log(1) - log(m)/2
- tempo.data.negbinom <-
- data.frame(
- x.green = get(transfo)(mean.nb1),
- y.green = get(transfo)(cv.nb1 * mean.nb1)
- ) # neg binomiale distrib
- } else{
- tempo.data.pois <-
- data.frame(
- x.pois = tempo.data.plot$MEAN,
- y.sd.pois = tempo.data.plot$MEAN ^ 0.5,
- y.cv.pois = 1 / tempo.data.plot$MEAN ^
- 0.5
- )
- tempo.data.negbinom <-
- data.frame(x.green = mean.nb1, y.green = cv.nb1 * mean.nb1) # neg binomiale distrib
- }
- tempo.title <-
- paste0(
- "MAT1 THEO\nAFTER PERMUTATION AND SUB SAMPLING\nMEAN DEVIATION (MD) PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_sd.x.range2, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.y.range2, 2), collapse = " , "),
- "\nRED LINE: POISSON DISTRIB\nGREEN LINE: NEG BINOM DISTRIB"
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot, tempo.data.pois, tempo.data.negbinom),
- x = list("MEAN", "x.pois", "x.green"),
- y = list("SD", "y.sd.pois", "y.green"),
- color = list(grey(0.40), "red", "green"),
- geom = list("geom_point", "geom_line", "geom_line"),
- alpha = list(0.5, 1, 1),
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_sd.x.range2,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_sd.y.range2,
- y.log = transfo,
- y.lab = "SD",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
- # end MD plot for the theoretical matrix 1 after sub sampling and permutation
-
- # MD plot for the theoretical matrix 2 after sub sampling and permutation
- x.MEAN <-
- apply(
- X = mat2.mix,
- MARGIN = 2,
- FUN = "mean",
- na.rm = TRUE
- )
- y.SD <- apply(mat2.mix,
- MARGIN = 2,
- FUN = "sd",
- na.rm = TRUE)
- tempo.data.plot <- data.frame(MEAN = x.MEAN, SD = y.SD)
- if (transfo != "no") {
- tempo.data.plot <-
- get(transfo)(tempo.data.plot) # log(x + 1) only for heatmap
- tempo.data.pois <-
- data.frame(
- x.pois = tempo.data.plot$MEAN,
- y.sd.pois = tempo.data.plot$MEAN / 2,
- y.cv.pois = get(transfo)(1) - tempo.data.plot$MEAN / 2
- ) # because poisson distrib is mean = variance, thus sd = mean ^0.5, ie each mean as x is square rooted for y and then x.MEAN / 2 because log2(mean^0.5) = 0.5 * log2(mean). For cv, cv = sd/m -> log(cv) = log(sd/m) = log(m/m^0.5) = log(1/m^0.5) = log(1) - log(m^0.5) = log(1) - log(m)/2
- tempo.data.negbinom <-
- data.frame(
- x.green = get(transfo)(mean.nb2),
- y.green = get(transfo)(cv.nb2 * mean.nb2)
- ) # neg binomiale distrib
- } else{
- tempo.data.pois <-
- data.frame(
- x.pois = tempo.data.plot$MEAN,
- y.sd.pois = tempo.data.plot$MEAN ^ 0.5,
- y.cv.pois = 1 / tempo.data.plot$MEAN ^
- 0.5
- )
- tempo.data.negbinom <-
- data.frame(x.green = mean.nb2, y.green = cv.nb2 * mean.nb2) # neg binomiale distrib
- }
- tempo.title <-
- paste0(
- "MAT2 THEO\nAFTER PERMUTATION AND SUB SAMPLING\nMEAN DEVIATION (MD) PLOT\n",
- if (transfo == "log2") {
- "MEAN AND SD LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND SD LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_sd.x.range2, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_sd.y.range2, 2), collapse = " , "),
- "\nRED LINE: POISSON DISTRIB\n
- GREEN LINE: NEG BINOM DISTRIB"
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot, tempo.data.pois, tempo.data.negbinom),
- x = list("MEAN", "x.pois", "x.green"),
- y = list("SD", "y.sd.pois", "y.green"),
- color = list(grey(0.40), "red", "green"),
- geom = list("geom_point", "geom_line", "geom_line"),
- alpha = list(0.5, 1, 1),
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_sd.x.range2,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_sd.y.range2,
- y.log = transfo,
- y.lab = "SD",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
- # end MD plot for the theoretical matrix 2 after sub sampling and permutation
-
- # mean / cor of the theoretical matrices
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- suppressWarnings(data.frame(
- MEAN = (
- apply(X = mat1.mix, MARGIN = 2, FUN = "mean") +
- apply(X = mat2.mix, MARGIN = 2, FUN = "mean")
- ) / 2,
- COR = mapply(
- FUN = "cor",
- x = as.data.frame(mat1.mix),
- y = as.data.frame(mat2.mix),
- use = "pairwise.complete.obs",
- method = "spearman",
- SIMPLIFY = TRUE
- )
- ))
- if (transfo != "no") {
- tempo.data.plot[, "MEAN"] <-
- get(transfo)(tempo.data.plot[, "MEAN"]) # log(x + 1) only for heatmap
- }
- tempo.title <- paste0(
- "AFTER PERMUTATION AND SUB SAMPLING\n
- (MAT1 THEO / MAT2 THEO) MEAN VERSUS (MAT1 THEO / MAT2 THEO) SPEARMAN CORRELATION\n",
- if (transfo == "log2") {
- "MEAN LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(m_cor.x.range2, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(m_cor.y.range2, 2), collapse = " , ")
- )
- fun_gg_scatter(
- data1 = tempo.data.plot,
- x = "MEAN",
- y = "COR",
- color = grey(0.40),
- geom = "geom_point",
- alpha = 0.5,
- dot.size = dot.size,
- line.size = line.size,
- x.lim = m_cor.x.range2,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.lim = m_cor.y.range2,
- y.log = "no",
- y.lab = "CORRELATION",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0,
- x.right.extra.margin = 0,
- y.top.extra.margin = 0,
- y.bottom.extra.margin = 0
- ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
- # correlation versus index before and after subsampling
- tempo.cor <-
- suppressWarnings(mapply(
- FUN = "cor",
- c(data.frame(mat1.mix)),
- c(data.frame(mat2.mix)),
- use = "pairwise.complete.obs",
- method = "spearman"
- ))
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- if (length(rho2) != length(tempo.cor)) {
- #
- tempo.cat <-
- paste0(
- "\n\n================\n\nINTERNAL ERROR CODE IN SLITHERINE\n
- THE TWO CORRELATIONS rho2 AND tempo.cor DO NOT HAVE THE SAME LENGTH\n\n================\n\n"
- ) # message for developers
- stop(tempo.cat)
- }
- tempo.data.plot <-
- data.frame(
- CORRELATION = c(rho2, unlist(cor.list), tempo.cor),
- COLUMN_NB = c(1:length(rho2), 1:length(rho2), 1:length(rho2)),
- KIND = rep(
- c("OBS", "THEO_AFTER_PERMUTATION", "THEO_AFTER_DOWNSAMPLING"),
- each = length(rho2)
- )
- )
- tempo.title <-
- paste0(
- "SPEARMAN CORRELATION BETWEEN MAT1 OBS / MAT2 OBS\n
- COMPARISON WITH MAT1 THEO / MAT2 THEO 1) AFTER PERMUTATION AND 2)
- AFTER PERMUTATION AND DOWNSAMPLING\nX SCALE RANGE: ",
- paste(range(
- 1:length(rho2),
- na.rm = TRUE, finite = TRUE
- ), collapse = " , "),
- "\nY SCALE RANGE: -1, 1"
- )
- fun_gg_scatter(
- data1 = list(tempo.data.plot),
- x = list("COLUMN_NB"),
- y = list("CORRELATION"),
- categ = list("KIND"),
- geom = list("geom_point"),
- alpha = list(0.5),
- dot.size = dot.size,
- line.size = line.size,
- x.log = "no",
- x.lab = "DIAGONAL INDEX",
- x.tick.nb = 8,
- y.log = "no",
- y.lab = "CORRELATION",
- y.lim = c(-1, 1),
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster
- )
- # end correlation versus index before and after subsampling
-
-
- ################ end sub sampling
-
-
- ################ matrix visualization before comparison
-
-
-} else{
- # message d'erreur à changer
- tempo.warning <-
- paste0(
- "THE serp.binning PARAMETER SETTING HAS BEEN SET TO TRUE,
- BUT THEORETICAL MATRICES HAVE BEEN IMPORTED\n
- -> PRE SERPENTINE ANALYSIS IS SUFFICIENT (IF YOU NEED MORE SERPENTINE BINNING,
- INCREASE THE VALUE OF THE serp.iter.nb PARAMETER)\n-> serp.binning PARAMETER RESET TO FALSE"
- )
- cat(paste0("\nWARNING: ", tempo.warning, "\n"))
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
-
-}
-
-
-
-
-cat("\nMATRIX VISUALIZATION BEFORE COMPARISON\n")
-fun_report(
- data = "\n\n################################ MATRIX VISUALIZATION BEFORE COMPARISON",
- path = path.out,
- output = log.file,
- sep = 4
-)
-if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
-} else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
-}
-fun_gg_empty_graph(text = "MATRIX VISUALIZATION BEFORE COMPARISON", text.size = 3)
-if (ratio.normalization == TRUE) {
- fun_report(
- data = paste0(
- "SIGNIFICANT DIFFERENCES BY SEGMENTATION PERFORMED ON NON NORMALIZED MATRICES\n
- BUT CUTOFF, APPLIED JUST AFTER SEGMENTATION, PERFORMED ON NORMALIZED MATRICES:\n
- THEO MATRICES:\nCELLS MEAN: NO NORMALIZATION (BECAUSE SELECTION IS PERFORMED ON CELL
- RATIOS AND BECAUSE CELL MEANS REMAIN DISCRETE VALUES,
- WHICH IS IMPORTANT FOR THE SEGMENTATION STEP AS DOTS REMAINS PERFECTLY OVERLAID)\n
- CELLS RATIO: DIVISION BY THE NORMALIZATION FACTOR( CELL ADJUSTED MEAN OF MATRIX 2
- DIVIDED BY CELL ADJUSTED MEAN OF MATRIX 1)\nOBS MATRICES:\n
- CELLS MEAN: NO NORMALIZATION (AS FOR THEO MATRICES)\n
- CELLS RATIO: DIVISION BY THE MEAN OF CELL RATIOS\n
- SEE EXPLANATION ABOUT ADJUSTED MEAN IN THE CODE OF THE adj.mean.fun FUNCTION"
- ),
- output = log.file,
- path = path.out
- )
-} else{
- fun_report(
- data = paste0(
- "SIGNIFICANT DIFFERENCES BY SEGMENTATION PERFORMED ON NON NORMALIZED MATRICES\n
- AND CUTOFF, APPLIED JUST AFTER SEGMENTATION, ALSO PERFORMED ON NON NORMALIZED MATRICES:\n
- THEO MATRICES:\nCELLS MEAN: NO NORMALIZATION (BECAUSE SELECTION IS PERFORMED ON CELL
- RATIOS AND BECAUSE CELL MEANS REMAIN DISCRETE VALUES, WHICH IS IMPORTANT
- FOR THE SEGMENTATION STEP AS DOTS REMAINS PERFECTLY OVERLAID)\n
- CELLS RATIO: NO NORMALIZATION ACCORDING TO THE ratio.normalization USER PARAMETER SETTING"
- ),
- output = log.file,
- path = path.out
- )
-}
-# matrix preparation
-# theo dataframe alone
-theo.mean.mat <- (mat1.mix + mat2.mix) / 2
-theo.ratio.mat <-
- mat2.mix / mat1.mix # mat2.mix / mat1.mix to respect serpentine convention. Here nomralization before ratio
-mat1.theo.mean <- adj.mean.fun(x_3fun = mat1.mix, text_3fun = "")
-mat2.theo.mean <- adj.mean.fun(x_3fun = mat2.mix, text_3fun = "")
-if (ratio.normalization == TRUE) {
- theo.ratio.factor <- mat2.theo.mean / mat1.theo.mean
- fun_report(
- data = paste0(
- "NORMALIZATION FACTOR OF CELL RATIOS OF THEO MATRICES: ",
- fun_round(theo.ratio.factor),
- "\nUSING CELL ADJUSTED MEAN OF MATRIX 2: ",
- fun_round(mat2.theo.mean),
- "\nAND CELL ADJUSTED MEAN OF MATRIX 1: ",
- fun_round(mat1.theo.mean)
- ),
- output = log.file,
- path = path.out
- )
-} else{
- theo.ratio.factor <- 1 # division by 1 means no norm
-}
-mat1.mix.norm <- mat1.mix / mat1.theo.mean
-mat2.mix.norm <- mat2.mix / mat2.theo.mean
-theo.ratio.mat.norm <-
- theo.ratio.mat / theo.ratio.factor # not normalized if ratio.normalization == FALSE because theo.ratio.factor == 1
-if (transfo != "no") {
- fun_report(
- data = paste0(
- "SIGNIFICANT DIFFERENCES PERFORMED ON ",
- toupper(transfo),
- " TRANSFORMED DATA"
- ),
- output = log.file,
- path = path.out
- )
- mat1.mix.norm.trans <-
- get(transfo)(mat1.mix.norm + 1) # for single heatmap
- mat2.mix.norm.trans <-
- get(transfo)(mat2.mix.norm + 1) # for single heatmap
- theo.mean.mat.trans <- get(transfo)(theo.mean.mat)
- theo.ratio.mat.trans <-
- get(transfo)(theo.ratio.mat) # required for segmentation (theo.df.pre.for.segm)
- theo.ratio.mat.norm.trans <- get(transfo)(theo.ratio.mat.norm)
- theo.df.pre <-
- data.frame(
- MEAN = as.vector(theo.mean.mat.trans),
- RATIO = as.vector(theo.ratio.mat.norm.trans),
- MATRICES = "Theo",
- coord_1D = 1:(nrow(mat1.mix) * ncol(mat1.mix)),
- stringsAsFactors = FALSE
- ) # The coord_1D coordinate is the 1D position of a cell in a matrix
- theo.df.pre.for.segm <-
- data.frame(
- MEAN = as.vector(theo.mean.mat.trans),
- RATIO = as.vector(theo.ratio.mat.trans),
- MATRICES = "Theo",
- coord_1D = 1:(nrow(mat1.mix) * ncol(mat1.mix)),
- stringsAsFactors = FALSE
- ) # The coord_1D coordinate is the 1D position of a cell in a matrix
-} else{
- fun_report(
- data = paste0(
- "SIGNIFICANT DIFFERENCES PERFORMED ON ",
- toupper(transfo),
- "N TRANSFORMED DATA"
- ),
- output = log.file,
- path = path.out
- )
- theo.df.pre <-
- data.frame(
- MEAN = as.vector(theo.mean.mat),
- RATIO = as.vector(theo.ratio.mat.norm),
- MATRICES = "Theo",
- coord_1D = 1:(nrow(mat1.mix) * ncol(mat1.mix)),
- stringsAsFactors = FALSE
- ) # The coord_1D coordinate is the 1D position of a cell in a matrix
- theo.df.pre.for.segm <-
- data.frame(
- MEAN = as.vector(theo.mean.mat),
- RATIO = as.vector(theo.ratio.mat),
- MATRICES = "Theo",
- coord_1D = 1:(nrow(mat1.mix) * ncol(mat1.mix)),
- stringsAsFactors = FALSE
- ) # The coord_1D coordinate is the 1D position of a cell in a matrix
-}
-# obs dataframe alone
-obs.mean.mat <- (mat1.obs + mat2.obs) / 2
-obs.ratio.mat <-
- mat2.obs / mat1.obs # mat2.obs / mat1.obs to respect serpentine convention. Here nomralization before ratio
-mat1.obs.mean <-
- mean(mat1.obs[is.finite(as.vector(mat1.obs))], na.rm = TRUE)
-mat2.obs.mean <-
- mean(mat2.obs[is.finite(as.vector(mat2.obs))], na.rm = TRUE)
-if (ratio.normalization == TRUE) {
- obs.ratio.factor <- mat2.obs.mean / mat1.obs.mean
- fun_report(
- data = paste0(
- "NORMALIZATION FACTOR OF CELL RATIOS OF OBS MATRICES: ",
- fun_round(obs.ratio.factor),
- "\nUSING CELL ADJUSTED MEAN OF MATRIX 2: ",
- fun_round(mat2.obs.mean),
- "\nAND CELL ADJUSTED MEAN OF MATRIX 1: ",
- fun_round(mat1.obs.mean)
- ),
- output = log.file,
- path = path.out
- )
-} else{
- obs.ratio.factor <- 1
-}
-mat1.obs.norm <- mat1.obs / mat1.obs.mean
-mat2.obs.norm <- mat2.obs / mat2.obs.mean
-obs.ratio.mat.norm <-
- obs.ratio.mat / obs.ratio.factor # not normalized if ratio.normalization == FALSE because obs.ratio.factor == 1
-obs.ratio.mat.norm[obs.ratio.mat.norm == 0] <-
- NA # replacement of zero by NA because zero values means "no reads". Thus, not interesting for the significativity
-if (transfo != "no") {
- mat1.obs.norm.trans <-
- get(transfo)(mat1.obs.norm + 1) # for single heatmap
- mat2.obs.norm.trans <-
- get(transfo)(mat2.obs.norm + 1) # for single heatmap
- obs.mean.mat.trans <- get(transfo)(obs.mean.mat)
- obs.ratio.mat.trans <-
- get(transfo)(obs.ratio.mat) # required for segmentation (obs.df.pre.for.segm)
- obs.ratio.mat.norm.trans <- get(transfo)(obs.ratio.mat.norm)
- obs.df.pre <-
- data.frame(
- MEAN = as.vector(obs.mean.mat.trans),
- RATIO = as.vector(obs.ratio.mat.norm.trans),
- MATRICES = "Obs",
- coord_1D = 1:(nrow(mat1.obs) * ncol(mat1.obs)),
- stringsAsFactors = FALSE
- ) # The coord_1D coordinate is the 1D position of a cell in a matrix
- obs.df.pre.for.segm <-
- data.frame(
- MEAN = as.vector(obs.mean.mat.trans),
- RATIO = as.vector(obs.ratio.mat.trans),
- MATRICES = "Obs",
- coord_1D = 1:(nrow(mat1.obs) * ncol(mat1.obs)),
- stringsAsFactors = FALSE
- ) # The coord_1D coordinate is the 1D position of a cell in a matrix
-} else{
- obs.df.pre <-
- data.frame(
- MEAN = as.vector(obs.mean.mat),
- RATIO = as.vector(obs.ratio.mat.norm),
- MATRICES = "Obs",
- coord_1D = 1:(nrow(mat1.obs) * ncol(mat1.obs)),
- stringsAsFactors = FALSE
- ) # The coord_1D coordinate is the 1D position of a cell in a matrix
- obs.df.pre.for.segm <-
- data.frame(
- MEAN = as.vector(obs.mean.mat),
- RATIO = as.vector(obs.ratio.mat),
- MATRICES = "Obs",
- coord_1D = 1:(nrow(mat1.obs) * ncol(mat1.obs)),
- stringsAsFactors = FALSE
- ) # The coord_1D coordinate is the 1D position of a cell in a matrix
-}
-final.df.pre <- rbind(theo.df.pre, obs.df.pre)
-if (transfo != "no") {
- loop.mat.names <-
- c(
- "mat1.mix.norm.trans",
- "mat2.mix.norm.trans",
- "mat1.obs.norm.trans",
- "mat2.obs.norm.trans"
- )
- diff.loop.mat.names <-
- c("theo.ratio.mat.norm.trans", "obs.ratio.mat.norm.trans")
- s.obs.heatmap.range.norm.pre <-
- range(mat1.obs.norm.trans,
- mat2.obs.norm.trans,
- na.rm = TRUE,
- finite = TRUE)
- s.both.heatmap.range.norm.pre <-
- range(
- mat1.mix.norm.trans,
- mat2.mix.norm.trans,
- s.obs.heatmap.range.norm.pre,
- na.rm = TRUE,
- finite = TRUE
- )
- tempo.range <-
- max(abs(range(
- final.df.pre$RATIO, na.rm = TRUE, finite = TRUE
- )), na.rm = TRUE)
- diff.both.heatmap.range.norm.pre <-
- c(-tempo.range, tempo.range) # to center the scale on log() = 0, whatever normalization or not. If no normalization, red or blue can be predominant
-} else{
- loop.mat.names <-
- c("mat1.mix.norm",
- "mat2.mix.norm",
- "mat1.obs.norm",
- "mat2.obs.norm")
- diff.loop.mat.names <-
- c("theo.ratio.mat.norm", "obs.ratio.mat.norm")
- s.obs.heatmap.range.norm.pre <-
- range(mat1.obs.norm,
- mat2.obs.norm,
- na.rm = TRUE,
- finite = TRUE)
- s.both.heatmap.range.norm.pre <-
- range(
- mat1.mix.norm,
- mat2.mix.norm,
- s.obs.heatmap.range.norm.pre,
- na.rm = TRUE,
- finite = TRUE
- )
- diff.both.heatmap.range.norm.pre <-
- range(final.df.pre$RATIO, na.rm = TRUE, finite = TRUE) #
-}
-# end matrix preparation
-# heatmap
-loop.heatmap.title1 <-
- c(
- "THEO MAT1 BEFORE SERPENTINE",
- "THEO MAT2 BEFORE SERPENTINE",
- "OBS MAT1 BEFORE SERPENTINE",
- "OBS MAT2 BEFORE SERPENTINE"
- )
-loop.heatmap.title2 <-
- c(
- "NO SYMMETRIC MATRIX",
- "NO SYMMETRIC MATRIX",
- ifelse(
- serp.symmet.input == TRUE,
- "SYMMETRIC MATRIX (FORCED BY USER OPTION)",
- "NO SYMMETRIC MATRIX"
- ),
- ifelse(
- serp.symmet.input == TRUE,
- "SYMMETRIC MATRIX (FORCED BY USER OPTION)",
- "NO SYMMETRIC MATRIX"
- )
- )
-loop.heatmap.title3 <-
- c(
- "WEIGHTED DIAGONAL MEAN DIVISION",
- "WEIGHTED DIAGONAL MEAN DIVISION",
- "GLOBAL MEAN DIVISION",
- "GLOBAL MEAN DIVISION"
- )
-loop.heatmap.title <- paste0(
- loop.heatmap.title1,
- "\n",
- if (transfo == "log2") {
- "LOG2(x + 1) "
- } else if (transfo == "log10") {
- "LOG10(x + 1) "
- } else{
- "NO "
- },
- "TRANSFORMATION\nSCALE RANGE: ",
- paste(fun_round(s.both.heatmap.range.norm.pre, 2),
- collapse = " , "),
- "\nNORMALIZED DISPLAY (",
- loop.heatmap.title3,
- ")\n",
- loop.heatmap.title2
-)
-for (i0 in 1:length(loop.mat.names)) {
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- fun_gg_heatmap(
- data1 = get(loop.mat.names[i0]),
- legend.name1 = "",
- limit1 = s.both.heatmap.range.norm.pre,
- midpoint1 = mean(s.both.heatmap.range.norm.pre, na.rm = TRUE),
- title = loop.heatmap.title[i0],
- text.size = heatmap.text.size,
- title.text.size = title.text.size
- )
-}
-# end heatmap
-# differential heatmap
-if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
-} else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
-}
-loop.heatmap.title1 <-
- c(
- "DIFFERENTIAL THEO BEFORE SERPENTINE (THEO2 / THEO1)",
- "DIFFERENTIAL OBS BEFORE SERPENTINE (OBS2 / OBS1)"
- )
-loop.heatmap.title2 <- c(
- "NO SYMMETRIC MATRIX",
- ifelse(
- serp.symmet.input == TRUE,
- "SYMMETRIC MATRIX (FORCED BY USER OPTION)",
- "NO SYMMETRIC MATRIX"
- )
-)
-if (ratio.normalization == TRUE) {
- loop.heatmap.title3 <-
- c(
- "NORMALIZED DISPLAY (WEIGHTED DIAGONAL MEAN DIVISION)",
- "NORMALIZED DISPLAY (GLOBAL MEAN DIVISION)"
- )
-} else{
- loop.heatmap.title3 <-
- c("NO RATIO NORMALIZATION", "NO RATIO NORMALIZATION")
-}
-loop.heatmap.title <- paste0(
- loop.heatmap.title1,
- "\n",
- if (transfo == "log2") {
- "LOG2(x + 1) "
- } else if (transfo == "log10") {
- "LOG10(x + 1) "
- } else{
- "NO "
- },
- "TRANSFORMATION\nSCALE RANGE: ",
- paste(fun_round(diff.both.heatmap.range.norm.pre, 2),
- collapse = " , "),
- "\n",
- loop.heatmap.title3,
- "\n",
- loop.heatmap.title2
-)
-for (i0 in 1:length(diff.loop.mat.names)) {
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- fun_gg_heatmap(
- data1 = get(diff.loop.mat.names[i0]),
- legend.name = "",
- limit1 = diff.both.heatmap.range.norm.pre,
- midpoint1 = mean(diff.both.heatmap.range.norm.pre, na.rm = TRUE),
- title = loop.heatmap.title[i0],
- title.text.size = title.text.size
- )
-
-}
-# end differential heatmap
-
-print("koko made daijoubu")
-
-################ significant differences pre serpentine (SLITHERINE)
-
-
-
-cat("\nSIGNIFICANT DIFFERENCES PRE SERPENTINE (SLITHERINE)\n")
-fun_report(
- data = "\n\n################################ SIGNIFICANT DIFFERENCES PRE SERPENTINE (SLITHERINE)",
- path = path.out,
- output = log.file,
- sep = 4
-)
-if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
-} else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
-}
-fun_gg_empty_graph(text = "SIGNIFICANT DIFFERENCES PRE SERPENTINE\n(SLITHERINE)", text.size = 3)
-# BEWARE: segment.pre.serp, final.df.pre, obs.df.pre and theo.df.pre potentially integrate log transfo already + normalized for theo
-# segmentation
-fun_report(
- data = paste0(
- "SEGMENTATION OF THE THEORETICAL DOT CLOUD (MEAN CELL / RATIO CELL PLOT) PERFORMED ON
- NON NORMALIZED DATA\nBECAUSE OF DISCRETE RATIO VALUES THAT ARE PRESENTS FOR LOW MEANS\n
- INDEED, NORMALIZATION SLIGHTLY SHIFTS THE RATIO VALUES BETWEEN THEO AND OBS CLOUDS,
- WHICH INDUCES LOW MEAN CELL DOTS (I.E., NOISE) TO BE SIGNIFICANT AFTER SEGMENTATION.
- THEN, DEPENDING ON USER SETTINGS (SEE ABOVE), RATIO NORMALIZATION ARE PERFORMED ON
- SEGMENTATION RESULT DATA, BEFORE APPLYING THE CUTOFFS FILTERING"
- ),
- output = log.file,
- path = path.out
-)
-segment.pre.serp <-
- fun_segmentation(
- data1 = theo.df.pre.for.segm,
- x1 = "MEAN",
- y1 = "RATIO",
- x.range.split = range.split,
- x.step.factor = step.factor,
- error = error,
- data2 = obs.df.pre.for.segm,
- x2 = "MEAN",
- y2 = "RATIO",
- data2.pb.dot = "signif",
- plot = FALSE,
- graph.in.file = FALSE
- ) # fun_seg create the outline MD plot
-fun_report(
- data = "UNKNOWN DOTS HAVE BEEN CONSIDERED AS SIGNIFICANTS
- (ARGUMENT data2.pb.dot OF fun_segmentation() SET TO \"signif\")",
- output = log.file,
- path = path.out
-)
-
-
-
-# cat(paste0("\n", segment.pre.serp$warn, "\n"))
-warning.message <-
- paste0(warning.message,
- ifelse(is.null(warning.message), "", "\n"),
- segment.pre.serp$warn) #
-fun_report(data = segment.pre.serp$warn,
- output = log.file,
- path = path.out)
-if (!is.null(segment.pre.serp$hframe)) {
- names(segment.pre.serp$hframe)[names(segment.pre.serp$hframe) == "x"] <-
- "MEAN" #
- names(segment.pre.serp$hframe)[names(segment.pre.serp$hframe) == "y"] <-
- "RATIO" #
- names(segment.pre.serp$hframe)[names(segment.pre.serp$hframe) == "kind"] <-
- "FRAMES" #
-} else{
- tempo.cat <-
- paste0("BEWARE: NO HORIZONTAL FRAME DETECTED DURING SEGMENTATION PRE SERPENTINE")
- cat(paste0("\n", tempo.cat, "\n"))
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
-}
-
-
-# jsp
-# normalization post segmentation if required
-if (ratio.normalization == TRUE) {
- fun_report(
- data = "DATA FRAMES IN segment.pre.serp OBJECT HAVE THE RATIO COLUMN NORMALIZED ACCORDING TO
- USER PARAMETER SETTINGS",
- output = log.file,
- path = path.out
- )
- for (i in 1:length(segment.pre.serp)) {
- if (all(class(segment.pre.serp[[i]]) == "data.frame") &
- grepl(x = names(segment.pre.serp[i]), pattern = "data1|frame")) {
- # modify only theoretical data and frames (made on theoretical data)
- if (nrow(segment.pre.serp[[i]]) > 0) {
- if (transfo != "no") {
- segment.pre.serp[[i]]$RATIO <-
- segment.pre.serp[[i]]$RATIO - get(transfo)(theo.ratio.factor)
- } else{
- segment.pre.serp[[i]]$RATIO <-
- segment.pre.serp[[i]]$RATIO / theo.ratio.factor
- }
- }
- }
- if (all(class(segment.pre.serp[[i]]) == "data.frame") &
- grepl(x = names(segment.pre.serp[i]), pattern = "data2")) {
- # modify only obs data
- if (nrow(segment.pre.serp[[i]]) > 0) {
- if (transfo != "no") {
- segment.pre.serp[[i]]$RATIO <-
- segment.pre.serp[[i]]$RATIO - get(transfo)(obs.ratio.factor)
- } else{
- segment.pre.serp[[i]]$RATIO <-
- segment.pre.serp[[i]]$RATIO / obs.ratio.factor
- }
- }
- }
- }
-} else{
- fun_report(
- data = "DATA FRAMES IN segment.pre.serp OBJECT DO NOT HAVE THE RATIO COLUMN
- NORMALIZED ACCORDING TO USER PARAMETER SETTINGS",
- output = log.file,
- path = path.out
- )
-}
-# end normalization post segmentation if required
-# end segmentation
-
-
-# second y filtering:
-# because theo and obs objects are already nomalized -> very simple to adjust the ratio.limit.sig
-if (transfo != "no") {
- ratio.cutoff.sup.pre <-
- get(transfo)(ratio.limit.sig) # no need to adjust because theo and obs objects are already normalized
- ratio.cutoff.inf.pre <- -get(transfo)(ratio.limit.sig) #
-} else{
- ratio.cutoff.sup.pre <- ratio.limit.sig #
- ratio.cutoff.inf.pre <- -ratio.limit.sig #
-}
-fun_report(
- data = paste0(
- "CUT-OFFS SET TO ",
- ratio.limit.sig,
- " BY THE USER CORRESPOND TO ",
- fun_round(ratio.cutoff.inf.pre),
- " AND ",
- fun_round(ratio.cutoff.sup.pre),
- " ON THE SEGMENTATION GRAPHS"
- ),
- output = log.file,
- path = path.out
-)
-# end weighting the cell ratio before computing the global mean ratio, after moving NA, Inf columns and also NA, Inf cells in columns with values
-signif.theo.dot.pre <-
- segment.pre.serp$data1.signif.dot # significant data frame of data1 pre serpentine
-if (!is.null(signif.theo.dot.pre)) {
- if (all(
- signif.theo.dot.pre$RATIO > ratio.cutoff.inf.pre &
- signif.theo.dot.pre$RATIO < ratio.cutoff.sup.pre
- )) {
- tempo.cat <-
- paste0(
- "BEWARE: SIGNIFICANT THEO DOTS DETECTED DURING SEGMENTATION PRE SERPENTINE\n
- BUT NOT ANYMORE AFTER USING THE ratio.limit.sig PARAMETER (",
- ratio.limit.sig,
- ")\n
- SIGNIFICANT USER LIMITS: ",
- paste(fun_round(
- c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre)
- ), collapse = " ")
- )
- cat(paste0("\n", tempo.cat, "\n"))
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(
- data = "THE SIGNIFICANT DOTS ARE:",
- output = log.file,
- path = path.out,
- sep = 1
- )
- fun_report(data = signif.theo.dot.pre,
- output = log.file,
- path = path.out)
- signif.theo.dot.pre <- NULL
- } else{
- signif.theo.dot.pre <- unique(signif.theo.dot.pre[!(
- signif.theo.dot.pre$RATIO > ratio.cutoff.inf.pre &
- signif.theo.dot.pre$RATIO < ratio.cutoff.sup.pre
- ),]) # only dot nb are finally kept
- }
-} else{
- tempo.cat <-
- paste0("NO SIGNIFICANT THEO DOTS DETECTED DURING SEGMENTATION PRE SERPENTINE")
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
-}
-signif.obs.dot.pre <-
- segment.pre.serp$data2.signif.dot # significant table of data2 pre serpentine
-sup.signif.obs.dot.pre <- NULL
-inf.signif.obs.dot.pre <- NULL
-if (!is.null(signif.obs.dot.pre)) {
- if (all(
- signif.obs.dot.pre$RATIO > ratio.cutoff.inf.pre &
- signif.obs.dot.pre$RATIO < ratio.cutoff.sup.pre
- )) {
- tempo.cat <-
- paste0(
- "BEWARE: SIGNIFICANT OBS DOTS DETECTED DURING SEGMENTATION PRE SERPENTINE\n
- BUT NOT ANYMORE AFTER USING THE ratio.limit.sig PARAMETER (",
- ratio.limit.sig,
- ")\n
- SIGNIFICANT USER LIMITS: ",
- paste(fun_round(
- c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre)
- ),
- collapse = " ")
- )
- cat(paste0("\n", tempo.cat, "\n"))
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- fun_report(
- data = "THE SIGNIFICANT DOTS ARE:",
- output = log.file,
- path = path.out,
- sep = 1
- )
- fun_report(data = signif.obs.dot.pre,
- output = log.file,
- path = path.out)
- signif.obs.dot.pre <- NULL
- } else{
- signif.obs.dot.pre <- unique(signif.obs.dot.pre[!(
- signif.obs.dot.pre$RATIO > ratio.cutoff.inf.pre &
- signif.obs.dot.pre$RATIO < ratio.cutoff.sup.pre
- ),]) #
- sup.signif.obs.dot.pre <-
- signif.obs.dot.pre[signif.obs.dot.pre$RATIO > 0,] # positive log ratio, i.e., mat2 > mat1
- inf.signif.obs.dot.pre <-
- signif.obs.dot.pre[signif.obs.dot.pre$RATIO < 0,] # negative log ratio, i.e., mat2 < mat1
- }
-} else{
- tempo.cat <-
- paste0("NO SIGNIFICANT OBS DOTS DETECTED DURING SEGMENTATION PRE SERPENTINE")
- cat(paste0("\n", tempo.cat, "\n"))
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
-}
-# end second y filtering
-
-fun_report(
- data = paste0(
- "PRE SERPENTINE SEGMENTATION DATA (RATIO NORMALIZED AND MEAN & RATIO POTENTIALLY LOG TRANSFORMED)
- SAVED IN: ",
- "segmentation_pre_serp.RData"
- ),
- output = log.file,
- path = path.out
-)
-save(
- list = c(
- "segment.pre.serp",
- "signif.theo.dot.pre",
- "signif.obs.dot.pre",
- "sup.signif.obs.dot.pre",
- "inf.signif.obs.dot.pre",
- "theo.df.pre",
- "obs.df.pre"
- ),
- file = "segmentation_pre_serp.RData"
-)
-# segment.pre.serp result of segmentation (no second y filtering)
-# signif.theo.dot.pre significant theo dot after second y filtering
-# signif.obs.dot.pre significant obs dot after second y filtering
-# sup.signif.obs.dot.pre dots from signif.obs.dot.pre with positive log2ratio
-# inf.signif.obs.dot.pre dots from signif.obs.dot.pre with negative log2ratio
-# theo.df.pre mean and ratio cells of the 2 theo matrices, with ratio normalization and potentialy with transformation, used for the segmentation
-# obs.df.pre mean and ratio cells of the 2 theo matrices, with ratio normalization and potentialy with transformation, used for the segmentation
-
-# plot verif obs dots outside
-# MD overlay plot before serpentine
-segm.x.range.pre <-
- range(final.df.pre$MEAN, na.rm = TRUE, finite = TRUE)
-segm.y.range.pre <-
- range(
- c(
- final.df.pre$RATIO,
- ratio.cutoff.inf.pre,
- ratio.cutoff.sup.pre
- ),
- na.rm = TRUE,
- finite = TRUE
- )
-if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
-} else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
-}
-if (!is.null(signif.theo.dot.pre)) {
- # signif dots in theo matrices
- tempo.title <-
- paste0(
- "SEGMENTATION OF THE MEAN / RATIO MATRIX CELLS\n
- THEO MAT ALONE + THEO SIGNIFICANT DOTS\n",
- ifelse(
- ratio.normalization == TRUE,
- "THEO AND OBS RATIOS HAVE BEEN NORMALIZED (EACH CENTERED ON RATIO 1)\n",
- ""
- ),
- if (transfo == "log2") {
- "MEAN AND RATIO LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND RATIO LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(segm.x.range.pre, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(segm.y.range.pre, 2), collapse = " , "),
- "\nCUT-OFFS DEFINED BY THE USER: ",
- fun_round(ratio.cutoff.inf.pre),
- " AND
- ",
- fun_round(ratio.cutoff.sup.pre)
- )
- fun_gg_scatter(
- data1 = list(
- L1 = theo.df.pre,
- L2 = signif.theo.dot.pre,
- L3 = segment.pre.serp$hframe,
- L4 = data.frame(
- y = c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre),
- CUTOFFS = c("INF_LIMIT", "SUP_LIMIT")
- )
- ),
- x = list(
- L1 = "MEAN",
- L2 = "MEAN",
- L3 = "MEAN",
- L4 = NULL
- ),
- y = list(
- L1 = "RATIO",
- L2 = "RATIO",
- L3 = "RATIO",
- L4 = "y"
- ),
- categ = list(
- L1 = "MATRICES",
- L2 = "MATRICES",
- L3 = "FRAMES",
- L4 = "CUTOFFS"
- ),
- legend.name = list(
- L1 = "MATRICES",
- L2 = "SIGNIF DOTS",
- L3 = "FRAMES",
- L4 = paste0(fun_round(ratio.limit.sig), " X CUTOFFS")
- ),
- color = list(
- L1 = fun_gg_palette(2)[2],
- L2 = "black",
- L3 = "blue",
- L4 = "orange"
- ),
- geom = list(
- L1 = "geom_point",
- L2 = "geom_point",
- L3 = "geom_path",
- L4 = "geom_hline"
- ),
- alpha = list(
- L1 = 0.25,
- L2 = 1,
- L3 = 0.5,
- L4 = 0.5
- ),
- dot.size = dot.size,
- line.size = line.size,
- text.size = text.size,
- title.text.size = title.text.size,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.log = transfo,
- x.lim = segm.x.range.pre,
- y.lim = segm.y.range.pre,
- y.lab = "RATIO",
- y.tick.nb = 8,
- title = tempo.title,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0.05,
- x.right.extra.margin = 0.05,
- y.top.extra.margin = 0.05,
- y.bottom.extra.margin = 0.05
- )
-} else{
- tempo.title <-
- paste0(
- "SEGMENTATION OF THE MEAN / RATIO MATRIX CELLS\nTHEO MAT ALONE (NO THEO SIGNIFICANT DOTS)\n",
- ifelse(
- ratio.normalization == TRUE,
- "THEO AND OBS RATIOS HAVE BEEN NORMALIZED (EACH CENTERED ON RATIO 1)\n",
- ""
- ),
- if (transfo == "log2") {
- "MEAN AND RATIO LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND RATIO LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(segm.x.range.pre, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(segm.y.range.pre, 2), collapse = " , "),
- "\nCUT-OFFS DEFINED BY THE USER: ",
- fun_round(ratio.cutoff.inf.pre),
- " AND ",
- fun_round(ratio.cutoff.sup.pre)
- )
- fun_gg_scatter(
- data1 = list(
- L1 = theo.df.pre,
- L3 = segment.pre.serp$hframe,
- L4 = data.frame(
- y = c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre),
- CUTOFFS = c("INF_LIMIT", "SUP_LIMIT")
- )
- ),
- x = list(L1 = "MEAN", L3 = "MEAN", L4 = NULL),
- y = list(L1 = "RATIO", L3 = "RATIO", L4 = "y"),
- categ = list(L1 = "MATRICES", L3 = "FRAMES", L4 = "CUTOFFS"),
- legend.name = list(
- L1 = "MATRICES",
- L3 = "FRAMES",
- L4 = paste0(fun_round(ratio.limit.sig), " X CUTOFFS")
- ),
- color = list(L1 = fun_gg_palette(2)[2], L3 = "blue", L4 = "orange"),
- geom = list(L1 = "geom_point", L3 = "geom_path", L4 = "geom_hline"),
- alpha = list(L1 = 0.25, L3 = 0.5, L4 = 0.5),
- dot.size = dot.size,
- line.size = line.size,
- text.size = text.size,
- title.text.size = title.text.size,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.log = transfo,
- x.lim = segm.x.range.pre,
- y.lim = segm.y.range.pre,
- y.lab = "RATIO",
- y.tick.nb = 8,
- title = tempo.title,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0.05,
- x.right.extra.margin = 0.05,
- y.top.extra.margin = 0.05,
- y.bottom.extra.margin = 0.05
- )
-}
-
-if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
-} else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
-}
-if (!is.null(signif.obs.dot.pre)) {
- # signif dots in obs matrices
- tempo.title <-
- paste0(
- "SEGMENTATION OF THE MEAN / RATIO MATRIX CELLS\nOBS MAT ALONE + OBS SIGNIFICANT DOTS\n",
- ifelse(
- ratio.normalization == TRUE,
- "THEO AND OBS RATIOS HAVE BEEN NORMALIZED (EACH CENTERED ON RATIO 1)\n",
- ""
- ),
- if (transfo == "log2") {
- "MEAN AND RATIO LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND RATIO LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(segm.x.range.pre, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(segm.y.range.pre, 2), collapse = " , "),
- "\nCUT-OFFS DEFINED BY THE USER: ",
- fun_round(ratio.cutoff.inf.pre),
- " AND ",
- fun_round(ratio.cutoff.sup.pre)
- )
- fun_gg_scatter(
- data1 = list(
- L1 = obs.df.pre,
- L2 = signif.obs.dot.pre,
- L3 = segment.pre.serp$hframe,
- L4 = data.frame(
- y = c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre),
- CUTOFFS = c("INF_LIMIT", "SUP_LIMIT")
- )
- ),
- x = list(
- L1 = "MEAN",
- L2 = "MEAN",
- L3 = "MEAN",
- L4 = NULL
- ),
- y = list(
- L1 = "RATIO",
- L2 = "RATIO",
- L3 = "RATIO",
- L4 = "y"
- ),
- categ = list(
- L1 = "MATRICES",
- L2 = "MATRICES",
- L3 = "FRAMES",
- L4 = "CUTOFFS"
- ),
- legend.name = list(
- L1 = "MATRICES",
- L2 = "SIGNIF DOTS",
- L3 = "FRAMES",
- L4 = paste0(fun_round(ratio.limit.sig),
- " X CUTOFFS")
- ),
- color = list(
- L1 = fun_gg_palette(2)[1],
- L2 = "black",
- L3 = "blue",
- L4 = "orange"
- ),
- geom = list(
- L1 = "geom_point",
- L2 = "geom_point",
- L3 = "geom_path",
- L4 = "geom_hline"
- ),
- alpha = list(
- L1 = 0.25,
- L2 = 1,
- L3 = 0.5,
- L4 = 0.5
- ),
- dot.size = dot.size,
- line.size = line.size,
- text.size = text.size,
- title.text.size = title.text.size,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.log = transfo,
- x.lim = segm.x.range.pre,
- y.lim = segm.y.range.pre,
- y.lab = "RATIO",
- y.tick.nb = 8,
- title = tempo.title,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0.05,
- x.right.extra.margin = 0.05,
- y.top.extra.margin = 0.05,
- y.bottom.extra.margin = 0.05
- )
-} else{
- tempo.title <-
- paste0(
- "SEGMENTATION OF THE MEAN / RATIO MATRIX CELLS\nOBS MAT ALONE (NO OBS SIGNIFICANT DOTS)\n",
- ifelse(
- ratio.normalization == TRUE,
- "THEO AND OBS RATIOS HAVE BEEN NORMALIZED (EACH CENTERED ON RATIO 1)\n",
- ""
- ),
- if (transfo == "log2") {
- "MEAN AND RATIO LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND RATIO LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(segm.x.range.pre, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(segm.y.range.pre, 2), collapse = " , "),
- "\nCUT-OFFS DEFINED BY THE USER: ",
- fun_round(ratio.cutoff.inf.pre),
- " AND ",
- fun_round(ratio.cutoff.sup.pre)
- )
- fun_gg_scatter(
- data1 = list(
- L1 = obs.df.pre,
- L3 = segment.pre.serp$hframe,
- L4 = data.frame(
- y = c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre),
- CUTOFFS = c("INF_LIMIT", "SUP_LIMIT")
- )
- ),
- x = list(L1 = "MEAN", L3 = "MEAN", L4 = NULL),
- y = list(L1 = "RATIO", L3 = "RATIO", L4 = "y"),
- categ = list(L1 = "MATRICES", L3 = "FRAMES", L4 = "CUTOFFS"),
- legend.name = list(
- L1 = "MATRICES",
- L3 = "FRAMES",
- L4 = paste0(fun_round(ratio.limit.sig), " X CUTOFFS")
- ),
- color = list(L1 = fun_gg_palette(2)[1], L3 = "blue", L4 = "orange"),
- geom = list(L1 = "geom_point", L3 = "geom_path", L4 = "geom_hline"),
- alpha = list(L1 = 0.25, L3 = 0.5, L4 = 0.5),
- dot.size = dot.size,
- line.size = line.size,
- text.size = text.size,
- title.text.size = title.text.size,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.log = transfo,
- x.lim = segm.x.range.pre,
- y.lim = segm.y.range.pre,
- y.lab = "RATIO",
- y.tick.nb = 8,
- title = tempo.title,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0.05,
- x.right.extra.margin = 0.05,
- y.top.extra.margin = 0.05,
- y.bottom.extra.margin = 0.05
- )
-}
-if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
-} else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
-}
-if (!is.null(signif.obs.dot.pre)) {
- # signif dots in obs matrices
- tempo.title <-
- paste0(
- "SEGMENTATION OF THE MEAN / RATIO MATRIX CELLS\nOBS AND THEO MAT + OBS SIGNIFICANT DOTS\n",
- ifelse(
- ratio.normalization == TRUE,
- "THEO AND OBS RATIOS HAVE BEEN NORMALIZED (EACH CENTERED ON RATIO 1)\n",
- ""
- ),
- if (transfo == "log2") {
- "MEAN AND RATIO LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND RATIO LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(segm.x.range.pre, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(segm.y.range.pre, 2), collapse = " , "),
- "\nCUT-OFFS DEFINED BY THE USER: ",
- fun_round(ratio.cutoff.inf.pre),
- " AND ",
- fun_round(ratio.cutoff.sup.pre)
- )
- fun_gg_scatter(
- data1 = list(
- L1 = final.df.pre,
- L2 = signif.obs.dot.pre,
- L3 = segment.pre.serp$hframe,
- L4 = data.frame(
- y = c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre),
- CUTOFFS = c("INF_LIMIT", "SUP_LIMIT")
- )
- ),
- x = list(
- L1 = "MEAN",
- L2 = "MEAN",
- L3 = "MEAN",
- L4 = NULL
- ),
- y = list(
- L1 = "RATIO",
- L2 = "RATIO",
- L3 = "RATIO",
- L4 = "y"
- ),
- categ = list(
- L1 = "MATRICES",
- L2 = "MATRICES",
- L3 = "FRAMES",
- L4 = "CUTOFFS"
- ),
- legend.name = list(
- L1 = "MATRICES",
- L2 = "SIGNIF DOTS",
- L3 = "FRAMES",
- L4 = paste0(fun_round(ratio.limit.sig), " X CUTOFFS")
- ),
- color = list(
- L1 = fun_gg_palette(2),
- L2 = "black",
- L3 = "blue",
- L4 = "orange"
- ),
- geom = list(
- L1 = "geom_point",
- L2 = "geom_point",
- L3 = "geom_path",
- L4 = "geom_hline"
- ),
- alpha = list(
- L1 = 0.25,
- L2 = 1,
- L3 = 0.5,
- L4 = 0.5
- ),
- dot.size = dot.size,
- line.size = line.size,
- text.size = text.size,
- title.text.size = title.text.size,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.log = transfo,
- x.lim = segm.x.range.pre,
- y.lim = segm.y.range.pre,
- y.lab = "RATIO",
- y.tick.nb = 8,
- title = tempo.title,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0.05,
- x.right.extra.margin = 0.05,
- y.top.extra.margin = 0.05,
- y.bottom.extra.margin = 0.05
- )
-} else{
- tempo.title <-
- paste0(
- "SEGMENTATION OF THE MEAN / RATIO MATRIX CELLS\nOBS AND THEO MAT (NO OBS SIGNIFICANT DOTS)\n",
- ifelse(
- ratio.normalization == TRUE,
- "THEO AND OBS RATIOS HAVE BEEN NORMALIZED (EACH CENTERED ON RATIO 1)\n",
- ""
- ),
- if (transfo == "log2") {
- "MEAN AND RATIO LOG2(x) "
- } else if (transfo == "log10") {
- "MEAN AND RATIO LOG10(x) "
- } else{
- "NO LOG TRANSFORMATION"
- },
- "\nX SCALE RANGE: ",
- paste(fun_round(segm.x.range.pre, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(segm.y.range.pre, 2), collapse = " , "),
- "\nCUT-OFFS DEFINED BY THE USER: ",
- fun_round(ratio.cutoff.inf.pre),
- " AND ",
- fun_round(ratio.cutoff.sup.pre)
- )
- fun_gg_scatter(
- data1 = list(
- L1 = final.df.pre,
- L3 = segment.pre.serp$hframe,
- L4 = data.frame(
- y = c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre),
- CUTOFFS = c("INF_LIMIT", "SUP_LIMIT")
- )
- ),
- x = list(L1 = "MEAN", L3 = "MEAN", L4 = NULL),
- y = list(L1 = "RATIO", L3 = "RATIO", L4 = "y"),
- categ = list(L1 = "MATRICES", L3 = "FRAMES", L4 = "CUTOFFS"),
- legend.name = list(
- L1 = "MATRICES",
- L3 = "FRAMES",
- L4 = paste0(fun_round(ratio.limit.sig), " X CUTOFFS")
- ),
- color = list(L1 = fun_gg_palette(2),
- L3 = "blue", L4 = "orange"),
- geom = list(L1 = "geom_point", L3 = "geom_path", L4 = "geom_hline"),
- alpha = list(L1 = 0.25, L3 = 0.5, L4 = 0.5),
- dot.size = dot.size,
- line.size = line.size,
- text.size = text.size,
- title.text.size = title.text.size,
- x.log = transfo,
- x.lab = "MEAN",
- x.tick.nb = 8,
- y.log = transfo,
- x.lim = segm.x.range.pre,
- y.lim = segm.y.range.pre,
- y.lab = "RATIO",
- y.tick.nb = 8,
- title = tempo.title,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0.05,
- x.right.extra.margin = 0.05,
- y.top.extra.margin = 0.05,
- y.bottom.extra.margin = 0.05
- )
-}
-# end plot verif obs dots outside
-# end MD overlay plot before serpentine
-
-
-# Mask of the obs data outside the cloud of the theo data on the MDMR plot (Mean Difference Mean Ratio)
-if (is.null(signif.obs.dot.pre)) {
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- fun_gg_empty_graph(
- title = "PRE SERPENTINE MASK",
- text = "NO MASK TO APPLY OVER HEATMAPS\nBECAUSE\n
- NO SIGNIFICANT DOT DETECTED",
- text.size = 3,
- title.size = title.text.size
- )
- fun_report(
- data = "NO MASK TO APPLY OVER HEATMAPS\nBECAUSE\n
- NO SIGNIFICANT DOT DETECTED",
- output = log.file,
- path = path.out
- )
-} else{
- # file saving
- sup.obs.mask.pre <-
- matrix(0, nrow = nrow(mat1.obs), ncol = nrow(mat1.obs)) # matrix same dim as obs full of zero
- inf.obs.mask.pre <-
- matrix(0, nrow = nrow(mat1.obs), ncol = nrow(mat1.obs)) # matrix same dim as obs full of zero
- if (nrow(sup.signif.obs.dot.pre) > 0) {
- sup.obs.mask.pre[sup.signif.obs.dot.pre$coord_1D] <-
- 1 # create the mask. If signif.obs.dot.pre is NULL, no 1 added
- fun_report(
- data = paste0(
- "PRE SERPENTINE MAT2 > MAT1 MASK DATA SAVED IN: ",
- "sup_mask_pre_serp.txt"
- ),
- output = log.file,
- path = path.out
- )
- write.table(
- sup.obs.mask.pre,
- file = "sup_mask_pre_serp.txt",
- row.names = FALSE,
- col.names = FALSE,
- append = FALSE,
- quote = FALSE,
- sep = "\t"
- )
- }
- if (nrow(inf.signif.obs.dot.pre) > 0) {
- inf.obs.mask.pre[inf.signif.obs.dot.pre$coord_1D] <-
- 1 # create the mask. If signif.obs.dot.pre is NULL, no 1 added
- fun_report(
- data = paste0(
- "PRE SERPENTINE MAT2 < MAT1 MASK DATA SAVED IN: ",
- "inf_mask_pre_serp.txt"
- ),
- output = log.file,
- path = path.out
- )
- write.table(
- inf.obs.mask.pre,
- file = "inf_mask_pre_serp.txt",
- row.names = FALSE,
- col.names = FALSE,
- append = FALSE,
- quote = FALSE,
- sep = "\t"
- )
- }
- obs.mask.pre <-
- sup.obs.mask.pre + inf.obs.mask.pre # full mask matrix
- fun_report(
- data = paste0("PRE SERPENTINE FULL MASK DATA SAVED IN: ", "mask_pre_serp.txt"),
- output = log.file,
- path = path.out
- )
- write.table(
- inf.obs.mask.pre,
- file = "mask_pre_serp.txt",
- row.names = FALSE,
- col.names = FALSE,
- append = FALSE,
- quote = FALSE,
- sep = "\t"
- )
- # end file saving
-
- # heatmaps
- if (transfo != "no") {
- tempo.mat1.obs.norm <- "mat1.obs.norm.trans"
- tempo.mat2.obs.norm <- "mat2.obs.norm.trans"
- tempo.obs.ratio.mat.norm <- "obs.ratio.mat.norm.trans"
- } else{
- tempo.mat1.obs.norm <- "mat1.obs.norm"
- tempo.mat2.obs.norm <- "mat2.obs.norm"
- tempo.obs.ratio.mat.norm <- "obs.ratio.mat.norm"
- }
- if (nrow(sup.signif.obs.dot.pre) > 0) {
- mask.plot.fun(
- mask_4fun = sup.obs.mask.pre,
- mat1_4fun = get(tempo.mat1.obs.norm),
- mat2_4fun = get(tempo.mat2.obs.norm),
- diff.mat_4fun = get(tempo.obs.ratio.mat.norm),
- serp_kind_4fun = "BEFORE",
- mask_kind_4fun = "POSITIVE (MAT2 > MAT1)",
- text_4fun = "",
- heatmap.range_4fun = s.obs.heatmap.range.norm.pre,
- diff.heatmap.range_4fun = diff.both.heatmap.range.norm.pre,
- activate.pdf_4fun = activate.pdf,
- pdf.nb_4fun = pdf.nb,
- width.wind_4fun = width.wind,
- height.wind_4fun = height.wind,
- dot.size_4fun = dot.size,
- text.size_4fun = text.size,
- title.text.size_4fun = title.text.size,
- raster_4fun = raster,
- transfo_4fun = transfo,
- ratio.limit.sig_4fun = ratio.limit.sig,
- line.size_4fun = line.size,
- heatmap.text.size_4fun = heatmap.text.size
- )
- } else{
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- fun_gg_empty_graph(
- title = "PRE SERPENTINE MASK",
- text = "NO MASK TO APPLY OVER HEATMAPS\nBECAUSE\n
- NO MAT2 > MAT1 SIGNIFICANT DOTS DETECTED",
- text.size = 3,
- title.size = title.text.size
- )
- fun_report(data = "NO MASK TO APPLY OVER HEATMAPS\nBECAUSE\nNO MAT2 > MAT1 SIGNIFICANT DOTS DETECTED",
- output = log.file,
- path = path.out)
- }
-
- if (nrow(inf.signif.obs.dot.pre) > 0) {
- mask.plot.fun(
- mask_4fun = inf.obs.mask.pre,
- mat1_4fun = get(tempo.mat1.obs.norm),
- mat2_4fun = get(tempo.mat2.obs.norm),
- diff.mat_4fun = get(tempo.obs.ratio.mat.norm),
- serp_kind_4fun = "BEFORE",
- mask_kind_4fun = "NEGATIVE (MAT2 < MAT1)",
- text_4fun = "",
- heatmap.range_4fun = s.obs.heatmap.range.norm.pre,
- diff.heatmap.range_4fun = diff.both.heatmap.range.norm.pre,
- activate.pdf_4fun = activate.pdf,
- pdf.nb_4fun = pdf.nb,
- width.wind_4fun = width.wind,
- height.wind_4fun = height.wind,
- dot.size_4fun = dot.size,
- text.size_4fun = text.size,
- title.text.size_4fun = title.text.size,
- raster_4fun = raster,
- transfo_4fun = transfo,
- ratio.limit.sig_4fun = ratio.limit.sig,
- line.size_4fun = line.size,
- heatmap.text.size_4fun = heatmap.text.size
- )
- } else{
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- fun_gg_empty_graph(
- title = "PRE SERPENTINE MASK",
- text = "NO MASK TO APPLY OVER HEATMAPS\nBECAUSE\n
- NO MAT2 < MAT1 SIGNIFICANT DOTS DETECTED",
- text.size = 3,
- title.size = title.text.size
- )
- fun_report(data = "NO MASK TO APPLY OVER HEATMAPS\nBECAUSE\nNO MAT2 < MAT1 SIGNIFICANT DOTS DETECTED",
- output = log.file,
- path = path.out)
- }
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
-
- mask.plot.fun(
- mask_4fun = obs.mask.pre,
- mat1_4fun = get(tempo.mat1.obs.norm),
- mat2_4fun = get(tempo.mat2.obs.norm),
- diff.mat_4fun = get(tempo.obs.ratio.mat.norm),
- serp_kind_4fun = "BEFORE",
- mask_kind_4fun = "FULL",
- text_4fun = "",
- heatmap.range_4fun = s.obs.heatmap.range.norm.pre,
- diff.heatmap.range_4fun = diff.both.heatmap.range.norm.pre,
- activate.pdf_4fun = activate.pdf,
- pdf.nb_4fun = pdf.nb,
- width.wind_4fun = width.wind,
- height.wind_4fun = height.wind,
- dot.size_4fun = dot.size,
- text.size_4fun = text.size,
- title.text.size_4fun = title.text.size,
- raster_4fun = raster,
- transfo_4fun = transfo,
- ratio.limit.sig_4fun = ratio.limit.sig,
- line.size_4fun = line.size,
- heatmap.text.size_4fun = heatmap.text.size
- )
- # end heatmaps
-}
-if (keep == FALSE) {
- tempo.list <-
- c("obs.mask.pre", "sup.obs.mask.pre", "inf.obs.mask.pre")
- tempo.cat <-
- paste0(
- "PRE SERPENTINE SLITHERINE MASK MATRICES SAVED IN: ",
- "",
- paste0(tempo.list, collapse = "_"),
- "_backup.RData"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- save(
- list = tempo.list,
- file = "",
- paste0(tempo.list, collapse = "_"),
- "_backup.RData"
- )
- rm(list = tempo.list) # not saved because initial matrices
-}
-
-print("end signif diff pre-serp")
-################ end significant differences pre serpentine (SLITHERINE)
-
-
-################ significant differences pre serpentine (HIC COMPARE)
-
-
-# see https://bioconductor.org/packages/release/bioc/manuals/HiCcompare/man/HiCcompare.pdf
-# In https://bioconductor.org/packages/devel/bioc/vignettes/HiCcompare/inst/doc/HiCcompare-vignette.html, it is written: "For use in HiCcompare you want the raw data so you should selected NONE. The second argument is the .hic file name. Next is the chromosome numbers of the matrix you want. For an intrachromosomal contact map both should be the same as in the above example. If you want a matrix of interchromosomal interactions you can use different chromosomes i.e. interactions between chromosome 1 and chromosome 2 (Note that HiCcompare is only meant to be used on intrachromosomal interactions at this point in development)."
-# Thus, HiC compare needs raw read number, not normalized !
-
-if (hiccomp == TRUE) {
- cat("\nSIGNIFICANT DIFFERENCES PRE SERPENTINE (HIC COMPARE)\n")
- fun_report(
- data = "\n\n################################ SIGNIFICANT DIFFERENCES PRE SERPENTINE (HIC COMPARE)",
- path = path.out,
- output = log.file,
- sep = 4
- )
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- fun_gg_empty_graph(text = "SIGNIFICANT DIFFERENCES PRE SERPENTINE\n(HIC COMPARE)", text.size = 3)
- # p values computations
- sparse.name.pre <-
- cumsum(c(0, rep(binning, ncol(mat1.obs) - 1)))
- mat1.obs.sparse.pre <- mat1.obs
- mat2.obs.sparse.pre <- mat2.obs
- fun_report(
- data = paste0(
- "NON NORMALIZED OBS CELL RATIO MATRICES USED FOR HIC COMPARE,
- AS DEFINED BY THE HIC COMPARE MANUAL (THUS, ratio.normalization PARAMETER SETTING NOT RESPECTED FOR HIC COMPARE"
- ),
- output = log.file,
- path = path.out
- ) # ratio of mat2.obs.norm / mat1.obs.norm is equivalent to obs.ratio.mat / obs.ratio.factor
- print("koko ?")
-
- # names of the matrices to use for heatmaps
- if (transfo != "no") {
- mat1.obs.for.plot <- "mat1.obs.norm.trans"
- mat2.obs.for.plot <- "mat2.obs.norm.trans"
- obs.ratio.mat.for.plot <-
- "obs.ratio.mat.norm.trans" # non normalized if ratio.normalization = FALSE
-
- } else{
- mat1.obs.for.plot <- "mat1.obs.norm"
- mat2.obs.for.plot <- "mat2.obs.norm"
- obs.ratio.mat.for.plot <-
- "obs.ratio.mat.norm" # non normalized if ratio.normalization = FALSE
- }
- print("kono ato dayone")
- # end names of the matrices to use for heatmaps
- colnames(mat1.obs.sparse.pre) <- sparse.name.pre
-
- mat1.obs.sparse.pre <-
- HiCcompare::full2sparse(mat1.obs.sparse.pre)
-
- colnames(mat2.obs.sparse.pre) <- sparse.name.pre
-
- mat2.obs.sparse.pre <-
- HiCcompare::full2sparse(mat2.obs.sparse.pre)
-
- hic.table.pre <-
- HiCcompare::create.hic.table(mat1.obs.sparse.pre, mat2.obs.sparse.pre, chr = "chr5") # chr must be filled, thus I put anything
- print("doko ?")
- tempo.warning <-
- fun_get_message(data = "HiCcompare::hic_loess(hic.table.pre)",
- kind = "warning",
- text = "IN HiCcompare::hic_loess FUNCTION OF SLITHERINE")
-
- warning.message <-
- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
-
- norm.hic.table.pre <-
- suppressMessages(suppressWarnings(HiCcompare::hic_loess(hic.table.pre))) # see the help of the hic_loess() function for the description of the returned table
-
- diff.res.pre <-
- suppressMessages(HiCcompare::hic_compare(norm.hic.table.pre))
- diff.res.pre <- as.data.frame(diff.res.pre)
- diff.res.pre <-
- data.frame(diff.res.pre, PVAL_MASK = 0L, PADJ_MASK = 0L) # add two columns to make the mask matrices
- print("naze ?")
- tempo.log.pvalue <- diff.res.pre$p.value <= 0.05
- tempo.log.padj <- diff.res.pre$p.adj <= 0.05
-
- if (sum(tempo.log.pvalue, na.rm = TRUE) > 0) {
- diff.res.pre$PVAL_MASK[tempo.log.pvalue] <- 1
- }
- print("wakaran")
- if (sum(tempo.log.padj, na.rm = TRUE) > 0) {
- diff.res.pre$PADJ_MASK[tempo.log.padj] <- 1
- }
-
- print("ta")
- # end p values computations
- # loess transformation plot
- # below section is equivalent to suppressMessages(HiCcompare::MD.plot1(M = diff.res.pre$M, D = diff.res.pre$D, mc = diff.res.pre$mc, smooth = FALSE))
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- tempo.data.plot <-
- data.frame(
- DISTANCE = diff.res.pre$D,
- RATIO = diff.res.pre$M,
- ADJ_RATIO = diff.res.pre$adj.M,
- LOESS = diff.res.pre$mc
- ) # BEWARE RATIO laready log2
- x.range.dist <-
- range(tempo.data.plot$DISTANCE,
- na.rm = TRUE,
- finite = TRUE)
- y.range.ratio <-
- range(tempo.data.plot$RATIO, na.rm = TRUE, finite = TRUE)
- tempo.title <-
- paste0(
- "OBS MATRICES\nMD PLOT FROM THE HICCOMPARE TABLE AND LOESS CURVE (ORANGE LINE)\n
- RATIO, CELL RATIO BETWEEN THE TWO OBS MATRICES; DISTANCE,
- CELL DISTANCE FROM THE MAIN DIAG (IN NB OF CELLS)\nRATIO IS LOG2(x) TRANSFORMED\n
- X SCALE RANGE: ",
- paste(fun_round(x.range.dist, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(y.range.ratio, 2), collapse = " , ")
- )
- print("su")
- fun_gg_scatter(
- data1 = list(L1 = tempo.data.plot[, c("DISTANCE", "RATIO")],
- L2 = tempo.data.plot[, c("DISTANCE", "LOESS")]),
- x = list(L1 = "DISTANCE",
- L2 = "DISTANCE"),
- y = list(L1 = "RATIO",
- L2 = "LOESS"),
- categ = NULL,
- color = list(L1 = grey(0.20),
- L2 = "orange"),
- geom = list(L1 = "geom_point",
- L2 = "geom_line"),
- legend.name = NULL,
- alpha = list(0.2, 1),
- dot.size = dot.size,
- line.size = line.size,
- x.log = "no",
- x.lab = "DISTANCE (D)",
- x.tick.nb = 8,
- y.log = "log2",
- y.lab = "RATIO (M)",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0.05,
- x.right.extra.margin = 0.05,
- y.top.extra.margin = 0.05,
- y.bottom.extra.margin = 0.05
- ) #
- print("ke")
- if (activate.pdf == TRUE) {
- invisible(dev.set(pdf.nb))
- } else{
- fun_open(pdf.disp = activate.pdf,
- width.fun = width.wind,
- height.fun = height.wind)
- }
- # x.range.dist <- range(tempo.data.plot$DISTANCE, na.rm = TRUE, finite = TRUE) # already computed
- y.range.ratio.adj <-
- range(tempo.data.plot$ADJ_RATIO,
- na.rm = TRUE,
- finite = TRUE)
- tempo.title <-
- paste0(
- "OBS MATRICES\nMD PLOT FROM THE HICCOMPARE TABLE AFTER LOESS ADJUSTMENT\n
- ADJUSTED RATIO, LOESS ADJUSTED CELL RATIO BETWEEN THE TWO OBS MATRICES; DISTANCE,
- CELL DISTANCE FROM THE MAIN DIAG (IN NB OF CELLS)\nRATIO IS LOG2(x) TRANSFORMED\n
- X SCALE RANGE: ",
- paste(fun_round(x.range.dist, 2), collapse = " , "),
- "\nY SCALE RANGE: ",
- paste(fun_round(y.range.ratio.adj, 2), collapse = " , ")
- )
- print("te")
- fun_gg_scatter(
- data1 = list(
- L1 = tempo.data.plot[, c("DISTANCE", "ADJ_RATIO")],
- L2 = data.frame(DISTANCE = tempo.data.plot["DISTANCE"], ADJ_LOESS = 0)
- ),
- x = list(L1 = "DISTANCE",
- L2 = "DISTANCE"),
- y = list(L1 = "ADJ_RATIO",
- L2 = "ADJ_LOESS"),
- categ = NULL,
- color = list(L1 = grey(0.20),
- L2 = "orange"),
- geom = list(L1 = "geom_point",
- L2 = "geom_line"),
- legend.name = NULL,
- alpha = list(L1 = 0.2,
- L2 = 1),
- dot.size = dot.size,
- line.size = line.size,
- x.log = "no",
- x.lab = "DISTANCE (D)",
- x.tick.nb = 8,
- y.log = "log2",
- y.lab = "RATIO (M)",
- y.tick.nb = 8,
- title = tempo.title,
- text.size = text.size,
- title.text.size = title.text.size,
- article = TRUE,
- legend.width = NULL,
- raster = raster,
- x.left.extra.margin = 0.05,
- x.right.extra.margin = 0.05,
- y.top.extra.margin = 0.05,
- y.bottom.extra.margin = 0.05
- ) #
- # end loess transformation plot
- print("kokkara ga mondai deshou")
- # non adjusted p value graphs
- hiccomp.pvalue.mask.pre <- hiccompare.graphs.fun(
- hictable_5fun = diff.res.pre,
- mat1_5fun = get(mat1.obs.for.plot),
- mat2_5fun = get(mat2.obs.for.plot),
- ratio.mat_5fun = get(obs.ratio.mat.for.plot),
- df_5fun = obs.df.pre,
- serp.kind_5fun = "BEFORE",
- pvalue.text_5fun = "NON ADJUSTED",
- pvalue.col_5fun = "p.value",
- sparse.name_5fun = sparse.name.pre,
- text_5fun = "",
- heatmap.range_5fun = s.obs.heatmap.range.norm.pre,
- # this already integrates normalization and potential log transformation
- diff.heatmap.range_5fun = diff.both.heatmap.range.norm.pre,
- # this already integrates potential normalization and log transformation
- ratio.cutoff.inf_5fun = ratio.cutoff.inf.pre,
- ratio.cutoff.sup_5fun = ratio.cutoff.sup.pre,
- activate.pdf_5fun = activate.pdf,
- pdf.nb_5fun = pdf.nb,
- width.wind_5fun = width.wind,
- height.wind_5fun = height.wind,
- dot.size_5fun = dot.size,
- text.size_5fun = text.size,
- title.text.size_5fun = title.text.size,
- raster_5fun = raster,
- transfo_5fun = transfo,
- ratio.limit.sig_5fun = ratio.limit.sig,
- line.size_5fun = line.size,
- heatmap.text.size_5fun = heatmap.text.size
- )
- if (!is.null(hiccomp.pvalue.mask.pre)) {
- # no mask finally
- # file saving
- fun_report(
- data = paste0(
- "PRE SERPENTINE FULL MASK DATA SAVED IN: ",
- "hicc_mask_pre_serp.txt"
- ),
- output = log.file,
- path = path.out
- )
- write.table(
- hiccomp.pvalue.mask.pre,
- file = "hicc_pvalue_mask_pre_serp.txt",
- row.names = FALSE,
- col.names = FALSE,
- append = FALSE,
- quote = FALSE,
- sep = "\t"
- )
- # end file saving
- }
- # end non adjusted p value graphs
- # adjusted p value graphs
- hiccomp.padj.mask.pre <- hiccompare.graphs.fun(
- hictable_5fun = diff.res.pre,
- mat1_5fun = get(mat1.obs.for.plot),
- mat2_5fun = get(mat2.obs.for.plot),
- ratio.mat_5fun = get(obs.ratio.mat.for.plot),
- df_5fun = obs.df.pre,
- serp.kind_5fun = "BEFORE",
- pvalue.text_5fun = "ADJUSTED",
- pvalue.col_5fun = "p.adj",
- sparse.name_5fun = sparse.name.pre,
- text_5fun = "",
- heatmap.range_5fun = s.obs.heatmap.range.norm.pre,
- # this already integrates normalization and potential log transformation
- diff.heatmap.range_5fun = diff.both.heatmap.range.norm.pre,
- # this already integrates potential normalization and log transformation
- ratio.cutoff.inf_5fun = ratio.cutoff.inf.pre,
- ratio.cutoff.sup_5fun = ratio.cutoff.sup.pre,
- activate.pdf_5fun = activate.pdf,
- pdf.nb_5fun = pdf.nb,
- width.wind_5fun = width.wind,
- height.wind_5fun = height.wind,
- dot.size_5fun = dot.size,
- text.size_5fun = text.size,
- title.text.size_5fun = title.text.size,
- raster_5fun = raster,
- transfo_5fun = transfo,
- ratio.limit.sig_5fun = ratio.limit.sig,
- line.size_5fun = line.size,
- heatmap.text.size_5fun = heatmap.text.size
- )
- if (!is.null(hiccomp.padj.mask.pre)) {
- # no mask finally
- # file saving
- fun_report(
- data = paste0(
- "PRE SERPENTINE FULL MASK DATA SAVED IN: ",
- "hicc_mask_pre_serp.txt"
- ),
- output = log.file,
- path = path.out
- )
- write.table(
- hiccomp.padj.mask.pre,
- file = "hicc_padj_mask_pre_serp.txt",
- row.names = FALSE,
- col.names = FALSE,
- append = FALSE,
- quote = FALSE,
- sep = "\t"
- )
- # end file saving
- }
- # end adjusted p value graphs
- if (keep == FALSE) {
- tempo.list <-
- c(
- "mat1.obs.sparse.pre",
- "mat2.obs.sparse.pre",
- "diff.res.pre",
- "hiccomp.pvalue.mask.pre",
- "hiccomp.padj.mask.pre"
- )
- tempo.cat <-
- paste0(
- "PRE SERPENTINE HIC COMPARE DATA SAVED IN: ",
- path.out,
- "pre_serp_hiccomp_backup.RData"
- )
- fun_report(data = tempo.cat,
- output = log.file,
- path = path.out)
- save(list = tempo.list, file = "pre_serp_hiccomp_backup.RData")
- rm(list = tempo.list) # not saved because initial matrices
- }
-}
-
-loop.mat.names <- c("mat1.mix", "mat2.mix")
-print("kokomade korenssho")
-
-
-
-for (i0 in 1:length(loop.mat.names)) {
- write.table(
- get(loop.mat.names[i0]),
- file = paste0("mat", i0, ".theo.txt"),
- row.names = FALSE,
- col.names = FALSE,
- append = FALSE,
- quote = FALSE,
- sep = "\t"
- )
-}
diff --git a/bin/slitherine_part1.R b/bin/slitherine_part1.R
new file mode 100644
index 0000000000000000000000000000000000000000..27955e9a4fd8a12b48d7473ec7d3ae2a0d940228
--- /dev/null
+++ b/bin/slitherine_part1.R
@@ -0,0 +1,7276 @@
+#! /usr/bin/Rscript
+
+#########################################################################
+## ##
+## slitherine_part1 ##
+## ##
+## Gael A. Millot ##
+## Vittore F. Scolari ##
+## Lyam Baudry ##
+## Mia Legras ##
+## ##
+#########################################################################
+
+
+################################ Aim
+
+# Slitherine help to define significant coverage differences when comparing two contact matrices
+
+################################ End Aim
+
+
+################################ Introduction
+
+
+################################ End Introduction
+
+
+################################ Acknowlegments
+
+
+################################ End Acknowlegments
+
+
+################################ Initialization
+
+
+# R version checking
+if(version$version.string != "R version 3.5.2 (2018-12-20)"){
+ stop(paste0("\n\n================\n\nERROR IN slitherine_part1.R\n\n\n", version$version.string, " IS NOT THE 3.5.2 RECOMMANDED\n\n================\n\n"))
+}
+# other initializations
+erase.objects = TRUE # write TRUE to erase all the existing objects in R before starting the algorithm and FALSE otherwise. Beginners should use TRUE
+if(erase.objects == TRUE){
+ rm(list = ls(all.names = TRUE))
+ erase.objects = TRUE
+}
+erase.graphs = TRUE # write TRUE to erase all the graphic windows in R before starting the algorithm and FALSE otherwise
+script <- "slitherine_part1"
+
+################################ End Initialization
+
+
+################################ Recording of the initial parameters
+
+tempo.cat <- "KIND OF RUN (SCRIPT, COPY-PASTE OR SOURCE): "
+if(interactive() == FALSE){ # if(grepl(x = commandArgs(trailingOnly = FALSE), pattern = "R\.exe$|\/R$|Rcmd\.exe$|Rcmd$|Rgui\.exe$|Rgui$|Rscript\.exe$|Rscript$|Rterm\.exe$|Rterm$")){ # detection of script usage
+ run.way <- "SCRIPT"
+ cat(paste0("\n\n", tempo.cat, run.way, "\n"))
+ command <- paste0(commandArgs(trailingOnly = FALSE), collapse = ",") # recover the full command
+ args <- commandArgs(trailingOnly = TRUE) # recover arguments written after the call of the R script
+ if(any(is.na(args))){
+ stop(paste0("\n\n================\n\nERROR IN slitherine_part1.R\n\n\nTHE args OBJECT HAS NA\n\n================\n\n"), call. = FALSE)
+ }
+ tempo.arg.names <- c(
+ "file.name1",
+ "file.name2",
+ "theo.path.in",
+ "theo.file.name1",
+ "theo.file.name2",
+ "cute",
+ "lib.path",
+ "path.cv.rho",
+ "path.theo1.theo2",
+ "project.name",
+ "empty.cell.string",
+ "thread.nb",
+ "hiccomp",
+ "binning",
+ "n.row",
+ "win.size",
+ "single.corr",
+ "abs.cor.limit",
+ "print.count",
+ "keep",
+ "ratio.limit.sig",
+ "error",
+ "range.split",
+ "step.factor",
+ "ratio.normalization",
+ "activate.pdf",
+ "optional.text",
+ "width.wind",
+ "height.wind",
+ "dot.size",
+ "line.size",
+ "heatmap.text.size",
+ "text.size",
+ "title.text.size",
+ "raster",
+ "transfo",
+ "warn.secu",
+ "serp.symmet.input",
+ "adj_mean",
+ "hiccompare_graph",
+ "mask_plot"
+ ) # objects names exactly in the same order as in the bash code and recovered in args. Here only one, because only the path of the config file to indicate after the slitherine_part1.R script execution
+ if(length(args) != length(tempo.arg.names)){
+ stop(paste0("\n\n================\n\nERROR IN slitherine_part1.R\n\n\nTHE NUMBER OF ELEMENTS IN args (", length(args),") IS DIFFERENT FROM THE NUMBER OF ELEMENTS IN tempo.arg.names (", length(tempo.arg.names),")\nargs:", paste0(args, collapse = ","), "\ntempo.arg.names:", paste0(tempo.arg.names, collapse = ","), "\n\n================\n\n"), call. = FALSE)
+ }
+ for(i1 in 1:length(tempo.arg.names)){
+ assign(tempo.arg.names[i1], args[i1])
+ }
+ rm(args, i1)
+}else if(sys.nframe() == 0L){ # detection of copy-paste/direct execution (for debugging). With script it is also 0, with source, it is 4
+ run.way <- "COPY-PASTE"
+ cat(paste0("\n\n", tempo.cat, run.way, "\n"))
+}else{
+ run.way <- "SOURCE" # using source(), sys.nframe() is 4
+ cat(paste0("\n\n", tempo.cat, run.way, "\n"))
+}
+rm(tempo.cat)
+
+
+################################ End Config import
+
+################################ Test
+
+# setwd("C:/Users/gael/Documents/Git_projects/slitherine/dev/")
+# tempo.arg.names <- c("file.name1", "file.name2", "theo.path.in","theo.file.name1", "theo.file.name2", "cute", "lib.path","path.cv.rho", "path.theo1.theo2", "project.name", "empty.cell.string", "thread.nb", "hiccomp", "binning", "n.row", "win.size", "single.corr", "abs.cor.limit", "print.count", "keep", "ratio.limit.sig", "error", "range.split", "step.factor", "ratio.normalization", "activate.pdf", "optional.text", "width.wind", "height.wind", "dot.size", "line.size", "heatmap.text.size", "text.size", "title.text.size", "raster", "transfo", "warn.secu", "serp.symmet.input", "adj_mean", "hiccompare_graph", "mask_plot")
+# file.name1 <- "C:/Users/Gael/Documents/Git_projects/slitherine/dataset/AT_Dndj1_D_T0.filt.2500.rebin_1162-1388.txt"
+# file.name2 <- "C:/Users/Gael/Documents/Git_projects/slitherine/dataset/AT200_Aurel_T6.filt.2500.rebin_1162-1388.txt"
+# theo.path.in <- "NULL_2"
+# theo.file.name1 <- "mat1.theo.serp.txt"
+# theo.file.name2 <- "mat2.theo.serp.txt"
+# cute <- "https://gitlab.pasteur.fr/gmillot/cute_little_R_functions/-/raw/c1dd8832f14d76c1901a60ca2a7c87af01a82b61/cute_little_R_functions.R"
+# lib.path <- "NULL_1"
+# path.cv.rho <- "NULL_5"
+# path.theo1.theo2 <- "NULL_6"
+# project.name <- "slitherine"
+# empty.cell.string <- "0"
+# thread.nb <- "NULL"
+# hiccomp <- "TRUE"
+# binning <- "2500"
+# n.row <- "300"
+# win.size <- "20"
+# single.corr <- "MAX"
+# abs.cor.limit <- "0.2"
+# print.count <- "1000000"
+# keep <- "TRUE"
+# ratio.limit.sig <- "2"
+# error <- "0"
+# range.split <- "25"
+# step.factor <- "10"
+# ratio.normalization <- "TRUE"
+# activate.pdf <- "TRUE"
+# optional.text <- "NULL"
+# width.wind <- "7"
+# height.wind <- "7"
+# dot.size <- "2"
+# line.size <- "0.75"
+# heatmap.text.size <- "16"
+# text.size <- "12"
+# title.text.size <- "6"
+# raster <- "TRUE"
+# transfo <- "log2"
+# warn.secu <- "FALSE"
+# serp.symmet.input <- "TRUE"
+# adj_mean <- "C:/Users/Gael/Documents/Git_projects/slitherine/bin/adj_mean.R"
+# hiccompare_graph <- "C:/Users/Gael/Documents/Git_projects/slitherine/bin/hiccompare_graph.R"
+# mask_plot <- "C:/Users/Gael/Documents/Git_projects/slitherine/bin/mask_plot.R"
+
+
+
+################################ end Test
+
+################################ Recording of the initial parameters
+
+
+
+
+
+param.list <- c(
+ "erase.objects",
+ "erase.graphs",
+ "script",
+ "run.way",
+ "tempo.arg.names",
+ if(run.way == "SCRIPT"){"command"},
+ "file.name1",
+ "file.name2",
+ "theo.path.in",
+ "theo.file.name1",
+ "theo.file.name2",
+ "cute",
+ "lib.path",
+ "path.cv.rho",
+ "path.theo1.theo2",
+ "project.name",
+ "empty.cell.string",
+ "thread.nb",
+ "hiccomp",
+ "binning",
+ "n.row",
+ "win.size",
+ "single.corr",
+ "abs.cor.limit",
+ "print.count",
+ "keep",
+ "ratio.limit.sig",
+ "error",
+ "range.split",
+ "step.factor",
+ "ratio.normalization",
+ "activate.pdf",
+ "optional.text",
+ "width.wind",
+ "height.wind",
+ "dot.size",
+ "line.size",
+ "heatmap.text.size",
+ "text.size",
+ "title.text.size",
+ "raster",
+ "transfo",
+ "warn.secu",
+ "serp.symmet.input",
+ "adj_mean",
+ "hiccompare_graph",
+ "mask_plot"
+)
+if(any(duplicated(param.list))){
+ stop(paste0("\n\n================\n\nINTERNAL CODE ERROR 1 IN slitherine_part1.R\n\nTHE param.list OBJECT CONTAINS DUPLICATED ELEMENTS:\n", paste(param.list[duplicated(param.list)], collapse = " "), "\n\n================\n\n"), call. = FALSE) # message for developers
+}
+if(erase.objects == TRUE){
+ created.object.control <- ls()[ ! ls() %in% "param.list"]
+ if( ! (all(created.object.control %in% param.list) & all(param.list %in% created.object.control))){
+ stop(paste0("\n\n================\n\nINTERNAL CODE ERROR 2 IN slitherine_part1.R\n\nINCONSISTENCIES BETWEEN THE ARGUMENTS USED AND THE PARAMETERS REQUIRED IN THE EXECUTABLE CODE FILE\nTHE ARGUMENTS NOT PRESENT IN THE EXECUTABLE FILE (slitherine_part1.R) ARE:\n", paste(created.object.control[ ! created.object.control %in% param.list], collapse = " "), "\nTHE PARAMETERS OF THE EXECUTABLE FILE (slitherine_part1.R) NOT PRESENT IN THE ARGUMENTS ARE:\n", paste(param.list[ ! param.list %in% created.object.control], collapse = " "), "\n\n================\n\n"), call. = FALSE) # message for developers
+ }
+}
+char.length <- nchar(param.list)
+space.add <- max(char.length) - char.length + 5
+param.ini.settings <- character(length = length(param.list))
+for(i in 1:length(param.list)){
+ param.ini.settings[i] <- paste0("\n", param.list[i], paste0(rep(" ", space.add[i]), collapse = ""), paste0(get(param.list[i]), collapse = ",")) # no env = sys.nframe(), inherit = FALSE in get() because look for function in the classical scope
+}
+
+
+################################ End Recording of the initial parameters
+
+
+################################ Functions
+
+
+# Functions are built such that they should have no direct use of Global objects (going through the R scope),
+# but use through the function arguments
+
+# 1) Cute little function is sourced for the moment into the .GlobalEnv environment,
+# but may be interesting to put it into a new environement just above .GlobalEnv environment.
+# See https://stackoverflow.com/questions/9002544/how-to-add-functions-in-an-existing-environment
+
+# 2) Argument names of each function must not be a name of Global objects (error message otherwise)
+
+# 3) Argument name of each function ends with "_fun" in the first function, "_2fun" in the second, etc.
+# This prevent conflicts with the argument partial names when using these functions, notably when they are imbricated
+
+
+
+################ import functions from cute little functions toolbox
+
+
+
+if(length(cute) != 1){
+ stop(paste0("\n\n============\n\nERROR IN slitherine_part1.R\n\ncute PARAMETER MUST BE LENGTH 1: ", paste(cute, collapse = " "), "\n\n============\n\n"), call. = FALSE)
+}else if(grepl(x = cute, pattern = "^http")){
+ tempo.try <- try(suppressWarnings(suppressMessages(source(cute, local = .GlobalEnv))), silent = TRUE)
+ if(any(grepl(x = tempo.try, pattern = "^[Ee]rror"))){
+ stop(paste0("\n\n============\n\nERROR IN slitherine_part1.R\n\nHTTP INDICATED IN THE cute PARAMETER DOES NOT EXISTS: ", cute, "\n\n============\n\n"), call. = FALSE)
+ }else{
+ source(cute, local = .GlobalEnv) # source the fun_ functions used below
+ }
+}else if( ! grepl(x = cute, pattern = "^http")){
+ if( ! file.exists(cute)){
+ stop(paste0("\n\n============\n\nERROR IN slitherine_part1.R\n\nFILE INDICATED IN THE cute PARAMETER DOES NOT EXISTS: ", cute, "\n\n============\n\n"), call. = FALSE)
+ }else{
+ source(cute, local = .GlobalEnv) # source the fun_ functions used below
+ }
+}else{
+ tempo.cat <- paste0("\n\n================\n\nINTERNAL CODE ERROR 3 IN slitherine_part1.R: CODE HAS TO BE MODIFIED\n\n============\n\n")
+ stop(tempo.cat, call. = FALSE)
+}
+
+
+# required cute function checking
+req.function <- c(
+ "fun_check",
+ "fun_pack",
+ "fun_report"
+)
+tempo <- NULL
+for(i1 in req.function){
+ if(length(find(i1, mode = "function")) == 0L){
+ tempo <- c(tempo, i1)
+ }
+}
+if( ! is.null(tempo)){
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R\n\nREQUIRED cute FUNCTION", ifelse(length(tempo) > 1, "S ARE", " IS"), " MISSING IN THE R ENVIRONMENT:\n", paste0(tempo, collapse = "()\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop(), not in tempo.cat, to be able to add several messages between ==
+}
+# end required function checking
+
+
+
+################ function that check the other internal functions of slitherine
+
+
+
+################ local function: package import
+
+
+# R Packages required
+req.package.list <- c(
+ "parallel",
+ "lubridate",
+ "reshape2",
+ "ggplot2",
+ "Cairo"
+)
+## peut etre à enlever
+for(i0 in 1:length(req.package.list)){suppressMessages(library(req.package.list[i0], character.only = TRUE))}
+# fun_pack(req.package = req.package.list, load = TRUE, lib.path = NULL) # packages are imported even if inside functions are written as package.name::function() in the present code
+
+
+################################ End Functions
+
+
+################################ Main code
+
+
+################ Pre-ignition checking
+
+
+# reserved words
+# end reserved words
+# argument primary checking
+arg.check <- NULL #
+text.check <- NULL #
+checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
+ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$object.name))
+for(i0 in tempo.arg.names){
+ tempo <- fun_check(data = get(i0), class = "vector", typeof = "character", length = 1, fun.name = "slitherine_part1.R") ; eval(ee)
+}
+if(any(arg.check) == TRUE){ # normally no NA
+ stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) # == in stop(), not in tempo.cat, to be able to add several messages between == #
+}
+# end argument primary checking
+# second round of checking and data preparation
+# management of NA arguments
+# end management of NA arguments
+# management of NULL arguments, WARNING: only for slitherine_part1.R because NULL is "NULL" in the nextflow.config file
+tempo.arg <-c(
+ "file.name1",
+ "file.name2",
+ "theo.path.in", # not inactivated because can be "NULL_2"
+ "theo.file.name1", # inactivated because can be "NULL_3"
+ "theo.file.name2", # inactivated because can be "NULL_4"
+ # "cute", # already checked above
+ "lib.path", # inactivated because can be "NULL_1"
+ "path.cv.rho", # inactivated because can be "NULL_5"
+ "path.theo1.theo2", # inactivated because can be "NULL_6"
+ "project.name",
+ # "empty.cell.string", # inactivated because can be "NULL"
+ # "thread.nb", # inactivated because can be "NULL"
+ "hiccomp",
+ "binning",
+ # "n.row", # inactivated because can be "NULL"
+ "win.size",
+ "single.corr",
+ "abs.cor.limit",
+ "print.count",
+ "keep",
+ "ratio.limit.sig",
+ "error",
+ "range.split",
+ "step.factor",
+ "ratio.normalization",
+ "activate.pdf",
+ # "optional.text", # inactivated because can be "NULL"
+ "width.wind",
+ "height.wind",
+ "dot.size",
+ "line.size",
+ "heatmap.text.size",
+ "text.size",
+ "title.text.size",
+ "raster",
+ "transfo",
+ "warn.secu",
+ "serp.symmet.input",
+ "adj_mean",
+ "hiccompare_graph",
+ "mask_plot"
+)
+tempo.log <- sapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = function(x){x == "NULL"}) # WARNING: only for slitherine_part1.R
+if(any(tempo.log) == TRUE){# normally no NA with is.null()
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R:\n", ifelse(sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS\n", "THIS ARGUMENT\n"), paste0(tempo.arg[tempo.log], collapse = "\n"),"\nCANNOT BE NULL (SOME MUST BE WRITTEN \"NULL_1\", \"NULL_2\", etc. CHECK THE EXPLANATIONS IN THE slitherine.config FILE)")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop(), not in tempo.cat, to be able to add several messages between ==
+}
+# end management of NULL arguments, WARNING: only for slitherine_part1.R because NULL is "NULL" in the nextflow.config file
+# seed
+set.seed(1)
+# end seed
+# warning initiation
+ini.warning.length <- options()$warning.length
+options(warning.length = 8170)
+warning.message <- NULL
+# warn.count <- 0 # not required
+# end warning initiation
+# other checkings (not full checked because already checked in the .nf file)
+if( ! file.exists(file.name1)){
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R:\nTHE file.name1 PARAMETER MUST BE A VALID PATH OF A FILE IF NOT \"NULL\"\nHERE IT IS: \n", paste0(file.name1, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+}else if(substr(file.name1, nchar(file.name1) - 3, nchar(file.name1)) != ".txt"){
+ tempo.warning <- paste0("THE file.name1 OBJECT SETTING SHOULD BE A TXT FILE BUT DOES NOT FINISH BY \".txt\" LOWERCASE WRITTEN")
+ cat(paste0("\nWARNING: ", tempo.warning, "\n"))
+ warning.message <- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+}
+if( ! file.exists(file.name2)){
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R:\nTHE file.name2 PARAMETER MUST BE A VALID PATH OF A FILE IF NOT \"NULL\"\nHERE IT IS: \n", paste0(file.name2, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+}else if(substr(file.name2, nchar(file.name2) - 3, nchar(file.name2)) != ".txt"){
+ tempo.warning <- paste0("THE file.name1 OBJECT SETTING SHOULD BE A TXT FILE BUT DOES NOT FINISH BY \".txt\" LOWERCASE WRITTEN")
+ cat(paste0("\nWARNING: ", tempo.warning, "\n"))
+ warning.message <- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+}
+if(theo.path.in == "NULL_2"){
+ theo.path.in <- NULL
+}
+if( ! is.null(theo.path.in)){
+ if( ! file.exists(theo.file.name1)){
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R:\nTHE theo.file.name1 PARAMETER MUST BE A VALID PATH OF A FILE IF NOT \"NULL\"\nHERE IT IS: \n", paste0(theo.file.name1, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }else if(substr(theo.file.name1, nchar(theo.file.name1) - 3, nchar(theo.file.name1)) != ".txt"){
+ tempo.warning <- paste0("THE file.name1 OBJECT SETTING SHOULD BE A TXT FILE BUT DOES NOT FINISH BY \".txt\" LOWERCASE WRITTEN")
+ cat(paste0("\nWARNING: ", tempo.warning, "\n"))
+ warning.message <- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+ }
+ if( ! file.exists(theo.file.name2)){
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R:\nTHE theo.file.name2 PARAMETER MUST BE A VALID PATH OF A FILE IF NOT \"NULL\"\nHERE IT IS: \n", paste0(theo.file.name2, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }else if(substr(theo.file.name2, nchar(theo.file.name2) - 3, nchar(theo.file.name2)) != ".txt"){
+ tempo.warning <- paste0("THE file.name1 OBJECT SETTING SHOULD BE A TXT FILE BUT DOES NOT FINISH BY \".txt\" LOWERCASE WRITTEN")
+ cat(paste0("\nWARNING: ", tempo.warning, "\n"))
+ warning.message <- paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+ }
+}
+if(lib.path == "NULL_1"){
+ lib.path <- NULL
+} # dir exist has no sens to be tested when in nextflow
+
+if(path.cv.rho == "NULL_5"){
+ path.cv.rho <- NULL
+}else if( ! file.exists(path.cv.rho)){
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R:\nTHE path.cv.rho PARAMETER MUST BE A VALID PATH OF A FILE IF NOT \"NULL\"\nHERE IT IS: \n", paste0(path.cv.rho, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+}
+if(path.theo1.theo2 == "NULL_6"){
+ path.theo1.theo2 <- NULL
+}else if( ! file.exists(path.theo1.theo2)){
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R:\nTHE path.theo1.theo2 PARAMETER MUST BE A VALID PATH OF A FILE IF NOT \"NULL\"\nHERE IT IS: \n", paste0(path.theo1.theo2, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+}
+
+if(empty.cell.string == "0"){
+ empty.cell.string <- 0
+}else if(empty.cell.string == "NA"){
+ empty.cell.string <- 0
+}else if(empty.cell.string == "-"){
+ empty.cell.string <- "-"
+}
+if(thread.nb == "NULL"){
+ thread.nb <- NULL
+}else{
+ thread.nb <- as.integer(thread.nb) # numeric string already checked by nextflow
+}
+if(hiccomp == "FALSE"){
+ hiccomp <- FALSE
+}else{
+ hiccomp <- TRUE
+}
+binning <- as.integer(binning) # numeric string already checked by nextflow
+n.row <- as.integer(n.row) # numeric string already checked by nextflow
+win.size <- as.integer(win.size) # numeric string already checked by nextflow
+tempo <- fun_check(data = single.corr, options = c("VALUE", "MAX", "DEC1", "QUART1", "MED", "MIN", "NO"), length = 1, fun.name = "slitherine_part1.R")
+if(tempo$problem == TRUE){
+ stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n"), call. = FALSE)
+}
+abs.cor.limit <- as.numeric(abs.cor.limit) # numeric string already checked by nextflow
+print.count <- as.integer(print.count) # numeric string already checked by nextflow
+if(keep == "FALSE"){
+ keep <- FALSE
+}else{
+ keep <- TRUE
+}
+ratio.limit.sig <- as.numeric(ratio.limit.sig) # numeric string already checked by nextflow
+if(ratio.limit.sig < 1){
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R:\nTHE ratio.limit.sig PARAMETER MUST BE A POSITIVE NUMERIC VALUE AT LEAST EQUAL TO 1\nHERE IT IS: \n", paste0(ratio.limit.sig, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+}
+error <- as.numeric(error) # numeric string already checked by nextflow
+range.split <- as.numeric(range.split) # numeric string already checked by nextflow
+step.factor <- as.numeric(step.factor) # numeric string already checked by nextflow
+if(step.factor < 1){
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R:\nTHE step.factor PARAMETER MUST BE A POSITIVE NUMERIC VALUE AT LEAST EQUAL TO 1\nHERE IT IS: \n", paste0(step.factor, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+}
+
+if(ratio.normalization == "FALSE"){
+ ratio.normalization <- FALSE
+}else{
+ ratio.normalization <- TRUE
+}
+if(activate.pdf == "FALSE"){
+ activate.pdf <- FALSE
+}else{
+ activate.pdf <- TRUE
+}
+if(optional.text == "NULL"){
+ optional.text <- ""
+}
+width.wind <- as.numeric(width.wind) # numeric string already checked by nextflow
+height.wind <- as.numeric(height.wind) # numeric string already checked by nextflow
+dot.size <- as.numeric(dot.size) # numeric string already checked by nextflow
+line.size <- as.numeric(line.size) # numeric string already checked by nextflow
+heatmap.text.size <- as.numeric(heatmap.text.size) # numeric string already checked by nextflow
+text.size <- as.numeric(text.size) # numeric string already checked by nextflow
+title.text.size <- as.numeric(title.text.size) # numeric string already checked by nextflow
+if(raster == "FALSE"){
+ raster <- FALSE
+}else{
+ raster <- TRUE
+}
+tempo <- fun_check(data = transfo, options = c("log2", "log10"), length = 1, fun.name = "slitherine_part1.R")
+if(tempo$problem == TRUE){
+ stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n"), call. = FALSE)
+}
+if(warn.secu == "FALSE"){
+ warn.secu <- FALSE
+}else{
+ warn.secu <- TRUE
+}
+if(serp.symmet.input == "FALSE"){
+ serp.symmet.input <- FALSE
+}else{
+ serp.symmet.input <- TRUE
+}
+if( ! file.exists(adj_mean)){
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R:\nTHE adj_mean PARAMETER MUST BE A VALID PATH OF A FILE IF NOT \"NULL\"\nHERE IT IS: \n", paste0(adj_mean, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+}
+if( ! file.exists(hiccompare_graph)){
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R:\nTHE hiccompare_graph PARAMETER MUST BE A VALID PATH OF A FILE IF NOT \"NULL\"\nHERE IT IS: \n", paste0(hiccompare_graph, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+}
+if( ! file.exists(mask_plot)){
+ tempo.cat <- paste0("ERROR IN slitherine_part1.R:\nTHE mask_plot PARAMETER MUST BE A VALID PATH OF A FILE IF NOT \"NULL\"\nHERE IT IS: \n", paste0(mask_plot, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+}
+
+
+source(adj_mean)
+source(mask_plot)
+source(hiccompare_graph)
+
+
+
+
+
+################################################# Inactivated
+if (FALSE){
+file.name1
+file.name2
+theo.file.name1
+theo.file.name2
+path.cv.rho
+path.theo1.theo2
+project.name
+empty.cell.string
+thread.nb
+hiccomp
+binning
+n.row
+win.size
+single.corr
+abs.cor.limit
+print.count
+keep
+ratio.limit.sig
+error
+range.split
+step.factor
+ratio.normalization
+activate.pdf
+optional.text
+width.wind
+height.wind
+dot.size
+line.size
+heatmap.text.size
+text.size
+title.text.size
+raster
+transfo
+warn.secu
+serp.symmet.input
+adj_mean
+hiccompare_graph
+mask_plot
+}
+################################################# end Inactivated
+
+
+
+
+
+
+
+
+
+################ End pre-ignition checking
+
+
+################ Ignition
+
+
+options(scipen = 7)
+analysis.nb <-
+ trunc(as.numeric(Sys.time())) # to provide a specific number ot each analysis
+log.file <- paste0(project.name, "_", analysis.nb, "_report.txt")
+name.dir <- paste0(project.name, "_", analysis.nb)
+
+cat("\nSLITHERINE IGNITION\n")
+fun_report(
+ data = paste0(
+ "\n\n################################ ",
+ log.file,
+ " ################"
+ ),
+ output = log.file,
+ no.overwrite = FALSE,
+ path = "./",
+ sep = 4
+)
+ini.date <- Sys.time()
+ini.time <-
+ as.numeric(ini.date) # time of process begin, converted into seconds
+fun_report(
+ "\n\n################################ RUNNING DATE AND STARTING TIME",
+ output = log.file,
+ path = "./"
+)
+fun_report(
+ data = ini.date,
+ path = "./",
+ output = log.file,
+ vector.cat = TRUE
+)
+cat("\nINITIAL SETTINGS AND DATA MODIFICATIONS\n")
+fun_report(
+ data = "\n\n################################ INITIAL SETTINGS AND DATA MODIFICATIONS",
+ path = "./",
+ output = log.file,
+ sep = 4
+)
+if (optional.text != "") {
+ fun_report(data = "OPTIONAL TEXT: ",
+ path = "./",
+ output = log.file)
+ fun_report(data = optional.text,
+ path = "./",
+ output = log.file)
+}
+
+################ End ignition
+
+
+################ Graphical parameter initialization
+
+fun_open(pdf.disp = activate.pdf, pdf.name.file = "initialization")
+par.ini <-
+ par(no.readonly = TRUE) # to recover the initial graphical parameters if required (reset)
+invisible(dev.off()) # close the new window
+zone.ini <- matrix(1, ncol = 1)
+if (erase.graphs == TRUE) {
+ graphics.off()
+} else{
+ tempo.warning <-
+ paste0("GRAPHICS HAVE NOT BEEN ERASED. GRAPHICAL PARAMETERS MAY HAVE NOT BEEN REINITIALIZED")
+ fun_report(data = tempo.warning,
+ path = "./",
+ output = log.file)
+ warning.message <-
+ paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+}
+
+################ End graphical parameter initialization
+
+
+################ Data import
+
+mat1.obs.ini <- as.matrix(read.table(file.name1))
+mat2.obs.ini <- as.matrix(read.table(file.name2))
+if( ! is.null(theo.path.in)){
+ mat1.mix <-
+ as.matrix(read.table(theo.file.name1))
+ mat2.mix <-
+ as.matrix(read.table(theo.file.name2))
+ tempo.warning <-
+ paste0(
+ "IMPORT OF THEORETICAL MATRICES, WHICH WOULD MEAN THAT THE OBSERVED
+ MATRICES IMPORTED HAVE ALREADY BEEN BINNED USING SERPENTINE"
+ )
+ cat(paste0("\nWARNING: ", tempo.warning, "\n"))
+ warning.message <-
+ paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+
+}
+
+print("end data import")
+################ End data import
+
+
+################ Checking
+
+
+param.check <- NULL #
+checked.param.names <- NULL #
+ee <-
+ expression(
+ param.check <-
+ c(param.check, tempo$problem) ,
+ checked.param.names <-
+ c(checked.param.names, tempo$param.name)
+ )
+for (i0 in 1:2) {
+ if (is.null(theo.path.in)) {
+ # obs matrix must be integer for serpentine binning or for theoretical matrix design
+ tempo <-
+ fun_check(
+ data = get(paste0("mat", i0, ".obs.ini")),
+ data.name = paste0("mat", i0, ".obs.ini"),
+ typeof = "integer",
+ double.as.integer.allowed = TRUE,
+ neg.values = FALSE,
+ fun.name = "SLITHERINE"
+ )
+ eval(ee)
+ if (tempo$problem == TRUE &
+ all(typeof(get(paste0(
+ "mat", i0, ".obs.ini"
+ ))) %in% "character")) {
+ cat(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE: IMPORTED MATRIX IS TYPE \"CHARACTER\".
+ CHECK THAT IT HAS NO ROW OR COLUMN NAMES, WHICH WOULD HAMPER THE MATRIX IMPORT:
+ \n\nMATRIX ",
+ i0,
+ " (",
+ get(paste0("file.name", i0)),
+ "):\n\n"
+ )
+ )
+ print(fun_head(get(paste0(
+ "mat", i0, ".obs.ini"
+ ))))
+ cat("\n\n============\n\n")
+ } else if (tempo$problem == TRUE &
+ all(typeof(get(paste0(
+ "mat", i0, ".obs.ini"
+ ))) %in% "double")) {
+ cat(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE: IMPORTED MATRIX ",
+ get(paste0("file.name", i0)),
+ " HAS DECIMAL VALUES (TYPE \"DOUBLE\"),\nWHILE THE GENERATION OF THEORETICAL MATRICES
+ REQUIRES INTEGERS (USE OF DISCRETE DISTRIBUTIONS).\nARE YOU SURE THAT theo.path.in PARAMETER IS
+ CORRECTLY SET TO \"NULL\"?\n\n"
+ )
+ )
+ print(fun_head(get(paste0(
+ "mat", i0, ".obs.ini"
+ ))))
+ cat("\n\n============\n\n")
+ } else if (tempo$problem == TRUE) {
+ cat(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE: ",
+ get(paste0("file.name", i0)),
+ " PARAMETER MUST BE INTEGER MATRIX (OR DECIMAL MATRIX IF ALREADY SERPENTINE BINNED): ",
+ paste(typeof(get(
+ paste0("mat", i0, ".obs.ini")
+ )), collapse = " "),
+ "\n\n============\n\n"
+ )
+ )
+ }
+ } else{
+ # obs matrix can be decimal (serpentine binned matrix imported), but theo.path.in must be NULL
+ tempo <-
+ fun_check(
+ data = get(paste0("mat", i0, ".obs.ini")),
+ data.name = paste0("mat", i0, ".obs.ini"),
+ class = "matrix",
+ mode = "numeric",
+ neg.values = FALSE,
+ fun.name = "SLITHERINE"
+ )
+ eval(ee)
+ if (tempo$problem == TRUE &
+ all(typeof(get(paste0(
+ "mat", i0, ".obs.ini"
+ ))) %in% "character")) {
+ cat(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE: IMPORTED MATRIX IS TYPE \"CHARACTER\".
+ CHECK THAT IT HAS NO ROW OR COLUMN NAMES, WHICH WOULD HAMPER THE MATRIX IMPORT:
+ \n\nMATRIX ",
+ i0,
+ " (",
+ get(paste0("file.name", i0)),
+ "):\n\n"
+ )
+ )
+ print(fun_head(get(paste0(
+ "mat", i0, ".obs.ini"
+ ))))
+ cat("\n\n============\n\n")
+ }
+ tempo <-
+ fun_check(
+ data = get(paste0("mat", i0, ".obs.ini")),
+ data.name = paste0("mat", i0, ".obs.ini"),
+ class = "matrix",
+ typeof = "integer",
+ double.as.integer.allowed = TRUE,
+ neg.values = FALSE,
+ fun.name = "SLITHERINE",
+ print = FALSE
+ )
+ if (tempo$problem == FALSE &
+ all(typeof(get(paste0(
+ "mat", i0, ".obs.ini"
+ ))) %in% "integer")) {
+ tempo.cat <-
+ paste0(
+ "OBSERVED MATRIX ",
+ i0,
+ " MADE OF INTEGERS WHILE THEORETICAL MATRICES IMPORTED.
+ ARE YOU SURE THAT OBSERVED MATRICES ARE ALREADY SERPENTINE BINNED?"
+ )
+ cat(paste0("\nWARNING: ", tempo.cat, "\n"))
+ fun_report(data = tempo.cat,
+ path = "./",
+ output = log.file)
+ warning.message <-
+ paste0(warning.message,
+ ifelse(is.null(warning.message), "", "\n"),
+ tempo.warning)
+ }
+ tempo <-
+ fun_check(
+ data = get(paste0("mat", i0, ".mix")),
+ data.name = paste0("mat", i0, ".mix"),
+ class = "matrix",
+ mode = "numeric",
+ double.as.integer.allowed = TRUE,
+ neg.values = FALSE,
+ fun.name = "SLITHERINE"
+ )
+ eval(ee)
+ if (tempo$problem == TRUE &
+ all(typeof(get(paste0(
+ "mat", i0, ".mix"
+ ))) %in% "character")) {
+ cat(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE: IMPORTED MATRIX IS TYPE \"CHARACTER\".
+ CHECK THAT IT HAS NO ROW OR COLUMN NAMES, WHICH WOULD HAMPER THE MATRIX IMPORT:\n\n
+ MATRIX ",
+ i0,
+ " (",
+ get(paste0("file.name", i0)),
+ "):\n\n"
+ )
+ )
+ print(fun_head(get(paste0(
+ "mat", i0, ".mix"
+ ))))
+ cat("\n\n============\n\n")
+ } else if (tempo$problem == TRUE &
+ !all(mode(get(paste0(
+ "mat", i0, ".mix"
+ ))) %in% "numeric")) {
+ cat(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE: ",
+ paste0("theo.file.name", i0),
+ " PARAMETER MUST BE DECIMAL MATRIX: ",
+ paste(mode(get(
+ paste0("mat", i0, ".mix")
+ )),
+ collapse = " "),
+ "\n\n============\n\n"
+ )
+ )
+ }
+ }
+}
+tempo <- fun_comp_2d(mat1.obs.ini, mat2.obs.ini)
+if (tempo$same.dim == FALSE) {
+ param.check <- c(param.check, TRUE)
+ cat(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE: DIMENSIONS OF MATRIX 1 AND 2 MUST BE THE SAME.
+ \n\nMATRIX 1: ",
+ paste(dim(mat1.obs.ini), collapse = " "),
+ "\n\nMATRIX 2: ",
+ paste(dim(mat2.obs.ini), collapse = " "),
+ "\n\n============\n\n"
+ )
+ )
+} else if (tempo$dim[1] != tempo$dim[2]) {
+ param.check <- c(param.check, TRUE)
+ cat(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE: MATRIX 1 AND 2 MUST BE SQUARE MATRICES.
+ HERE DIMENSIONS ARE: ",
+ paste(tempo$dim, collapse = " "),
+ "\n\n============\n\n"
+ )
+ )
+} else if (tempo$identical.content == TRUE) {
+ tempo.cat <- paste0("MATRIX 1 AND 2 HAVE IDENTICAL CONTENT")
+ cat(paste0("\nWARNING: ", tempo.cat, "\n"))
+ fun_report(data = tempo.cat,
+ path = "./",
+ output = log.file)
+ warning.message <-
+ paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+}
+if ( ! is.null(theo.path.in)) {
+ # check the variable names. Still mix ?
+ for (i0 in 1:2) {
+ tempo <-
+ fun_check(
+ data = get(paste0("mat", i0, ".mix")),
+ data.name = paste0("mat", i0, ".mix"),
+ class = "matrix",
+ mode = "numeric",
+ neg.values = FALSE,
+ fun.name = "SLITHERINE"
+ )
+ eval(ee) # not necessary integer because serpentine binned matrices are means of binning
+ if (tempo$problem == TRUE &
+ all(typeof(get(paste0(
+ "mat", i0, ".mix"
+ ))) %in% "character")) {
+ cat(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE: IMPORTED MATRIX IS TYPE \"CHARACTER\".
+ CHECK THAT IT HAS NO ROW OR COLUMN NAMES, WHICH WOULD HAMPER THE MATRIX IMPORT:
+ \n\nMATRIX ",
+ i0,
+ " (",
+ get(paste0("mat", i0, ".mix")),
+ "):\n\n"
+ )
+ )
+ print(fun_head(get(paste0(
+ "mat", i0, ".mix"
+ ))))
+ cat("\n\n============\n\n")
+ }
+ }
+ tempo <- fun_comp_2d(mat1.mix, mat2.mix)
+ if (tempo$same.dim == FALSE) {
+ param.check <- c(param.check, TRUE)
+ cat(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE: DIMENSIONS OF THEORETICAL MATRIX 1 AND 2
+ MUST BE THE SAME.\n\nMATRIX 1: ",
+ paste(dim(mat1.mix), collapse = " "),
+ "\n\nMATRIX 2: ",
+ paste(dim(mat2.mix), collapse = " "),
+ "\n\n============\n\n"
+ )
+ )
+ } else if (tempo$identical.content == TRUE) {
+ tempo.cat <-
+ paste0("THEORETICAL MATRIX 1 AND 2 HAVE IDENTICAL CONTENT")
+ cat(paste0("\nWARNING: ", tempo.cat, "\n"))
+ fun_report(data = tempo.cat,
+ path = "./",
+ output = log.file)
+ warning.message <-
+ paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+ }
+ if (ncol(mat1.mix) != ncol(mat1.obs.ini)) {
+ param.check <- c(param.check, TRUE)
+ cat(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE: NUMBER OF COLUMN MUST BE THE SAME BETWEEN THEORETICAL
+ AND OBSERVED MATRICE.\n\nMATRIX 1: ",
+ paste(ncol(mat1.mix), collapse = " "),
+ "\n\nTHEO MATRIX 1: ",
+ paste(ncol(mat1.obs.ini), collapse = " "),
+ "\n\n============\n\n"
+ )
+ )
+ }
+}
+if (any(param.check) == TRUE) {
+ stop() # nothing else because print = TRUE by default in fun_check()
+}
+
+print("end data check")
+################ Info
+
+
+fun_report(
+ data = "MATRIX 1 INFO:",
+ path = "./",
+ output = log.file,
+ sep = 1
+)
+fun_report(
+ data = fun_info(mat1.obs.ini)[c("CLASS",
+ "TYPE",
+ "DIMENSION",
+ "SUM",
+ "RANGE",
+ "MEAN",
+ "NA.NB",
+ "INF.NB")],
+ path = "./",
+ output = log.file,
+ sep = 1
+)
+fun_report(
+ data = "MATRIX 2 INFO:",
+ path = "./",
+ output = log.file,
+ sep = 1
+)
+fun_report(
+ data = fun_info(mat2.obs.ini)[c("CLASS",
+ "TYPE",
+ "DIMENSION",
+ "SUM",
+ "RANGE",
+ "MEAN",
+ "NA.NB",
+ "INF.NB")],
+ path = "./",
+ output = log.file,
+ sep = 1
+)
+
+print("end info")
+################ End Info
+
+
+################ Modification of imported matrices
+
+
+# detection of half matrix
+mat1.modif <- FALSE
+mat2.modif <- FALSE
+if (!is.null(empty.cell.string)) {
+ if (!any(mat1.obs.ini %in% empty.cell.string)) {
+ # works for NA, Inf, etc.
+ stop(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE\nPARAMETER empty.cell.string SET TO ",
+ empty.cell.string,
+ ", WHICH IS NOT PRESENT IN THE IMPORTED MATRIX 1\n\n============\n\n"
+ )
+ )
+ }
+ tempo.mat1.obs <-
+ fun_mat_fill(mat = mat1.obs.ini, empty.cell.string = empty.cell.string)
+ if (!is.null(tempo.mat1.obs$warn)) {
+ mat1.modif <- TRUE
+ fun_report(data = tempo.mat1.obs$warn,
+ path = "./",
+ output = log.file)
+ warning.message <-
+ paste0(warning.message,
+ ifelse(is.null(warning.message), "", "\n"),
+ tempo.mat1.obs$warn)
+ } else{
+ fun_report(
+ data = paste0("MATRIX 1 DETECTED AS SYMMETRIC"),
+ path = "./",
+ output = log.file
+ )
+ }
+ mat1.obs <- tempo.mat1.obs$mat
+ if (!any(mat2.obs.ini %in% empty.cell.string)) {
+ # works for NA, Inf, etc.
+ stop(
+ paste0(
+ "\n\n============\n\nERROR IN SLITHERINE\nPARAMETER empty.cell.string SET TO ",
+ empty.cell.string,
+ ", WHICH IS NOT PRESENT IN THE IMPORTED MATRIX 2\n\n============\n\n"
+ )
+ )
+ }
+ tempo.mat2.obs <-
+ fun_mat_fill(mat = mat2.obs.ini, empty.cell.string = empty.cell.string)
+ if (!is.null(tempo.mat2.obs$warn)) {
+ mat2.modif <- TRUE
+ fun_report(data = tempo.mat2.obs$warn,
+ path = "./",
+ output = log.file)
+ warning.message <-
+ paste0(warning.message,
+ ifelse(is.null(warning.message), "", "\n"),
+ tempo.mat2.obs$warn) #
+ } else{
+ fun_report(
+ data = paste0("MATRIX 2 DETECTED AS SYMMETRIC"),
+ path = "./",
+ output = log.file
+ )
+ }
+ mat2.obs <- tempo.mat2.obs$mat
+} else{
+ mat1.obs <- mat1.obs.ini
+ mat2.obs <- mat2.obs.ini
+ tempo.warning <-
+ paste0(
+ "IMPORTED MATRICES NOT DECLARED HALF FILLED BY THE USER
+ (empty.cell.string PARAMETER SET TO NULL)"
+ )
+ warning.message <-
+ paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning)
+ fun_report(data = tempo.warning,
+ path = "./",
+ output = log.file)
+}
+# detection of the matrix orientation, and t() potentially to always have the same orientation? -> done with the message provided by fun_mat_fill() and the rotate option of fun_heatmap()
+# end detection of half matrix
+
+# diagonal removal
+if (!all(unique(as.matrix(as.data.frame(
+ list(1:nrow(mat1.obs), 1:ncol(mat1.obs))
+))) == 0)) {
+ mat1.obs[as.matrix(as.data.frame(list(1:nrow(mat1.obs), 1:ncol(mat1.obs))))] <-
+ 0
+ mat1.modif <- TRUE
+ tempo.warning <-
+ paste0("MAIN DIAGONAL OF MATRIX 1 HAS BEEN REPLACED BY 0")
+ fun_report(data = tempo.warning,
+ path = "./",
+ output = log.file)
+ warning.message <-
+ paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+}
+if (!all(unique(as.matrix(as.data.frame(
+ list(1:nrow(mat2.obs), 1:ncol(mat2.obs))
+))) == 0)) {
+ mat2.obs[as.matrix(as.data.frame(list(1:nrow(mat2.obs), 1:ncol(mat2.obs))))] <-
+ 0
+ mat2.modif <- TRUE
+ tempo.warning <-
+ paste0("MAIN DIAGONAL OF MATRIX 2 HAS BEEN REPLACED BY 0")
+ fun_report(data = tempo.warning,
+ path = "./",
+ output = log.file)
+ warning.message <-
+ paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+}
+# end diagonal removal
+
+# heatmap: matrix checking
+if (is.null(theo.path.in)) {
+ loop.mat.names <-
+ c("mat1.obs.ini", "mat1.obs", "mat2.obs.ini", "mat2.obs")
+ loop.heatmap.title <-
+ c(
+ "MATRIX 1 IMPORTED",
+ "MATRIX 1 AFTER MODIFICATIONS",
+ "MATRIX 2 IMPORTED",
+ "MATRIX 2 AFTER MODIFICATIONS"
+ )
+} else{
+ loop.mat.names <-
+ c("mat1.obs.ini",
+ "mat1.obs",
+ "mat2.obs.ini",
+ "mat2.obs",
+ "mat1.mix",
+ "mat2.mix")
+ loop.heatmap.title <-
+ c(
+ "MATRIX 1 IMPORTED",
+ "MATRIX 1 AFTER MODIFICATIONS",
+ "MATRIX 2 IMPORTED",
+ "MATRIX 2 AFTER MODIFICATIONS",
+ "THEORETICAL MATRIX 1 IMPORTED",
+ "THEORETICAL MATRIX 2 IMPORTED"
+ )
+ s.both.heatmap.range.pre <- NULL
+}
+# graphic range (min and max value inside matrix) recovering: to have same matrix resolution
+# BEWARE: this means that I take the log2(... + 1) of the matrix that I normalize by the mean of this. Thus, I plot log2(... + 1) on get(loop.mat.names[i0]) / mean(get(loop.mat.names[i0]), na.rm = TRUE)
+s.obs.heatmap.range.pre <- NULL
+for (i0 in 1:length(loop.mat.names)) {
+ # data transformtation
+ if (grepl(x = loop.mat.names[i0], pattern = ".mix$")) {
+ tempo.data.plot <-
+ get(loop.mat.names[i0]) / adj.mean.fun(x_3fun = get(loop.mat.names[i0]),
+ text_3fun = "JUST AFTER IMPORT THEO HEATMAP NORMALIZATION ACCORDING TO THE WEIGHTED DIAGONAL MEAN") # weighted diag for theo only
+ } else{
+ tempo.data.plot <-
+ get(loop.mat.names[i0]) / mean(get(loop.mat.names[i0])[is.finite(get(loop.mat.names[i0]))],
+ na.rm = TRUE) # mean normalization obs matrices
+ }
+ if (transfo != "no") {
+ tempo.data.plot <- get(transfo)(tempo.data.plot + 1) # log transfo
+ }
+ # end data transformtation
+ if (grepl(x = loop.mat.names[i0], pattern = ".mix$")) {
+ # if is.null(theo.path.in), then no.mix matrices and this condition is not filled
+ s.both.heatmap.range.pre <-
+ range(
+ c(
+ s.obs.heatmap.range.pre,
+ s.both.heatmap.range.pre,
+ tempo.data.plot
+ ),
+ na.rm = TRUE,
+ finite = TRUE
+ )
+ } else{
+ s.obs.heatmap.range.pre <-
+ range(
+ c(s.obs.heatmap.range.pre, tempo.data.plot),
+ na.rm = TRUE,
+ finite = TRUE
+ )
+ }
+}
+# end graphic range (min and max value inside matrix) recovering: to have same matrix resolution
+# heatmap
+loop.heatmap.title <- paste0(
+ loop.heatmap.title,
+ "\n",
+ if (transfo == "log2") {
+ "LOG2(x + 1) "
+ } else if (transfo == "log10") {
+ "LOG10(x + 1) "
+ } else{
+ "NO "
+ },
+ "TRANSFORMATION\nSCALE RANGE: ",
+ paste(fun_round(s.obs.heatmap.range.pre, 2), collapse = " , "),
+ "\nNORMALIZED DISPLAY (GLOBAL MEAN DIVISION, WHICH WOULD EXPLAIN INTENSITY VARIATION)"
+)
+for (i0 in 1:length(loop.mat.names)) {
+ # data transformtation
+ if (grepl(x = loop.mat.names[i0], pattern = ".mix$")) {
+ tempo.data.plot <-
+ get(loop.mat.names[i0]) / adj.mean.fun(x_3fun = get(loop.mat.names[i0]),
+ text_3fun = "JUST AFTER IMPORT THEO HEATMAP NORMALIZATION ACCORDING TO THE WEIGHTED DIAGONAL MEAN") # weighted diag for theo only
+ tempo.range <- s.both.heatmap.range.pre
+ } else{
+ tempo.data.plot <-
+ get(loop.mat.names[i0]) / mean(get(loop.mat.names[i0])[is.finite(get(loop.mat.names[i0]))],
+ na.rm = TRUE) # mean normalization obs matrices
+ tempo.range <- s.obs.heatmap.range.pre
+ }
+ if (transfo != "no") {
+ tempo.data.plot <- get(transfo)(tempo.data.plot + 1)
+ }
+ # end data transformation
+ if (activate.pdf == TRUE) {
+ if (i0 == 1) {
+ fun_open(
+ pdf.disp = activate.pdf,
+ fun.path = "./",
+ pdf.name.file = paste0("plots_", analysis.nb),
+ width.fun = width.wind,
+ height.fun = height.wind
+ )
+ pdf.nb <- dev.cur()
+ } else{
+ invisible(dev.set(pdf.nb))
+ }
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ if (i0 == 1) {
+ fun_gg_empty_graph(text = "MATRIX MODIFICATION\nCHECKING", text.size = 3)
+ }
+ if ((loop.mat.names[i0] == "mat1.obs" &
+ mat1.modif == FALSE) |
+ (loop.mat.names[i0] == "mat2.obs" & mat2.modif == FALSE)) {
+ fun_gg_empty_graph(
+ title = loop.heatmap.title[i0],
+ text = "NO MODIFICATION OF THE IMPORTED MATRIX\n
+ (HALF FILLING\n&\nMAIN DIAGONAL REPLACEMENT BY ZERO",
+ text.size = 3,
+ title.size = title.text.size
+ )
+ } else{
+ fun_gg_heatmap(
+ data1 = tempo.data.plot,
+ legend.name = "",
+ limit1 = tempo.range,
+ midpoint1 = mean(tempo.range, na.rm = TRUE),
+ title = loop.heatmap.title[i0],
+ text.size = heatmap.text.size,
+ title.text.size = title.text.size
+ )
+ }
+}
+if (keep == FALSE) {
+ rm(list = c("mat1.obs.ini", "mat2.obs.ini")) # not saved because initial matrices
+}
+# end heatmap
+# end heatmap: matrix checking
+
+write.table(
+ mat1.obs,
+ file = paste0("mat1.obs.txt"),
+ row.names = FALSE,
+ col.names = FALSE,
+ append = FALSE,
+ quote = FALSE,
+ sep = "\t"
+)
+write.table(
+ mat2.obs,
+ file = paste0("mat2.obs.txt"),
+ row.names = FALSE,
+ col.names = FALSE,
+ append = FALSE,
+ quote = FALSE,
+ sep = "\t"
+)
+
+# end export of matrices
+################ end modification of imported matrices
+
+
+################ detection of diagonales with mean zero
+
+
+if (is.null(theo.path.in)) {
+ # means of matrix diagonales will then be modified such as when one is mean zero, the other one is also mean zero
+ tempo.cat <-
+ "MEANS OF MATRIX DIAGONALES ARE MODIFIED SUCH AS WHEN ONE IS MEAN ZERO, THE OTHER ONE IS ALSO MEAN ZERO"
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ # Means and sd are computed for each diagonal
+ tempo.coord <-
+ row(mat1.obs) - col(mat1.obs) # BEWARE: diag 0 is first diagonal and diag n-1 is last diagonal !! row(pmat)-col(pmat) generate a matrix with same number on upleft/rightdown diag, with 0 for main diag and negative number for half right part
+ diag.mean.mat1.obs <-
+ sapply(
+ 0:-(nrow(mat1.obs) - 1),
+ FUN = function(x) {
+ mean(mat1.obs[tempo.coord == x], na.rm = TRUE)
+ }
+ ) # work on the diagonales
+ diag.mean.mat2.obs <-
+ sapply(
+ 0:-(nrow(mat2.obs) - 1),
+ FUN = function(x) {
+ mean(mat2.obs[tempo.coord == x], na.rm = TRUE)
+ }
+ ) # work on the diagonales
+ common.null.mean.pos <-
+ diag.mean.mat1.obs == 0 | diag.mean.mat2.obs == 0
+
+
+ ################ Analysis of observed matrices and data extraction
+
+
+ # MATRIX 1
+ cat("\nCOLLECTION OF DIAGONAL PARAMETERS FROM OBSERVED MATRICES\n")
+ fun_report(
+ data = "\n\n################################ COLLECTION OF DIAGONAL PARAMETERS FROM OBSERVED MATRICES",
+ path = "./",
+ output = log.file,
+ sep = 4
+ )
+ # Means and sd are computed for each diagonal
+ tempo.coord <-
+ row(mat1.obs) - col(mat1.obs) # row(pmat)-col(pmat) generate a matrix with same number on upleft/rightdown diag, with 0 for main diag and negative number for half right part
+ # diag.mean.mat1.obs already obtained above
+ diag.sd.mat1.obs <-
+ sapply(
+ 0:-(nrow(mat1.obs) - 1),
+ FUN = function(x) {
+ sd(mat1.obs[tempo.coord == x], na.rm = TRUE)
+ }
+ ) # BEWARE: the last is NA because a single value for this corner diag
+ diag.cor.mat1.obs <-
+ suppressWarnings(sapply(
+ 0:-(nrow(mat1.obs) - 1),
+ FUN = function(x) {
+ cor(
+ x = mat1.obs[tempo.coord == x],
+ y = mat2.obs[tempo.coord == x],
+ use = "pairwise.complete.obs",
+ method = "spearman"
+ )
+ }
+ )) # BEWARE: the last is NA because a single value for this corner diag # to remove the sd null message
+ mean.sd.cv.cor.mat1.obs <-
+ as.matrix(
+ data.frame(
+ MEAN = diag.mean.mat1.obs,
+ SD = diag.sd.mat1.obs,
+ CV = diag.sd.mat1.obs / diag.mean.mat1.obs,
+ COR = diag.cor.mat1.obs
+ )
+ )
+
+ # replacement of the NA SD CV and CORR on the last line by ZER0: no consequence because we do not use SD, we use CV for taking one of them among the max and CORR we also use high values
+ if (!all(is.na(mean.sd.cv.cor.mat1.obs[nrow(mean.sd.cv.cor.mat1.obs), c("SD", "CV", "COR")]))) {
+ tempo.cat <-
+ paste0(
+ "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\nTHE LAST LINE (I.E., CORNER DIAGONAL)
+ OF mean.sd.cv.cor.mat1.obs SHOULD BE NA FOR SD, CV AND CORR, BECAUSE A SINGLE VALUE
+ IN THE CORNER DIAGONAL\n\n========\n\n"
+ )
+ cat(tempo.cat)
+ print(mean.sd.cv.cor.mat1.obs[nrow(mean.sd.cv.cor.mat1.obs),])
+ stop()
+ } else{
+ mean.sd.cv.cor.mat1.obs[nrow(mean.sd.cv.cor.mat1.obs), c("SD", "CV", "COR")] <-
+ 0
+ tempo.cat <-
+ paste0(
+ "FOR SD, CV AND CORR COLUMNS, REPLACEMENT OF the NA IN THE LAST LINE
+ (I.E., CORNER DIAGONAL) OF mean.sd.cv.cor.mat1.obs BY ZERO\nNO CONSEQUENCE BECAUSE
+ WE DO NOT USE SD, WE USE CV FOR TAKING ONE OF THEM AMONG THE MAX
+ AND FOR CORR WE ALSO USE HIGH VALUES\n"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(
+ data = mean.sd.cv.cor.mat1.obs[nrow(mean.sd.cv.cor.mat1.obs),],
+ output = log.file,
+ path = "./",
+ rownames.kept = TRUE
+ )
+ }
+
+ tempo.detect <-
+ apply(mean.sd.cv.cor.mat1.obs, 2, FUN = "%in%", c(-Inf, NA, Inf)) # in the matrix
+ if (all(is.na(tempo.detect[nrow(tempo.detect), c("SD", "CV", "COR")])) == TRUE &
+ (tempo.detect[nrow(tempo.detect), "MEAN"] == FALSE)) {
+ tempo.cat <- paste0(
+ "THE LAST LINE (I.E., CORNER DIAGONAL) OF
+ mean.sd.cv.cor.mat1.obs IS NA FOR SD, CV and CORR, BUT THIS IS EXPECTED BECAUSE
+ A SINGLE VALUE IN THE CORNER DIAGONAL"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(data = mean.sd.cv.cor.mat1.obs[tempo.detect,],
+ output = log.file,
+ path = "./")
+ } else if (all(is.na(tempo.detect[nrow(tempo.detect), c("SD", "CV", "COR")])) == TRUE &
+ (tempo.detect[nrow(tempo.detect), "MEAN"] == TRUE)) {
+ tempo.cat <-
+ paste0(
+ "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\nTHE LAST LINE (I.E., CORNER DIAGONAL)
+ OF mean.sd.cv.cor.mat1.obs CANNOT BE -Inf, NA OR Inf FOR THE MEAN COLUMN\n\n========\n\n"
+ )
+ cat(tempo.cat)
+ print(mean.sd.cv.cor.mat1.obs[nrow(tempo.detect),])
+ stop()
+ } else if (any(tempo.detect[-nrow(tempo.detect),]) == TRUE |
+ any(tempo.detect[nrow(tempo.detect), "MEAN"]) == TRUE) {
+ tempo.cat <-
+ paste0(
+ "BEWARE: EXCEPT THE LAST ROW (I.E., CORNER DIAGONAL), ALSO PRESENCE OF -Inf, NA, OR
+ Inf DETECTED IN mean.sd.cv.cor.mat1.obs, WHICH WILL PUT NA IN THEORETICAL MATRIX 1,
+ WHICH IS NOT COMPATIBLE WITH SERPENTINE. REPLACEMENT OF NA WILL BE MADE THENAFTER"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(
+ data = mean.sd.cv.cor.mat1.obs[apply(tempo.detect, 1, FUN = any),],
+ output = log.file,
+ path = "./",
+ rownames.kept = TRUE
+ )
+ mean.sd.cv.cor.mat1.obs[tempo.detect] <-
+ NA # NA, -Inf and Inf replaced by NA
+ }
+
+ mean.sd.cv.cor.mat1.obs <-
+ as.data.frame(mean.sd.cv.cor.mat1.obs)
+ # end replacement of c(-Inf, NA, Inf) by NA
+ # replacement of mean, sd, cor by zero if common null diag between mat1.obs and mat2.obs
+ if (any(common.null.mean.pos)) {
+ mean.sd.cv.cor.mat1.obs[common.null.mean.pos, c("MEAN", "SD", "COR")] <-
+ 0
+ tempo.cat <-
+ paste0(
+ "BEWARE: IF AT LEAST ONE OF THE OBSERVED DIAG MEAN IS ZERO,
+ THE CODE WILL CONSIDER THAT THE DIAG MEANS, SD, AND CORR ARE ZERO FOR THE TWO THEO
+ CORRESPONDING DIAGONALES"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ tempo.cat <- "REPLACEMENT BY ZERO IN THE THEO MAT 1"
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(
+ data = mean.sd.cv.cor.mat1.obs[common.null.mean.pos,],
+ output = log.file,
+ path = "./",
+ rownames.kept = TRUE
+ )
+ }
+ # end replacement of mean, sd, cor by zero if common null diag between mat1.obs and mat2.obs
+ # END MATRIX 1
+
+ # MATRIX 2
+ # Means and sd are computed for each diagonal
+ tempo.coord <-
+ row(mat2.obs) - col(mat2.obs) # row(pmat)-col(pmat) generate a matrix with same number on upleft/rightdown diag, with 0 for main diag and negative number for half right part
+ # diag.mean.mat2.obs already obtained above
+ diag.sd.mat2.obs <- sapply(
+ 0:-(nrow(mat2.obs) - 1),
+ FUN = function(x) {
+ sd(mat2.obs[tempo.coord == x], na.rm = TRUE)
+ }
+ ) # BEWARE: the last is NA because a single value for this corner diag
+ diag.cor.mat2.obs <-
+ suppressWarnings(sapply(
+ 0:-(nrow(mat2.obs) - 1),
+ FUN = function(x) {
+ cor(
+ x = mat1.obs[tempo.coord == x],
+ y = mat2.obs[tempo.coord == x],
+ use = "pairwise.complete.obs",
+ method = "spearman"
+ )
+ }
+ )) # BEWARE: the last is NA because a single value for this corner diag # to remove the sd null message
+ mean.sd.cv.cor.mat2.obs <-
+ as.matrix(
+ data.frame(
+ MEAN = diag.mean.mat2.obs,
+ SD = diag.sd.mat2.obs,
+ CV = diag.sd.mat2.obs / diag.mean.mat2.obs,
+ COR = diag.cor.mat2.obs
+ )
+ )
+
+ # replacement of the NA SD CV and CORR on the last line by ZER0: no consequence because we do not use SD, we use CV for taking one of them among the max and CORR we also use high values
+ if (!all(is.na(mean.sd.cv.cor.mat2.obs[nrow(mean.sd.cv.cor.mat2.obs), c("SD", "CV", "COR")]))) {
+ tempo.cat <-
+ paste0(
+ "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ THE LAST LINE (I.E., CORNER DIAGONAL) OF mean.sd.cv.cor.mat2.obs SHOULD BE NA FOR SD,
+ CV AND CORR, BECAUSE A SINGLE VALUE IN THE CORNER DIAGONAL\n\n========\n\n"
+ )
+ cat(tempo.cat)
+ print(mean.sd.cv.cor.mat2.obs[nrow(mean.sd.cv.cor.mat2.obs),])
+ stop()
+ } else{
+ mean.sd.cv.cor.mat2.obs[nrow(mean.sd.cv.cor.mat2.obs), c("SD", "CV", "COR")] <-
+ 0
+ tempo.cat <-
+ paste0(
+ "FOR SD, CV AND CORR COLUMNS, REPLACEMENT OF the NA IN THE LAST LINE
+ (I.E., CORNER DIAGONAL) OF mean.sd.cv.cor.mat2.obs BY ZERO\n
+ NO CONSEQUENCE BECAUSE WE DO NOT USE SD, WE USE CV FOR TAKING ONE OF THEM AMONG
+ THE MAX AND FOR CORR WE ALSO USE HIGH VALUES\n"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(
+ data = mean.sd.cv.cor.mat2.obs[nrow(mean.sd.cv.cor.mat2.obs),],
+ output = log.file,
+ path = "./",
+ rownames.kept = TRUE
+ )
+ }
+
+ tempo.detect <-
+ apply(mean.sd.cv.cor.mat2.obs, 2, FUN = "%in%", c(-Inf, NA, Inf)) # in the matrix
+ if (all(is.na(tempo.detect[nrow(tempo.detect), c("SD", "CV", "COR")])) == TRUE &
+ (tempo.detect[nrow(tempo.detect), "MEAN"] == FALSE)) {
+ tempo.cat <-
+ paste0(
+ "THE LAST LINE (I.E., CORNER DIAGONAL) OF mean.sd.cv.cor.mat2.obs IS NA FOR SD,
+ CV and CORR, BUT THIS IS EXPECTED BECAUSE A SINGLE VALUE IN THE CORNER DIAGONAL"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(data = mean.sd.cv.cor.mat2.obs[tempo.detect,],
+ output = log.file,
+ path = "./")
+ } else if (all(is.na(tempo.detect[nrow(tempo.detect), c("SD", "CV", "COR")])) == TRUE &
+ (tempo.detect[nrow(tempo.detect), "MEAN"] == TRUE)) {
+ tempo.cat <-
+ paste0(
+ "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ THE LAST LINE (I.E., CORNER DIAGONAL) OF mean.sd.cv.cor.mat2.obs CANNOT BE
+ -Inf, NA OR Inf FOR THE MEAN COLUMN\n\n========\n\n"
+ )
+ cat(tempo.cat)
+ print(mean.sd.cv.cor.mat2.obs[nrow(tempo.detect),])
+ stop()
+ } else if (any(tempo.detect[-nrow(tempo.detect),]) == TRUE |
+ any(tempo.detect[nrow(tempo.detect), "MEAN"]) == TRUE) {
+ tempo.cat <-
+ paste0(
+ "BEWARE: EXCEPT THE LAST ROW (I.E., CORNER DIAGONAL), ALSO PRESENCE OF
+ -Inf, NA, OR Inf DETECTED IN mean.sd.cv.cor.mat2.obs, WHICH WILL PUT NA IN THEORETICAL MATRIX 2,
+ WHICH IS NOT COMPATIBLE WITH SERPENTINE. REPLACEMENT OF NA WILL BE MADE THENAFTER"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(
+ data = mean.sd.cv.cor.mat2.obs[apply(tempo.detect, 1, FUN = any),],
+ output = log.file,
+ path = "./",
+ rownames.kept = TRUE
+ )
+ mean.sd.cv.cor.mat2.obs[tempo.detect] <-
+ NA # NA, -Inf and Inf replaced by NA
+ }
+
+ mean.sd.cv.cor.mat2.obs <-
+ as.data.frame(mean.sd.cv.cor.mat2.obs)
+ # end replacement of c(-Inf, NA, Inf) by NA
+ # replacement of mean, sd, cor by zero if common null diag between mat2.obs and mat2.obs
+ if (any(common.null.mean.pos)) {
+ mean.sd.cv.cor.mat2.obs[common.null.mean.pos, c("MEAN", "SD", "COR")] <-
+ 0
+ tempo.cat <-
+ paste0(
+ "BEWARE: IF AT LEAST ONE OF THE OBSERVED DIAG MEAN IS ZERO,
+ THE CODE WILL CONSIDER THAT THE DIAG MEANS, SD, AND CORR ARE ZERO
+ FOR THE TWO THEO CORRESPONDING DIAGONALES"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ tempo.cat <- "REPLACEMENT BY ZERO IN THE THEO MAT 2"
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(
+ data = mean.sd.cv.cor.mat2.obs[common.null.mean.pos,],
+ output = log.file,
+ path = "./",
+ rownames.kept = TRUE
+ )
+ }
+ # end replacement of mean, sd, cor by zero if common null diag between mat2.obs and mat2.obs
+ # END MATRIX 2
+
+ ################ End Analysis of observed matrices and data extraction
+
+
+ ################ detection of diagonales with NA correlation
+
+
+ # replacement of cor by zero if any NA correlation diag between mat1.obs and mat2.obs
+ common.na.cor.pos <-
+ is.na(mean.sd.cv.cor.mat1.obs$COR) |
+ is.na(mean.sd.cv.cor.mat2.obs$COR)
+ if (any(common.na.cor.pos)) {
+ mean.sd.cv.cor.mat1.obs[common.na.cor.pos, "COR"] <- 0
+ mean.sd.cv.cor.mat2.obs[common.na.cor.pos, "COR"] <- 0
+ tempo.cat <-
+ paste0(
+ "BEWARE: IF AT LEAST ONE OF THE OBSERVED DIAG CORRELATION IS NA
+ (POSSIBLE IF ONE SD IS 0, I.E., IDENTICAL VALUES IN THE DIAGONAL),
+ THE CODE WILL CONSIDER THAT THE DIAG CORR ARE ZERO FOR THE TWO THEO CORRESPONDING DIAGONALES"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ tempo.cat <- "REPLACEMENT BY ZERO IN THE THEO MAT 1"
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(
+ data = mean.sd.cv.cor.mat1.obs[common.na.cor.pos,],
+ output = log.file,
+ path = "./",
+ rownames.kept = TRUE
+ )
+ tempo.cat <- "REPLACEMENT BY ZERO IN THE THEO MAT 2"
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(
+ data = mean.sd.cv.cor.mat2.obs[common.na.cor.pos,],
+ output = log.file,
+ path = "./",
+ rownames.kept = TRUE
+ )
+ }
+ # end replacement of cor by zero if any NA correlation diag between mat1.obs and mat2.obs
+
+ print("end detect diag NA corr")
+ ################ end detection of diagonales with NA correlation
+
+
+ ################ plot verification
+
+ print("plot verif")
+ # homogeneous scale
+ m_sd.coord.obs <-
+ fun_gg_scatter(
+ data1 = list(L1 = if (transfo != "no") {
+ get(transfo)(mean.sd.cv.cor.mat1.obs[, c("MEAN", "SD")])
+ } else{
+ mean.sd.cv.cor.mat1.obs[, c("MEAN", "SD")]
+ }, L2 = if (transfo != "no") {
+ get(transfo)(mean.sd.cv.cor.mat2.obs[,
+ c("MEAN", "SD")])
+ } else{
+ mean.sd.cv.cor.mat2.obs[, c("MEAN", "SD")]
+ }),
+ x = list(L1 = "MEAN", L2 = "MEAN"),
+ y = list(L1 = "SD", L2 = "SD"),
+ geom = list("geom_point", "geom_point"),
+ alpha = list(0.5, 0.5),
+ x.log = transfo,
+ y.log = transfo,
+ plot = FALSE,
+ return = TRUE
+ )
+ m_sd.x.range <- m_sd.coord.obs$axes$x.range
+ m_sd.y.range <- m_sd.coord.obs$axes$y.range
+ m_cor.coord.obs <- fun_gg_scatter(
+ data1 = list(
+ L1 = data.frame(MEAN = if (transfo != "no") {
+ get(transfo)(mean.sd.cv.cor.mat1.obs[, "MEAN"])
+ } else{
+ mean.sd.cv.cor.mat1.obs[, "MEAN"]
+ }, mean.sd.cv.cor.mat1.obs["COR"]),
+ L2 = data.frame(MEAN = if (transfo != "no") {
+ get(transfo)(mean.sd.cv.cor.mat2.obs[, "MEAN"])
+ } else{
+ mean.sd.cv.cor.mat2.obs[, "MEAN"]
+ }, mean.sd.cv.cor.mat2.obs["COR"])
+ ),
+ x = list(L1 = "MEAN", L2 = "MEAN"),
+ y = list(L1 = "COR", L2 = "COR"),
+ geom = list("geom_point", "geom_point"),
+ alpha = list(0.5, 0.5),
+ x.log = transfo,
+ y.log = "no",
+ plot = FALSE,
+ return = TRUE,
+ y.lim = c(-1, 1)
+ )
+ m_cor.x.range <- m_cor.coord.obs$axes$x.range
+ m_cor.y.range <- m_cor.coord.obs$axes$y.range
+ m_cv.coord.obs <- fun_gg_scatter(
+ data1 = list(L1 = if (transfo != "no") {
+ get(transfo)(mean.sd.cv.cor.mat1.obs[, c("MEAN", "CV")])
+ } else{
+ mean.sd.cv.cor.mat1.obs[, c("MEAN", "CV")]
+ },
+ L2 = if (transfo != "no") {
+ get(transfo)(mean.sd.cv.cor.mat2.obs[, c("MEAN", "CV")])
+ } else{
+ mean.sd.cv.cor.mat2.obs[, c("MEAN", "CV")]
+ }),
+ x = list(L1 = "MEAN", L2 = "MEAN"),
+ y = list(L1 = "CV", L2 = "CV"),
+ geom = list("geom_point", "geom_point"),
+ alpha = list(0.5, 0.5),
+ x.log = transfo,
+ y.log = transfo,
+ plot = FALSE,
+ return = TRUE
+ )
+ m_cv.x.range <- m_cv.coord.obs$axes$x.range
+ m_cv.y.range <- m_cv.coord.obs$axes$y.range
+ # end homogeneous scale
+ print("mada daijoubu")
+ # MATRIX1
+ # heatmap: matrix checking
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ fun_gg_empty_graph(text = "OBSERVED MATRIX 1:\nCOLLECTION OF DIAGONAL PARAMETERS", text.size = 3)
+
+ tempo.data.plot <- mean.sd.cv.cor.mat1.obs
+ tempo.data.plot2 <-
+ data.frame(
+ MEAN = tempo.data.plot$MEAN,
+ MEAN.MINUS.SD = tempo.data.plot$MEAN - tempo.data.plot$SD,
+ MEAN.PLUS.SD = tempo.data.plot$MEAN + tempo.data.plot$SD
+ ) # created here to be before log transformation
+ if (transfo != "no") {
+ tempo.data.plot[, c("MEAN", "SD", "CV")] <-
+ get(transfo)(tempo.data.plot[, c("MEAN", "SD", "CV")]) # log(x + 1) only for heatmap
+ tempo.data.pois <-
+ data.frame(
+ x.pois = tempo.data.plot$MEAN,
+ y.sd.pois = tempo.data.plot$MEAN / 2,
+ y.cv.pois = get(transfo)(1) - tempo.data.plot$MEAN / 2
+ ) # because poisson distrib is mean = variance, thus sd = mean ^0.5, ie each mean as x is square rooted for y and then x.MEAN / 2 because log2(mean^0.5) = 0.5 * log2(mean). For cv, cv = sd/m -> log(cv) = log(sd/m) = log(m/m^0.5) = log(1/m^0.5) = log(1) - log(m^0.5) = log(1) - log(m)/2
+ } else{
+ tempo.data.pois <-
+ data.frame(
+ x.pois = tempo.data.plot$MEAN,
+ y.sd.pois = tempo.data.plot$MEAN ^ 0.5,
+ y.cv.pois = 1 / tempo.data.plot$MEAN ^
+ 0.5
+ )
+ }
+
+ # mean versus index plot
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ if (transfo != "no") {
+ tempo.data.plot2 <-
+ suppressWarnings(get(transfo)(tempo.data.plot2)) # log(x + 1) only for heatmap
+ if (any(is.na(tempo.data.plot2$MEAN.MINUS.SD))) {
+ tempo.data.plot2$MEAN.MINUS.SD[is.na(tempo.data.plot2$MEAN.MINUS.SD)] <-
+ tempo.data.plot2$MEAN[is.na(tempo.data.plot2$MEAN.MINUS.SD)]
+ }
+ }
+
+ tempo.data.plot2 <-
+ data.frame(COLUMN_NB = 1:nrow(tempo.data.plot2), tempo.data.plot2)
+ tempo.title <-
+ paste0(
+ "MAT1 OBS\nMEAN PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x)\n
+ ABSENT SD IF LOG2(M - SD) < 0 "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x)
+ \nABSENT SD IF LOG10(M - SD) < 0 "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nDIAGONAL NB FROM MAIN TO CORNER\nX SCALE RANGE: ",
+ paste(range(
+ 1:nrow(tempo.data.plot2),
+ na.rm = TRUE,
+ finite = TRUE
+ ), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.x.range, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot2),
+ x = list("COLUMN_NB"),
+ y = list("MEAN"),
+ color = list(grey(0.40)),
+ geom = list("geom_point"),
+ alpha = list(0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.log = "no",
+ x.lab = "DIAGONAL NB",
+ x.tick.nb = 8,
+ y.log = transfo,
+ y.lab = "MEAN",
+ y.lim = m_sd.x.range,
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ add = paste0(
+ '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot2$COLUMN_NB,
+ xend = tempo.data.plot2$COLUMN_NB, y = tempo.data.plot2$MEAN.MINUS.SD, yend = tempo.data.plot2$MEAN.PLUS.SD),
+ ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
+ )
+ )
+ # end mean versus index plot
+
+ # Mean Deviation (MD) plot of the observed matrix
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.title <- paste0(
+ "MAT1 OBS\nMEAN DEVIATION (MD) PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_sd.x.range, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.y.range, 2), collapse = " , "),
+ "\nRED LINE: POISSON DISTRIB\n"
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot, tempo.data.pois),
+ x = list("MEAN", "x.pois"),
+ y = list("SD", "y.sd.pois"),
+ color = list(grey(0.40), "red"),
+ geom = list("geom_point", "geom_line"),
+ alpha = list(0.5, 1),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_sd.x.range,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_sd.y.range,
+ y.log = transfo,
+ y.lab = "SD",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
+ # end Mean Deviation (MD) plot of the observed matrix
+
+ # mean / cor of the observed matrix
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.title <-
+ paste0(
+ "MAT1 OBS\nMEAN VERSUS MAT1 OBS / MAT2 OBS SPEARMAN CORRELATION\n",
+ if (transfo == "log2") {
+ "MEAN LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_cor.x.range, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_cor.y.range, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = tempo.data.plot,
+ x = "MEAN",
+ y = "COR",
+ color = grey(0.40),
+ geom = "geom_point",
+ alpha = 0.5,
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_cor.x.range,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_cor.y.range,
+ y.log = "no",
+ y.lab = "CORRELATION",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
+ # end mean / cor of the observed matrix
+
+ # mean / cv of the observed matrix
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.title <- paste0(
+ "MAT1 OBS\nMEAN DEVIATION (MD) PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND CV LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND CV LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_cv.x.range, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_cv.y.range, 2), collapse = " , "),
+ "\nRED LINE: POISSON DISTRIB\n"
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot, tempo.data.pois),
+ x = list("MEAN", "x.pois"),
+ y = list("CV", "y.cv.pois"),
+ color = list(grey(0.40), "red"),
+ geom = list("geom_point", "geom_line"),
+ alpha = list(0.5, 1),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_cv.x.range,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_cv.y.range,
+ y.log = transfo,
+ y.lab = "CV",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_cv.coord.obs
+ # end mean / cv of the observed matrix
+
+ # cv selection using increasing windows to detect the average constant cv
+ tempo.cv.mean.mat <- mean.sd.cv.cor.mat1.obs[!(
+ mean.sd.cv.cor.mat1.obs$CV == 0 |
+ mean.sd.cv.cor.mat1.obs$MEAN == 0 |
+ is.na(mean.sd.cv.cor.mat1.obs$MEAN) |
+ is.na(mean.sd.cv.cor.mat1.obs$CV)
+ ),] # remove 0 and NA in mean and CV
+ sort.cv1 <- sort(tempo.cv.mean.mat$CV)
+ sort.mean <-
+ tempo.cv.mean.mat$MEAN[order(tempo.cv.mean.mat$CV, na.last = NA)] # means sorted like cv
+ # n.cv <- length(sort.cv1)
+ win.size.ini <- win.size
+ if (win.size >= length(sort.cv1)) {
+ tempo.warning <-
+ paste0(
+ "THE win.size PARAMETER SETTING (",
+ win.size,
+ ") IS OVER OR
+ EQUAL TO THE NUMBER OF NON NA DIAGONAL CV OF THE OBSERVED MATRIX 1 (",
+ length(sort.cv1),
+ ")\nTHE win.size PARAMETER HAS BEEN RESET TO VALUE: ",
+ length(sort.cv1) - 1
+ )
+ cat(paste0("\nWARNING: ", tempo.warning, "\n"))
+ warning.message <-
+ paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+ win.size <- length(sort.cv1) - 1
+ fun_report(data = tempo.warning,
+ output = log.file,
+ path = "./")
+ }
+ if (win.size < 2) {
+ tempo.cat <-
+ paste0(
+ "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\nwin.size IS LESS THAN 2.
+ NO BEST CV CAN BE COMPUTED\n\n========\n\n"
+ )
+ stop(tempo.cat)
+ }
+ if (win.size < length(sort.cv1)) {
+ cv.win.mean <-
+ vector("numeric", win.size - 1) # mean cv in the increasing window of the sorted cv
+ cv.win.mean[] <- NA
+ cv.win.sd <-
+ vector("numeric", win.size - 1) # sd cv in the increasing window of the sorted cv
+ cv.win.sd[] <- NA
+ mean.win.median <-
+ vector("numeric", win.size - 1) # median in the increasing window of the sorted mean
+ mean.win.median[] <- NA
+ mean.win.mean <-
+ vector("numeric", win.size - 1) # for the cv selection: mean in the increasing window of the sorted mean
+ mean.win.mean[] <- NA
+ for (i0 in 2:win.size) {
+ # to take at least 2 values, to avoid a first NA
+ cv.win.mean[i0 - 1] <-
+ mean(sort.cv1[1:i0], na.rm = TRUE)
+ cv.win.sd[i0 - 1] <- sd(sort.cv1[1:i0], na.rm = TRUE)
+ mean.win.median[i0 - 1] <-
+ median(sort.mean[1:i0], na.rm = TRUE)
+ mean.win.mean[i0 - 1] <-
+ mean(sort.mean[1:i0], na.rm = TRUE)
+ }
+ if (any(is.na(cv.win.mean))) {
+ tempo.cat <-
+ paste0(
+ "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ cv.win.mean SHOULD NOT HAVE ANY NA\n\n========\n\n"
+ )
+ stop(tempo.cat)
+ }
+ }
+
+ if (any(is.na(cumsum(diff(
+ cv.win.sd / mean.win.mean
+ ))))) {
+ tempo.cat <-
+ paste0(
+ "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ NO NA SHOULD BE PRESENT IN cv.win.sd / mean.win.mean\n\n========\n\n"
+ )
+ cat(tempo.cat)
+ print(cv.win.sd / mean.win.mean)
+ stop()
+ } else{
+ cv.select.nb <- which.min(cumsum(diff(cv.win.sd / mean.win.mean)))
+ }
+ i0 <- 1
+ while (median(sort.cv1[i0:cv.select.nb], na.rm = TRUE) == 0 |
+ median(sort.mean[i0:cv.select.nb], na.rm = TRUE) == 0) {
+ # loop to avoid to take zero values in sort.cv1 and sort.mean
+ i0 <- i0 + 1
+ cv.select.nb <- cv.select.nb + 1
+ }
+ cv.select.mat1.obs <-
+ median(sort.cv1[i0:cv.select.nb], na.rm = TRUE) # cv selected is the median of the xxx first cv
+ mean.select.mat1.obs <-
+ median(sort.mean[i0:cv.select.nb], na.rm = TRUE)
+
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.title <- paste0(
+ "MAT1 OBS\nSLIDING CV COMPUTATION\n
+ BLUE DOTS: MEAN+/-SD OF CV IN INCREASING WINDOWS OF CV VALUES\n
+ GREEN LINE: SELECTED CV VALUE IS ",
+ round(cv.select.mat1.obs, 2),
+ ", BASED ON MEDIAN OF ",
+ cv.select.nb,
+ " BLUE DOTS\nRED LINE: POISSON DISTRIB\n",
+ if (transfo == "log2") {
+ "LOG2(x) "
+ } else if (transfo == "log10") {
+ "LOG10(x) "
+ } else{
+ "NO "
+ },
+ "TRANSFORMATION"
+ )
+
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot, tempo.data.pois),
+ x = list("MEAN", "x.pois"),
+ y = list("CV", "y.cv.pois"),
+ color = list(grey(0.40), "red"),
+ geom = list("geom_point", "geom_line"),
+ alpha = list(0.5, 1),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_cv.x.range,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_cv.y.range,
+ y.log = transfo,
+ y.lab = "CV",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0,
+ add = paste0(
+ '+ ggplot2::geom_point(data = data.frame(x = get(transfo)(mean.win.median),
+ y = get(transfo)(cv.win.mean)), ggplot2::aes(x = x, y = y), color = "blue",
+ size = dot.size, alpha = 0.3) + ggplot2::geom_segment(data = data.frame(x = get(transfo)(mean.win.median),
+ xend = get(transfo)(mean.win.median), y = get(transfo)(cv.win.mean - cv.win.sd),
+ yend = get(transfo)(cv.win.mean + cv.win.sd)), ggplot2::aes(x = x, y = y, xend = xend, yend = yend),
+ color = "blue", alpha = 0.3) + ggplot2::geom_hline(data = data.frame(y = get(transfo)(cv.select.mat1.obs)),
+ ggplot2::aes(yintercept = y), color = "green", size = line.size) + ggplot2::theme_classic(base_size = text.size)',
+ if (raster == TRUE) {
+ '+ ggplot2::theme(text = ggplot2::element_text(size = text.size),
+ plot.title = ggplot2::element_text(size = title.text.size), aspect.ratio = 1)'
+ } else{
+ '+ ggplot2::theme(text = ggplot2::element_text(size = text.size),
+ plot.title = ggplot2::element_text(size = title.text.size))'
+ }
+ )
+ )
+
+ # cv selection using increasing windows to detect the average constant cv
+ # END MATRIX 1
+
+
+ # MATRIX2
+ # heatmap: matrix checking
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ fun_gg_empty_graph(text = "OBSERVED MATRIX 2:\nCOLLECTION OF DIAGONAL PARAMETERS", text.size = 3)
+
+ tempo.data.plot <- mean.sd.cv.cor.mat2.obs
+ tempo.data.plot2 <-
+ data.frame(
+ MEAN = tempo.data.plot$MEAN,
+ MEAN.MINUS.SD = tempo.data.plot$MEAN - tempo.data.plot$SD,
+ MEAN.PLUS.SD = tempo.data.plot$MEAN + tempo.data.plot$SD
+ ) # created here to be before log transformation
+ if (transfo != "no") {
+ tempo.data.plot[, c("MEAN", "SD", "CV")] <-
+ get(transfo)(tempo.data.plot[, c("MEAN", "SD", "CV")]) # log(x + 1) only for heatmap
+ tempo.data.pois <-
+ data.frame(
+ x.pois = tempo.data.plot$MEAN,
+ y.sd.pois = tempo.data.plot$MEAN / 2,
+ y.cv.pois = get(transfo)(1) - tempo.data.plot$MEAN / 2
+ ) # because poisson distrib is mean = variance, thus sd = mean ^0.5, ie each mean as x is square rooted for y and then x.MEAN / 2 because log2(mean^0.5) = 0.5 * log2(mean). For cv, cv = sd/m -> log(cv) = log(sd/m) = log(m/m^0.5) = log(1/m^0.5) = log(1) - log(m^0.5) = log(1) - log(m)/2
+ } else{
+ tempo.data.pois <-
+ data.frame(
+ x.pois = tempo.data.plot$MEAN,
+ y.sd.pois = tempo.data.plot$MEAN ^ 0.5,
+ y.cv.pois = 1 / tempo.data.plot$MEAN ^
+ 0.5
+ )
+ }
+
+
+ # mean versus index plot
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ if (transfo != "no") {
+ tempo.data.plot2 <-
+ suppressWarnings(get(transfo)(tempo.data.plot2)) # log(x + 1) only for heatmap
+ if (any(is.na(tempo.data.plot2$MEAN.MINUS.SD))) {
+ tempo.data.plot2$MEAN.MINUS.SD[is.na(tempo.data.plot2$MEAN.MINUS.SD)] <-
+ tempo.data.plot2$MEAN[is.na(tempo.data.plot2$MEAN.MINUS.SD)]
+ }
+ }
+ tempo.data.plot2 <-
+ data.frame(COLUMN_NB = 1:nrow(tempo.data.plot2), tempo.data.plot2)
+ tempo.title <-
+ paste0(
+ "MAT2 OBS\nMEAN PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x)\n
+ ABSENT SD IF LOG2(M - SD) < 0 "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x)\n
+ ABSENT SD IF LOG10(M - SD) < 0 "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nDIAGONAL NB FROM MAIN TO CORNER\nX SCALE RANGE: ",
+ paste(range(
+ 1:nrow(tempo.data.plot2),
+ na.rm = TRUE,
+ finite = TRUE
+ ),
+ collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.x.range, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot2),
+ x = list("COLUMN_NB"),
+ y = list("MEAN"),
+ color = list(grey(0.40)),
+ geom = list("geom_point"),
+ alpha = list(0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.log = "no",
+ x.lab = "DIAGONAL NB",
+ x.tick.nb = 8,
+ y.log = transfo,
+ y.lab = "MEAN",
+ y.lim = m_sd.x.range,
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ add = paste0(
+ '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot2$COLUMN_NB,
+ xend = tempo.data.plot2$COLUMN_NB, y = tempo.data.plot2$MEAN.MINUS.SD, yend = tempo.data.plot2$MEAN.PLUS.SD),
+ ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
+ )
+ )
+ # end mean versus index plot
+ # Mean Deviation (MD) plot of the observed matrix
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.title <- paste0(
+ "MAT2 OBS\nMEAN DEVIATION (MD) PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_sd.x.range, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.y.range, 2), collapse = " , "),
+ "\nRED LINE: POISSON DISTRIB\n"
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot, tempo.data.pois),
+ x = list("MEAN", "x.pois"),
+ y = list("SD", "y.sd.pois"),
+ color = list(grey(0.40), "red"),
+ geom = list("geom_point", "geom_line"),
+ alpha = list(0.5, 1),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_sd.x.range,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_sd.y.range,
+ y.log = transfo,
+ y.lab = "SD",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
+ # end Mean Deviation (MD) plot of the observed matrix
+
+ # mean / cor of the observed matrix
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.title <-
+ paste0(
+ "MAT2 OBS\nMEAN VERSUS MAT1 OBS / MAT2 OBS SPEARMAN CORRELATION\n",
+ if (transfo == "log2") {
+ "MEAN LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_cor.x.range, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_cor.y.range, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = tempo.data.plot,
+ x = "MEAN",
+ y = "COR",
+ color = grey(0.40),
+ geom = "geom_point",
+ alpha = 0.5,
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_cor.x.range,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_cor.y.range,
+ y.log = "no",
+ y.lab = "CORRELATION",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
+ # end mean / cor of the observed matrix
+
+ # mean / cv of the observed matrix
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.title <- paste0(
+ "MAT2 OBS\nMEAN DEVIATION (MD) PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND CV LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND CV LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_cv.x.range, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_cv.y.range, 2), collapse = " , "),
+ "\nRED LINE: POISSON DISTRIB\n"
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot, tempo.data.pois),
+ x = list("MEAN", "x.pois"),
+ y = list("CV", "y.cv.pois"),
+ color = list(grey(0.40), "red"),
+ geom = list("geom_point", "geom_line"),
+ alpha = list(0.5, 1),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_cv.x.range,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_cv.y.range,
+ y.log = transfo,
+ y.lab = "CV",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_cv.coord.obs
+ # end mean / cv of the observed matrix
+
+ # cv selection using increasing windows to detect the average constant cv
+ tempo.cv.mean.mat <- mean.sd.cv.cor.mat2.obs[!(
+ mean.sd.cv.cor.mat2.obs$CV == 0 |
+ mean.sd.cv.cor.mat2.obs$MEAN == 0 |
+ is.na(mean.sd.cv.cor.mat2.obs$MEAN) |
+ is.na(mean.sd.cv.cor.mat2.obs$CV)
+ ),] # remove 0 and NA in mean and CV
+ sort.cv2 <- sort(tempo.cv.mean.mat$CV)
+ sort.mean <-
+ tempo.cv.mean.mat$MEAN[order(tempo.cv.mean.mat$CV, na.last = NA)] # means sorted like cv
+ win.size <-
+ win.size.ini # in case modified during first MAT1 analysis
+ if (win.size >= length(sort.cv2)) {
+ tempo.warning <-
+ paste0(
+ "THE win.size PARAMETER SETTING (",
+ win.size,
+ ")
+ IS OVER OR EQUAL TO THE NUMBER OF NON NA DIAGONAL CV OF THE OBSERVED MATRIX 2 (",
+ length(sort.cv2),
+ ")\nTHE win.size PARAMETER HAS BEEN RESET TO VALUE: ",
+ length(sort.cv2) - 1
+ )
+ cat(paste0("\nWARNING: ", tempo.warning, "\n"))
+ warning.message <-
+ paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+ win.size <- length(sort.cv2) - 1
+ fun_report(data = tempo.warning,
+ output = log.file,
+ path = "./")
+ }
+ if (win.size < 2) {
+ tempo.cat <-
+ paste0(
+ "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ win.size IS LESS THAN 2. NO BEST CV CAN BE COMPUTED\n\n========\n\n"
+ )
+ stop(tempo.cat)
+ }
+
+ if (win.size < length(sort.cv2)) {
+ cv.win.mean <-
+ vector("numeric", win.size - 1) # mean cv in the increasing window of the sorted cv
+ cv.win.mean[] <- NA
+ cv.win.sd <-
+ vector("numeric", win.size - 1) # sd cv in the increasing window of the sorted cv
+ cv.win.sd[] <- NA
+ mean.win.median <-
+ vector("numeric", win.size - 1) # median in the increasing window of the sorted mean
+ mean.win.median[] <- NA
+ mean.win.mean <-
+ vector("numeric", win.size - 1) # for the cv selection: mean in the increasing window of the sorted mean
+ mean.win.mean[] <- NA
+ for (i0 in 2:win.size) {
+ # to take at least 2 values, to avoid a first NA
+ cv.win.mean[i0 - 1] <-
+ mean(sort.cv2[1:i0], na.rm = TRUE)
+ cv.win.sd[i0 - 1] <- sd(sort.cv2[1:i0], na.rm = TRUE)
+ mean.win.median[i0 - 1] <-
+ median(sort.mean[1:i0], na.rm = TRUE)
+ mean.win.mean[i0 - 1] <-
+ mean(sort.mean[1:i0], na.rm = TRUE)
+ }
+ if (any(is.na(cv.win.mean))) {
+ tempo.cat <-
+ paste0(
+ "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\ncv.win.mean SHOULD NOT HAVE ANY NA
+ \n\n========\n\n"
+ )
+ cat(tempo.cat)
+ stop()
+ }
+ }
+
+ if (any(is.na(cumsum(diff(
+ cv.win.sd / mean.win.mean
+ ))))) {
+ tempo.cat <-
+ paste0(
+ "\n\n========\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ NO NA SHOULD BE PRESENT IN cv.win.sd / mean.win.mean\n\n========\n\n"
+ )
+ cat(tempo.cat)
+ print(cv.win.sd / mean.win.mean)
+ stop()
+ } else{
+ cv.select.nb <- which.min(cumsum(diff(cv.win.sd / mean.win.mean)))
+ }
+
+ i0 <- 1
+ while (median(sort.cv2[i0:cv.select.nb], na.rm = TRUE) == 0 |
+ median(sort.mean[i0:cv.select.nb], na.rm = TRUE) == 0) {
+ # loop to avoid to take zero values in sort.cv2 and sort.mean
+ i0 <- i0 + 1
+ cv.select.nb <- cv.select.nb + 1
+ }
+ cv.select.mat2.obs <-
+ median(sort.cv2[i0:cv.select.nb], na.rm = TRUE) # cv selected is the median of the xxx first cv
+ mean.select.mat2.obs <-
+ median(sort.mean[i0:cv.select.nb], na.rm = TRUE)
+
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+
+ tempo.title <- paste0(
+ "MAT2 OBS\nSLIDING CV COMPUTATION\n
+ BLUE DOTS: MEAN+/-SD OF CV IN INCREASING WINDOWS OF CV VALUES\n
+ GREEN LINE: SELECTED CV VALUE IS ",
+ round(cv.select.mat2.obs, 2),
+ ", BASED ON MEDIAN OF ",
+ cv.select.nb,
+ " BLUE DOTS\nRED LINE: POISSON DISTRIB\n",
+ if (transfo == "log2") {
+ "LOG2(x) "
+ } else if (transfo == "log10") {
+ "LOG10(x) "
+ } else{
+ "NO "
+ },
+ "TRANSFORMATION"
+ )
+
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot, tempo.data.pois),
+ x = list("MEAN", "x.pois"),
+ y = list("CV", "y.cv.pois"),
+ color = list(grey(0.40), "red"),
+ geom = list("geom_point", "geom_line"),
+ alpha = list(0.5, 1),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_cv.x.range,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_cv.y.range,
+ y.log = transfo,
+ y.lab = "CV",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0,
+ add = paste0(
+ '+ ggplot2::geom_point(data = data.frame(x = get(transfo)(mean.win.median),
+ y = get(transfo)(cv.win.mean)), ggplot2::aes(x = x, y = y), color = "blue", size = dot.size, alpha = 0.3) +
+ ggplot2::geom_segment(data = data.frame(x = get(transfo)(mean.win.median), xend = get(transfo)(mean.win.median),
+ y = get(transfo)(cv.win.mean - cv.win.sd), yend = get(transfo)(cv.win.mean + cv.win.sd)),
+ ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = "blue", alpha = 0.3) +
+ ggplot2::geom_hline(data = data.frame(y = get(transfo)(cv.select.mat2.obs)),
+ ggplot2::aes(yintercept = y), color = "green", size = line.size) + ggplot2::theme_classic(base_size = text.size)',
+ if (raster == TRUE) {
+ '+ ggplot2::theme(text = ggplot2::element_text(size = text.size),
+ plot.title = ggplot2::element_text(size = title.text.size), aspect.ratio = 1)'
+ } else{
+ '+ ggplot2::theme(text = ggplot2::element_text(size = text.size),
+ plot.title = ggplot2::element_text(size = title.text.size))'
+ }
+ )
+ )
+ # cv selection using increasing windows to detect the average constant cv
+ # END MATRIX 2
+
+
+ ################ End plot verification
+ print("end plot verif")
+
+ ################ Theoretical matrices
+
+
+ # MATRIX 1
+ cat("\nTHEORETICAL MATRIX DESIGN\n")
+ fun_report(
+ data = "\n\n################################ THEORETICAL MATRIX DESIGN",
+ path = "./",
+ output = log.file,
+ sep = 4
+ )
+ n1 <- nrow(mean.sd.cv.cor.mat1.obs)
+ mu1 <-
+ sort(mean.sd.cv.cor.mat1.obs$MEAN,
+ decreasing = TRUE,
+ na.last = TRUE) # need the ordering to work on correlation (see below), decreasing = TRUE to have the first column in theo1 as the main diagonal. For non sorting: mu1 <- mean.sd.cv.cor.mat1.obs$MEAN # no sorting anymore
+
+ if ( ! is.null(path.cv.rho)) {
+ source(path.cv.rho) #
+ tempo.cat <-
+ paste0(
+ "BEWARE: THE SAVED FILE:\n",
+ "cv1_cv2_rho1_rho2_backup.RData",
+ "\nIS MAD OF VALUES COMING FROM THE DOWNLOAD OF:\n",
+ path.cv.rho
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ } else{
+ rho1 <-
+ mean.sd.cv.cor.mat1.obs$COR[order(mean.sd.cv.cor.mat1.obs$MEAN,
+ decreasing = TRUE,
+ na.last = TRUE)] # for non sorting: rho1 <- mean.sd.cv.cor.mat1.obs$COR
+ cv1 <- cv.select.mat1.obs # see above
+ }
+ # mean correction before subsampling
+ # Subsampling is necessary because we cannot have any mean of a diagonal less than t = 1/cv1^2.
+ # Thus, we have to multiply all the value to increase diagonal means, then use the BN law, and then subsample to go back to the initial means
+ # see Negative binomial law, CV m relationship and subsampling.docx do understand the origin of these formula (equation numbers)
+ t1 <- 1 / cv1 ^ 2 # equation (1)
+ p1 <-
+ exp(-t1 / mu1) # equation (8). Related to equation (9). In these equations, m cannot go below mt, but we do not care here for the correction
+ r1 <- t1 / p1 # equation (7)
+ # Beware: one sub.factor per diagonal: meaning that we do not apply the same up raising and dowsampling coeff for all the diag
+ sub.factor1 = t1 / (mu1 * (1 - p1)) # equation (9), with mt = m1 (obs) and m = mean.nb1 (theo mean of NB). equation (9) / m1 -> t1 / ( mu1 * ( 1 - exp(-t1/mu1))) and sub.factor1 = m / mt, ie, sub.factor1 = mean.nb1 / m1. Thus, for the down sampling, to go back to m1, we will have to divide by sub.factor1
+ mean.nb1 <- p1 * r1 / (1 - p1) # equation (2), just for graphs
+ sd.nb1 <-
+ (p1 * r1 / (1 - p1) ^ 2) ^ 0.5 # equation (3), just for graphs
+ # end mean correction before subsampling
+ # because in two contact matrix, the values in the largest diagonal, where the mean is the biggest, are very correlated, and because this correlation decreases in other diagonales when taking distance from the largest diag, we have to sort the generated values by the neg binom distrib, more or less depending on the mean used.
+
+ if (is.null(n.row)) {
+ n.row <- n1
+ }
+ mat1.ini <-
+ matrix(NA, nrow = n.row, ncol = n1) # each column of mat1.ini is filled with random values according to neg binom distrib, with mean increasing for each column of mat1.ini
+ # solving the fact that when p is less than 1e-16, 1-p is rounded by R to 1, which results in prob = 1 in the rnbinom() function and only 0 returned
+ p1.rd <- p1
+ r1.rd <- r1
+ cutoff.pb <- 1e-13 # cut-off at which p is ok
+ if (any(p1.rd < cutoff.pb & p1.rd > 0)) {
+ cutoff.pos1 <- which.max(p1.rd < cutoff.pb & p1.rd > 0) - 1
+ if (cutoff.pos1 == 0) {
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ CODE CANNOT WORK IF cutoff.pos1 IS EQUAL TO ZERO\n\n============\n\n"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ stop("\n", tempo.cat, "\n")
+ } else{
+ r1.rd[p1.rd < cutoff.pb &
+ p1.rd > 0] <- r1.rd[cutoff.pos1] # beware: must be before p2.rd
+ p1.rd[p1.rd < cutoff.pb &
+ p1.rd > 0] <- p1.rd[cutoff.pos1]
+ }
+ }
+
+ # end solving the fact that when p is less than 1e-16, 1-p is rounded by R to 1, which results in prob = 1 in the rnbinom() function and only 0 returned
+ for (i1 in 1:length(mu1)) {
+ if (mu1[i1] != 0) {
+ # otherwise cannot compute rnbinom() because p Infinite
+ mat1.ini[, i1] <-
+ rnbinom(n = n.row,
+ size = r1.rd[i1],
+ prob = 1 - p1.rd[i1]) # because prob is the proba of success in R, while it is the proba of failure in the equation
+ } else{
+ mean.nb1[i1] <- 0 # just for graphs
+ sd.nb1[i1] <- NA # just for graphs
+ mat1.ini[, i1] <- 0
+ tempo.cat <-
+ paste0(
+ "BEWARE: IN LOOP ",
+ i1,
+ ", mu1 HAS A ZERO VALUE: NO NEG BINOM LAW USED ->
+ MATRIX COLUMN FILLED WITH ZERO"
+ )
+ # cat(paste0("\n", tempo.cat, "\n"))
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ }
+ }
+
+ cv.nb1 <- sd.nb1 / mean.nb1 # just for graphs
+ options.ini <- options()$digits
+ options(digits = 22)
+ if (any((cv1 ^ 2 < 1 / mean.nb1[!(is.na(mean.nb1) |
+ !is.finite(1 / mean.nb1))]) | (sapply(FUN = all.equal, 1 / mean.nb1[!(is.na(mean.nb1) |
+ !is.finite(1 / mean.nb1))], cv1 ^ 2) == TRUE))) {
+ # because we need sigma^2 > mean.nb1 for neg binom (otherwise, we have to use poisson)
+ # Then sigma^2 / mean.nb1^2 < mean.nb1 / mean.nb1^2 -> cv1^2 > 1/mean.nb1
+ tempo.cat <-
+ paste0(
+ "\n\n========\n\nPROBLEM: cv1 PARAMETER MUST BE SUCH THAT cv1^2 > 1/mean.nb1\ncv1 : ",
+ cv1,
+ "\ncv1^2 : ",
+ cv1 ^ 2,
+ "\nmean.nb1 VALUES DO NOT RESPECTING THE FORMULA (ZERO NOT CONSIDERED): ",
+ paste(mean.nb1[!(is.na(mean.nb1) |
+ !is.finite(1 / mean.nb1))][cv1 ^ 2 <= 1 / mean.nb1[!(is.na(mean.nb1) |
+ !is.finite(1 / mean.nb1))]], collapse = " "),
+ "\n1/mean.nb1: ",
+ paste(1 / mean.nb1[!(is.na(mean.nb1) |
+ !is.finite(1 / mean.nb1))][cv1 ^ 2 <= 1 / mean.nb1[!(is.na(mean.nb1) |
+ !is.finite(1 / mean.nb1))]], collapse = " "),
+ "\n\n========\n\n"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ }
+ options(digits = options.ini)
+
+
+ # MATRIX 2
+ # see matrix1 for the explanaition
+ n2 <- nrow(mean.sd.cv.cor.mat2.obs)
+ if (!identical(n1, n2)) {
+ # important
+ tempo.cat <-
+ paste0(
+ "\n\n================\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ THE TWO ROW NUMBERS OF OBS MAT1 AND MAT2 ARE DIFFERENT: ",
+ paste(c(n1, n2), collapse = " "),
+ "\n\n================\n\n"
+ ) # message for developers
+ stop(tempo.cat)
+ }
+ mu2 <-
+ sort(mean.sd.cv.cor.mat2.obs$MEAN,
+ decreasing = TRUE,
+ na.last = TRUE) # need the ordering to work on correlation (see below). For non sorting: mu2 <- mean.sd.cv.cor.mat2.obs$MEAN # no sorting anymore
+ if ( ! is.null(path.cv.rho)) {
+
+ } else{
+ rho2 <-
+ mean.sd.cv.cor.mat2.obs$COR[order(mean.sd.cv.cor.mat2.obs$MEAN,
+ decreasing = TRUE,
+ na.last = TRUE)] # rho2 <- mean.sd.cv.cor.mat2.obs$COR
+ cv2 <- cv.select.mat2.obs # see above
+ }
+
+ if (!identical(sort(rho1), sort(rho2))) {
+ # important because rho1 will be modified, and rho2 kept as the initial correlation between obs mat1 and mat2
+ tempo.cat <-
+ paste0(
+ "\n\n================\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ THE TWO CORRELATIONS rho1 AND rho2 ARE NOT IDENTICAL\n\n================\n\n"
+ ) # message for developers
+ stop(tempo.cat)
+ }
+ save(list = c("cv1", "rho1", "cv2", "rho2"),
+ file = "cv1_cv2_rho1_rho2_backup.RData")
+ tempo.cat <-
+ paste0(
+ "CORRELATIONS AND SELECTED COEFFICIENTS OF VARIATION SAVED IN: ",
+ "cv1_cv2_rho1_rho2_backup.RData"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+
+ t2 <- 1 / cv2 ^ 2 # equation (1)
+ p2 <-
+ exp(-t2 / mu2) # equation (8). Related to equation (9). In these equations, m cannot go below mt, but we do not care here for the correction
+ r2 <- t2 / p2 # equation (7)
+ sub.factor2 = t2 / (mu2 * (1 - p2)) # equation (9), with mt = m2 (obs) and m = mean.nb2 (theo mean of NB). equation (9) / m2 -> t2 / ( mu2 * ( 1 - exp(-t2/mu2))) and sub.factor2 = m / mt, ie, sub.factor2 = mean.nb2 / m2. Thus, for the down sampling, to go back to m2, we will have to divide by sub.factor2
+ mean.nb2 <- p2 * r2 / (1 - p2) # equation (2), just for graphs
+ sd.nb2 <-
+ (p2 * r2 / (1 - p2) ^ 2) ^ 0.5 # equation (3), just for graphs
+ mat2.ini <-
+ matrix(NA, nrow = n.row, ncol = n2) # each column of mat2.ini is filled with random values according to neg binom distrib, with mean increasing for each column of mat2.ini. n.row defined above
+ # solving the fact that when p is less than 1e-16, 1-p is rounded by R to 1, which results in prob = 1 in the rnbinom() function and only 0 returned
+ p2.rd <- p2
+ r2.rd <- r2
+ # cutoff.pb # defined above for Mat1
+ if (any(p2.rd < cutoff.pb & p2.rd > 0)) {
+ cutoff.pos2 <- which.max(p2.rd < cutoff.pb & p2.rd > 0) - 1
+ if (cutoff.pos2 == 0) {
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ CODE CANNOT WORK IF cutoff.pos2 IS EQUAL TO ZERO\n\n============\n\n"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ stop("\n", tempo.cat, "\n")
+ } else{
+ r2.rd[p2.rd < cutoff.pb &
+ p2.rd > 0] <- r2.rd[cutoff.pos2] # beware: must be before p2.rd
+ p2.rd[p2.rd < cutoff.pb &
+ p2.rd > 0] <- p2.rd[cutoff.pos2]
+ }
+ }
+
+ # end solving the fact that when p is less than 1e-16, 1-p is rounded by R to 1, which results in prob = 1 in the rnbinom() function and only 0 returned
+ for (i1 in 1:length(mu2)) {
+ if (mu2[i1] != 0) {
+ # otherwise cannot compute rnbinom() because p Infinite
+ mat2.ini[, i1] <-
+ rnbinom(n = n.row,
+ size = r2.rd[i1],
+ prob = 1 - p2.rd[i1]) # because prob is the proba of success in R, while it is the proba of failure in the equation
+ } else{
+ mean.nb2[i1] <- 0
+ sd.nb2[i1] <- NA
+ mat2.ini[, i1] <- 0
+ tempo.cat <-
+ paste0(
+ "BEWARE: IN LOOP ",
+ i1,
+ ", mu2 HAS A ZERO VALUE: NO NEG BINOM LAW USED ->
+ MATRIX COLUMN FILLED WITH ZERO"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ }
+ }
+ cv.nb2 <- sd.nb2 / mean.nb2
+ options.ini <- options()$digits
+ options(digits = 22)
+ if (any((cv2 ^ 2 < 1 / mean.nb2[!(is.na(mean.nb2) |
+ !is.finite(1 / mean.nb2))]) |
+ (sapply(FUN = all.equal, 1 / mean.nb2[!(is.na(mean.nb2) |
+ !is.finite(1 / mean.nb2))], cv2 ^ 2) == TRUE))) {
+ # because we need sigma^2 > mean.nb2 for neg binom (otherwise, we have to use poisson)
+ # Then sigma^2 / mean.nb2^2 > mean.nb2 / mean.nb2^2 -> cv2^2 > 1/mean.nb2
+ tempo.cat <-
+ paste0(
+ "\n\n========\n\nPROBLEM: cv2 PARAMETER MUST BE SUCH THAT cv2^2 > 1/mean.nb2\ncv2 : ",
+ cv2,
+ "\ncv2^2 : ",
+ cv2 ^ 2,
+ "\nmean.nb2 VALUES DO NOT RESPECTING THE FORMULA (ZERO NOT CONSIDERED): ",
+ paste(mean.nb2[!(is.na(mean.nb2) |
+ !is.finite(1 / mean.nb2))][cv2 ^ 2 <= 1 / mean.nb2[!(is.na(mean.nb2) |
+ !is.finite(1 / mean.nb2))]], collapse = " "),
+ "\n1/mean.nb2: ",
+ paste(1 / mean.nb2[!(is.na(mean.nb2) |
+ !is.finite(1 / mean.nb2))][cv2 ^ 2 <= 1 / mean.nb2[!(is.na(mean.nb2) |
+ !is.finite(1 / mean.nb2))]], collapse = " "),
+ "\n\n========\n\n"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ }
+ options(digits = options.ini)
+ print("end theorical matrices")
+
+ ################ End Theoretical matrices
+
+
+ ################ plot verification
+
+ print("plot verif")
+ # homogeneous scale
+ # heatmap range
+ loop.mat.names <- c("mat1.ini", "mat2.ini")
+ s.both.heatmap.range.pre <- NULL
+ for (i0 in 1:length(loop.mat.names)) {
+ # data transformtation
+ tempo.data.plot <-
+ get(loop.mat.names[i0]) / adj.mean.fun(x_3fun = get(loop.mat.names[i0]),
+ text_3fun = "JUST AFTER CREATION OF THEO, HEATMAP NORMALIZATION ACCORDING TO THE WEIGHTED DIAGONAL MEAN") # weighted diag for theo only
+ if (transfo != "no") {
+ tempo.data.plot <- get(transfo)(tempo.data.plot + 1) # log transfo
+ }
+ # end data transformtation
+ s.both.heatmap.range.pre <-
+ range(
+ c(
+ s.obs.heatmap.range.pre,
+ s.both.heatmap.range.pre,
+ tempo.data.plot
+ ),
+ na.rm = TRUE,
+ finite = TRUE
+ )
+ }
+
+ # end heatmap range
+ # sd homogeneous scale
+ tempo1 <-
+ data.frame(
+ MEAN = apply(
+ X = mat1.ini,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ),
+ SD = apply(
+ mat1.ini,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ )
+ )
+ tempo2 <-
+ data.frame(
+ MEAN = apply(
+ X = mat2.ini,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ),
+ SD = apply(
+ mat2.ini,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ )
+ )
+ tempo.range <-
+ fun_gg_scatter(
+ data1 = list(L1 = if (transfo != "no") {
+ get(transfo)(tempo1)
+ } else{
+ tempo1
+ },
+ L2 = if (transfo != "no") {
+ get(transfo)(tempo2)
+ } else{
+ tempo2
+ }),
+ x = list(L1 = "MEAN", L2 = "MEAN"),
+ y = list(L1 = "SD", L2 = "SD"),
+ geom = list("geom_point", "geom_point"),
+ alpha = list(0.5, 0.5),
+ x.log = transfo,
+ y.log = transfo,
+ plot = FALSE,
+ return = TRUE
+ )
+ m_sd.x.range2 <-
+ range(c(m_sd.x.range, tempo.range$axes$x.range),
+ na.rm = TRUE,
+ finite = TRUE)
+ m_sd.y.range2 <-
+ range(c(m_sd.y.range, tempo.range$axes$y.range),
+ na.rm = TRUE,
+ finite = TRUE)
+ # end sd homogeneous scale
+ # cv homogeneous scale
+ tempo1 <- tempo1$SD / tempo1$MEAN
+ tempo2 <- tempo2$SD / tempo2$MEAN
+ m_cv.x.range2 <-
+ range(c(m_cv.x.range, tempo1, tempo2),
+ na.rm = TRUE,
+ finite = TRUE)
+ m_cv.y.range2 <-
+ range(c(m_cv.y.range, tempo1, tempo2),
+ na.rm = TRUE,
+ finite = TRUE)
+ # cor homogeneous scale
+ m_cor.x.range2 <-
+ range(c(m_cor.x.range, m_cv.x.range2),
+ na.rm = TRUE,
+ finite = TRUE) # because same x-axis
+ m_cor.y.range2 <- m_cor.y.range # because same x-axis
+ # end cor homogeneous scale
+ # end sd homogeneous scale
+
+ # MATRIX 1
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ fun_gg_empty_graph(text = "THEORETICAL MATRIX 1 DESIGN", text.size = 3)
+ # heatmap
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.title <-
+ paste0(
+ "MAT1 THEO\nEACH COLUMN REPRESENTS A DIAGONAL OF MAT1 OBS (MAIN DIAG FULL OF ZERO INCLUDED)\n",
+ if (transfo == "log2") {
+ "LOG2(x + 1) "
+ } else if (transfo == "log10") {
+ "LOG10(x + 1) "
+ } else{
+ "NO "
+ },
+ "TRANSFORMATION\nSCALE RANGE: ",
+ paste(fun_round(s.both.heatmap.range.pre, 2),
+ collapse = " , "),
+ "\nNORMALIZED DISPLAY (GLOBAL MEAN DIVISION)"
+ )
+ tempo.data.plot <-
+ mat1.ini / adj.mean.fun(
+ x_3fun = mat1.ini,
+ text_3fun = "JUST AFTER CREATION,
+ THEO HEATMAP NORMALIZATION ACCORDING TO THE WEIGHTED DIAGONAL MEAN"
+ ) # was not here before. I tried that
+ if (transfo != "no") {
+ tempo.data.plot <- get(transfo)(tempo.data.plot + 1)
+ }
+ fun_gg_heatmap(
+ data1 = tempo.data.plot,
+ legend.name = "",
+ limit1 = s.both.heatmap.range.pre,
+ midpoint1 = mean(s.both.heatmap.range.pre, na.rm = TRUE),
+ title = tempo.title,
+ text.size = heatmap.text.size,
+ title.text.size = title.text.size
+ )
+ # end heatmap
+
+ # Mean Deviation (MD) plot
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ data.frame(
+ MEAN = apply(
+ X = mat1.ini,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ),
+ SD = apply(
+ mat1.ini,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ )
+ )
+ if (transfo != "no") {
+ tempo.data.plot <-
+ get(transfo)(tempo.data.plot) # log(x + 1) only for heatmap
+ tempo.data.pois <-
+ data.frame(
+ x.pois = tempo.data.plot$MEAN,
+ y.sd.pois = tempo.data.plot$MEAN / 2,
+ y.cv.pois = get(transfo)(1) - tempo.data.plot$MEAN / 2
+ ) # because poisson distrib is mean = variance, thus sd = mean ^0.5, ie each mean as x is square rooted for y and then x.MEAN / 2 because log2(mean^0.5) = 0.5 * log2(mean). For cv, cv = sd/m -> log(cv) = log(sd/m) = log(m/m^0.5) = log(1/m^0.5) = log(1) - log(m^0.5) = log(1) - log(m)/2
+ tempo.data.negbinom <-
+ data.frame(
+ x.green = get(transfo)(mean.nb1),
+ y.green = get(transfo)(cv.nb1 * mean.nb1)
+ ) # neg binomiale distrib
+ } else{
+ tempo.data.pois <-
+ data.frame(
+ x.pois = tempo.data.plot$MEAN,
+ y.sd.pois = tempo.data.plot$MEAN ^ 0.5,
+ y.cv.pois = 1 / tempo.data.plot$MEAN ^
+ 0.5
+ )
+ tempo.data.negbinom <-
+ data.frame(x.green = mean.nb1, y.green = cv.nb1 * mean.nb1) # neg binomiale distrib
+ }
+ tempo.title <- paste0(
+ "MAT1 THEO\nMEAN DEVIATION (MD) PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_sd.x.range2, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.y.range2, 2), collapse = " , "),
+ "\nRED LINE: POISSON DISTRIB\nGREEN LINE: NEG BINOM DISTRIB"
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot, tempo.data.pois, tempo.data.negbinom),
+ x = list("MEAN", "x.pois", "x.green"),
+ y = list("SD", "y.sd.pois", "y.green"),
+ color = list(grey(0.40), "red", "green"),
+ geom = list("geom_point", "geom_line", "geom_line"),
+ alpha = list(0.5, 1, 1),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_sd.x.range2,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_sd.y.range2,
+ y.log = transfo,
+ y.lab = "SD",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
+ # end Mean Deviation (MD) plot of the observed matrix
+
+ # mean versus index plot
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ data.frame(
+ MEAN = apply(
+ X = mat1.ini,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ),
+ MEAN.MINUS.SD = apply(
+ X = mat1.ini,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ) - apply(
+ mat1.ini,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ ),
+ MEAN.PLUS.SD = apply(
+ X = mat1.ini,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ) + apply(
+ mat1.ini,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ )
+ )
+ if (transfo != "no") {
+ tempo.data.plot <-
+ suppressWarnings(get(transfo)(tempo.data.plot)) # log(x + 1) only for heatmap
+ if (any(is.na(tempo.data.plot$MEAN.MINUS.SD))) {
+ tempo.data.plot$MEAN.MINUS.SD[is.na(tempo.data.plot$MEAN.MINUS.SD)] <-
+ tempo.data.plot$MEAN[is.na(tempo.data.plot$MEAN.MINUS.SD)]
+ }
+ }
+ tempo.data.plot <-
+ data.frame(COLUMN_NB = 1:nrow(tempo.data.plot), tempo.data.plot)
+ tempo.title <- paste0(
+ "MAT1 THEO\nMEAN PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x)\nABSENT SD IF LOG2(M - SD) < 0 "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x)\nABSENT SD IF LOG10(M - SD) < 0 "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(range(
+ 1:nrow(tempo.data.plot),
+ na.rm = TRUE,
+ finite = TRUE
+ ), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.y.range2, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot),
+ x = list("COLUMN_NB"),
+ y = list("MEAN"),
+ color = list(grey(0.40)),
+ geom = list("geom_point"),
+ alpha = list(0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.log = "no",
+ x.lab = "COLUMN NB",
+ x.tick.nb = 8,
+ y.log = transfo,
+ y.lab = "MEAN",
+ y.lim = m_sd.y.range2,
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ add = paste0(
+ '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot$COLUMN_NB,
+ xend = tempo.data.plot$COLUMN_NB, y = tempo.data.plot$MEAN.MINUS.SD, yend = tempo.data.plot$MEAN.PLUS.SD),
+ ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
+ )
+ )
+ # end mean versus index plot
+
+
+ # MATRIX 2
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ fun_gg_empty_graph(text = "THEORETICAL MATRIX 2 DESIGN", text.size = 3)
+ # heatmap
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.title <-
+ paste0(
+ "MAT2 THEO\nEACH COLUMN REPRESENTS A DIAGONAL OF MAT2 OBS (MAIN DIAG FULL OF ZERO INCLUDED)\n",
+ if (transfo == "log2") {
+ "LOG2(x + 1) "
+ } else if (transfo == "log10") {
+ "LOG10(x + 1) "
+ } else{
+ "NO "
+ },
+ "TRANSFORMATION\nSCALE RANGE: ",
+ paste(fun_round(s.both.heatmap.range.pre, 2),
+ collapse = " , "),
+ "\nNORMALIZED DISPLAY (GLOBAL MEAN DIVISION)"
+ )
+ tempo.data.plot <-
+ mat2.ini / adj.mean.fun(
+ x_3fun = mat2.ini,
+ text_3fun = "JUST AFTER CREATION,
+ THEO HEATMAP NORMALIZATION ACCORDING TO THE WEIGHTED DIAGONAL MEAN"
+ ) # was not here before. I tried that
+ if (transfo != "no") {
+ tempo.data.plot <- get(transfo)(tempo.data.plot + 1)
+ }
+ fun_gg_heatmap(
+ data1 = tempo.data.plot,
+ legend.name = "",
+ limit1 = s.both.heatmap.range.pre,
+ midpoint1 = mean(s.both.heatmap.range.pre, na.rm = TRUE),
+ title = tempo.title,
+ text.size = heatmap.text.size,
+ title.text.size = title.text.size
+ )
+ # end heatmap
+
+ # Mean Deviation (MD) plot
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ data.frame(
+ MEAN = apply(
+ X = mat2.ini,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ),
+ SD = apply(
+ mat2.ini,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ )
+ )
+ if (transfo != "no") {
+ tempo.data.plot <-
+ get(transfo)(tempo.data.plot) # log(x + 1) only for heatmap
+ tempo.data.pois <-
+ data.frame(
+ x.pois = tempo.data.plot$MEAN,
+ y.sd.pois = tempo.data.plot$MEAN / 2,
+ y.cv.pois = get(transfo)(1) - tempo.data.plot$MEAN / 2
+ ) # because poisson distrib is mean = variance, thus sd = mean ^0.5, ie each mean as x is square rooted for y and then x.MEAN / 2 because log2(mean^0.5) = 0.5 * log2(mean). For cv, cv = sd/m -> log(cv) = log(sd/m) = log(m/m^0.5) = log(1/m^0.5) = log(1) - log(m^0.5) = log(1) - log(m)/2
+ tempo.data.negbinom <-
+ data.frame(
+ x.green = get(transfo)(mean.nb2),
+ y.green = get(transfo)(cv.nb2 * mean.nb2)
+ ) # neg binomiale distrib
+ } else{
+ tempo.data.pois <-
+ data.frame(
+ x.pois = tempo.data.plot$MEAN,
+ y.sd.pois = tempo.data.plot$MEAN ^ 0.5,
+ y.cv.pois = 1 / tempo.data.plot$MEAN ^
+ 0.5
+ )
+ tempo.data.negbinom <-
+ data.frame(x.green = mean.nb2, y.green = cv.nb2 * mean.nb2) # neg binomiale distrib
+ }
+ tempo.title <- paste0(
+ "MAT2 THEO\nMEAN DEVIATION (MD) PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_sd.x.range2, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.y.range2, 2), collapse = " , "),
+ "\nRED LINE: POISSON DISTRIB\nGREEN LINE: NEG BINOM DISTRIB"
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot, tempo.data.pois, tempo.data.negbinom),
+ x = list("MEAN", "x.pois", "x.green"),
+ y = list("SD", "y.sd.pois", "y.green"),
+ color = list(grey(0.40), "red", "green"),
+ geom = list("geom_point", "geom_line", "geom_line"),
+ alpha = list(0.5, 1, 1),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_sd.x.range2,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_sd.y.range2,
+ y.log = transfo,
+ y.lab = "SD",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
+ # end Mean Deviation (MD) plot
+
+ # mean versus index plot
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ data.frame(
+ MEAN = apply(
+ X = mat2.ini,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ),
+ MEAN.MINUS.SD = apply(
+ X = mat2.ini,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ) - apply(
+ mat2.ini,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ ),
+ MEAN.PLUS.SD = apply(
+ X = mat2.ini,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ) + apply(
+ mat2.ini,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ )
+ )
+ if (transfo != "no") {
+ tempo.data.plot <-
+ suppressWarnings(get(transfo)(tempo.data.plot)) # log(x + 1) only for heatmap
+ if (any(is.na(tempo.data.plot$MEAN.MINUS.SD))) {
+ tempo.data.plot$MEAN.MINUS.SD[is.na(tempo.data.plot$MEAN.MINUS.SD)] <-
+ tempo.data.plot$MEAN[is.na(tempo.data.plot$MEAN.MINUS.SD)]
+ }
+ }
+ tempo.data.plot <-
+ data.frame(COLUMN_NB = 1:nrow(tempo.data.plot), tempo.data.plot)
+ tempo.title <- paste0(
+ "MAT2 THEO\nMEAN PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x)\nABSENT SD IF LOG2(M - SD) < 0 "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x)\nABSENT SD IF LOG10(M - SD) < 0 "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(range(
+ 1:nrow(tempo.data.plot),
+ na.rm = TRUE,
+ finite = TRUE
+ ), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.y.range2, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot),
+ x = list("COLUMN_NB"),
+ y = list("MEAN"),
+ color = list(grey(0.40)),
+ geom = list("geom_point"),
+ alpha = list(0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.log = "no",
+ x.lab = "COLUMN NB",
+ x.tick.nb = 8,
+ y.log = transfo,
+ y.lab = "MEAN",
+ y.lim = m_sd.y.range2,
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ add = paste0(
+ '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot$COLUMN_NB,
+ xend = tempo.data.plot$COLUMN_NB, y = tempo.data.plot$MEAN.MINUS.SD, yend = tempo.data.plot$MEAN.PLUS.SD),
+ ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
+ )
+ )
+ # end mean versus index plot
+
+
+ ################ End plot verification
+ print("end plot verif")
+
+ ################ Taking correlation into account
+
+
+ cat("\nINCLUDING THE OBS MAT1 / MAT2 DIAGONAL CORRELATIONS INTO THEO MATRICES\n")
+ fun_report(
+ data = "\n\n################################ INCLUDING THE OBS MAT1 / MAT2 DIAGONAL CORRELATIONS INTO
+ THEO MATRICES",
+ path = "./",
+ output = log.file,
+ sep = 4
+ )
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ fun_gg_empty_graph(text = "INCLUDING THE OBS\nMAT1 / MAT2\nDIAGONAL CORRELATIONS\nINTO THEO MATRICES", text.size = 3)
+ # mean / cor of the observed matrix
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ data.frame(
+ MEAN = (
+ mean.sd.cv.cor.mat1.obs$MEAN + mean.sd.cv.cor.mat2.obs$MEAN
+ ) / 2,
+ COR = mean.sd.cv.cor.mat1.obs$COR
+ )
+ if (transfo != "no") {
+ tempo.data.plot[, "MEAN"] <-
+ get(transfo)(tempo.data.plot[, "MEAN"]) # log(x + 1) only for heatmap
+ }
+ print("mada daijoubu 1?")
+ tempo.title <-
+ paste0(
+ "(MAT1 OBS / MAT2 OBS) MEAN VERSUS (MAT1 OBS / MAT2 OBS) SPEARMAN CORRELATION\n",
+ if (transfo == "log2") {
+ "MEAN LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_cor.x.range2, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_cor.y.range2, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = tempo.data.plot,
+ x = "MEAN",
+ y = "COR",
+ color = grey(0.40),
+ geom = "geom_point",
+ alpha = 0.5,
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_cor.x.range2,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_cor.y.range2,
+ y.log = "no",
+ y.lab = "CORRELATION",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
+ # end mean / cor of the observed matrix
+ print("mada daijoubu 2?")
+ # mean / cor of the theoretical matrices
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ suppressWarnings(data.frame(
+ MEAN = (
+ apply(X = mat1.ini, MARGIN = 2, FUN = "mean") +
+ apply(X = mat2.ini, MARGIN = 2, FUN = "mean")
+ ) / 2,
+ COR = mapply(
+ FUN = "cor",
+ x = as.data.frame(mat1.ini),
+ y = as.data.frame(mat2.ini),
+ use = "pairwise.complete.obs",
+ method = "spearman",
+ SIMPLIFY = TRUE
+ )
+ ))
+ if (transfo != "no") {
+ tempo.data.plot[, "MEAN"] <-
+ get(transfo)(tempo.data.plot[, "MEAN"]) # log(x + 1) only for heatmap
+ }
+ tempo.title <-
+ paste0(
+ "(MAT1 THEO / MAT2 THEO) MEAN VERSUS (MAT1 THEO / MAT2 THEO) SPEARMAN CORRELATION\n",
+ if (transfo == "log2") {
+ "MEAN LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_cor.x.range2, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_cor.y.range2, 2), collapse = " , ")
+ )
+ print("mada daijoubu 3?")
+ fun_gg_scatter(
+ data1 = tempo.data.plot,
+ x = "MEAN",
+ y = "COR",
+ color = grey(0.40),
+ geom = "geom_point",
+ alpha = 0.5,
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_cor.x.range2,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_cor.y.range2,
+ y.log = "no",
+ y.lab = "CORRELATION",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
+ # Permutation of the mat1.ini values to have the mat1.obs correlation on the diagonales between mat1 and mat2
+ if ( ! is.null(path.theo1.theo2)) {
+ tempo.cat <-
+ paste0(
+ "BEWARE: mat1.ini, mat1.perm, mat2.ini and mat2.perm THERORETICAL MATRICES
+ USED HAVE BEEN DOWNLOADED FROM:\n",
+ path.theo1.theo2
+ )
+ cat(paste0("\n", tempo.cat, "\n"))
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ load(paste0(path.theo1.theo2))
+ } else{
+ if (any(is.na(mat1.ini))) {
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ SHOULD NOT HAVE ANY NA IN mat1.ini\n\n============\n\n"
+ )
+ cat(tempo.cat)
+ stop()
+ }
+ if (any(is.na(mat2.ini))) {
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ SHOULD NOT HAVE ANY NA IN mat2.ini\n\n============\n\n"
+ )
+ cat(tempo.cat)
+ stop()
+ }
+ print("mada daijoubu 4?")
+ mat1.perm <- mat1.ini
+ mat2.perm <- mat2.ini
+ # modifiying rho1
+ if (single.corr == "VALUE") {
+ # all the observed corr between mat1.obs and mat2.obs replaced by abs.corr.limit
+ rho1[!is.na(rho1)] <- abs.corr.limit
+ tempo.cat <-
+ paste0(
+ "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND mat2.obs REPLACED BY abs.corr.limit"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ } else if (single.corr == "MAX") {
+ rho1[!is.na(rho1)] <- max(rho1, na.rm = TRUE)
+ tempo.cat <-
+ paste0(
+ "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND
+ mat2.obs REPLACED BY MAX CORRELATION OF rho1: ",
+ max(rho1, na.rm = TRUE)
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ } else if (single.corr == "DEC1") {
+ rho1[!is.na(rho1)] <-
+ quantile(rho1,
+ probs = 0.1,
+ type = 7,
+ na.rm = TRUE)
+ tempo.cat <-
+ paste0(
+ "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND
+ mat2.obs REPLACED BY FIRST DECILE CORRELATION OF rho1: ",
+ quantile(
+ rho1,
+ probs = 0.1,
+ type = 7,
+ na.rm = TRUE
+ )
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ } else if (single.corr == "QUART1") {
+ rho1[!is.na(rho1)] <-
+ quantile(rho1,
+ probs = 0.25,
+ type = 7,
+ na.rm = TRUE)
+ tempo.cat <-
+ paste0(
+ "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND mat2.obs
+ REPLACED BY FIRST QUARTILE CORRELATION OF rho1: ",
+ quantile(
+ rho1,
+ probs = 0.25,
+ type = 7,
+ na.rm = TRUE
+ )
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ } else if (single.corr == "MED") {
+ rho1[!is.na(rho1)] <- median(rho1, na.rm = TRUE)
+ tempo.cat <-
+ paste0(
+ "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND mat2.obs
+ REPLACED BY THE MEDIAN CORRELATION OF rho1: ",
+ median(rho1, na.rm = TRUE)
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ } else if (single.corr == "MIN") {
+ rho1[!is.na(rho1)] <- min(rho1, na.rm = TRUE)
+ tempo.cat <-
+ paste0(
+ "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND mat2.obs
+ REPLACED BY MIN CORRELATION OF rho1: ",
+ min(rho1, na.rm = TRUE)
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ } else if (single.corr == "NO") {
+ tempo.cat <-
+ paste0(
+ "BEWARE: ALL THE OBSERVED CORRELATIONS BETWEEN mat1.obs AND mat2.obs
+ WILL BE USED FOR THE PERMUTATIONS, EXCEPT THOSE BELOW abs.corr.limit: ",
+ abs.corr.limit
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ } else{
+ tempo.cat <-
+ paste0("\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n\n============\n\n")
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ stop("\n", tempo.cat, "\n")
+ }
+ # end modifiying rho1
+ print("mada daijoubu 5?")
+ # sorting mat1 according to the rho1 values
+ for (i0 in 1:ncol(mat1.perm)) {
+ if (is.na(rho1[i0])) {
+ if (!all(mat1.perm[, i0] == 0)) {
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\nrho1 IS NA AND COLUMN ",
+ i0,
+ " OF mat1.perm IS NOT ZERO FOR LOOP:",
+ i0,
+ "\n\n============\n\n"
+ )
+ cat(tempo.cat)
+ stop()
+ }
+ } else if (any(is.na(mat1.perm[, i0]))) {
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\nSHOULD NOT HAVE NA IN COLUMN ",
+ i0,
+ " OF mat1.perm\n\n============\n\n"
+ )
+ cat(tempo.cat)
+ stop()
+ } else if (rho1[i0] < 0) {
+ mat1.perm[, i0] <-
+ sort(mat1.perm[, i0], decreasing = TRUE) # Beware: decreasing order here because we want a negative correlation with mat2[, i0] starting at -1, and increasing during permut
+ } else if (rho1[i0] >= 0) {
+ mat1.perm[, i0] <-
+ sort(mat1.perm[, i0], decreasing = FALSE) # Beware: increasing order here because we want a positive correlation with mat2[, i0] starting at 1, and decreasing during permut
+ } else{
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n\n============\n\n"
+ )
+ cat(tempo.cat)
+ stop()
+ }
+ }
+ # end sorting mat1 according to the rho1 values
+ # sorting mat2.perm systematically in the ascending order
+ for (i0 in 1:ncol(mat2.perm)) {
+ if (is.na(rho2[i0])) {
+ if (!all(mat2.perm[, i0] == 0)) {
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\nrho2 IS NA AND COLUMN ",
+ i0,
+ " OF mat2.perm IS NOT ZERO FOR LOOP:",
+ i0,
+ "\n\n============\n\n"
+ )
+ cat(tempo.cat)
+ stop()
+ }
+ } else if (any(is.na(mat2.perm[, i0]))) {
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\nSHOULD NOT HAVE NA IN COLUMN ",
+ i0,
+ " OF mat2.perm\n\n============\n\n"
+ )
+ cat(tempo.cat)
+ stop()
+ } else{
+ mat2.perm[, i0] <- sort(mat2.perm[, i0], decreasing = FALSE)
+ }
+ }
+ # end sorting mat2.perm systematically in the ascending order
+ # parallelization
+ perm.ini.date <-
+ Sys.time() # time of process begin, converted into seconds
+ perm.ini.time <-
+ as.numeric(perm.ini.date) # time of process begin, converted into seconds
+ tempo.cat <-
+ paste0(
+ "PERMUTATION RUN INITIATED ON THEO MATRICES (DIMENSION ",
+ paste(dim(mat1.perm), collapse = " x "),
+ ") AT: ",
+ perm.ini.date
+ )
+ cat(paste0("\n", tempo.cat, "\n"))
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ tempo.thread.nb = parallel::detectCores(all.tests = FALSE, logical = TRUE) # detect the number of threads
+ if (is.null(thread.nb)) {
+ thread.nb <- tempo.thread.nb - 1
+ } else if (tempo.thread.nb < thread.nb) {
+ thread.nb <- tempo.thread.nb
+ }
+ tempo.cat <- paste0("NUMBER OF THREADS USED: ", thread.nb)
+ cat(paste0("\n ", tempo.cat, "\n"))
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ # trick to correctly dispatch the amount of work per cpu
+ pos.rho1.decrease <-
+ order(rho1, decreasing = TRUE, na.last = NA) # remove the NA positions
+ tempo.list <-
+ vector("list", thread.nb) # will contain a good repartition of the higher corr per cpu
+ count <- 0
+ for (i0 in 1:length(pos.rho1.decrease)) {
+ count <- count + 1
+ tempo.list[[count]] <-
+ c(tempo.list[[count]], pos.rho1.decrease[i0])
+ if (count == thread.nb) {
+ count <- 0
+ }
+ }
+ tempo.list <- unlist(tempo.list)
+ print("mada daijoubu 6?")
+ # end trick to correctly dispatch the amount of work per cpu
+ Clust <-
+ parallel::makeCluster(thread.nb, outfile = "cor_parall_log.txt") # outfile to print or cat during parallelization (only possible in a file, outfile = "" do not work on windowsâ—‹)
+ tempo.cat <-
+ paste0("COLUMN NUMBER SPLIT FOR PARALLELISATION")
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(
+ data = parallel::clusterSplit(Clust, tempo.list),
+ output = log.file,
+ path = "./"
+ )
+ paral.output.list <-
+ parallel::clusterApply(
+ # paral.output.list is a list made of thread.nb compartments, each made of n / thread.nb (mat theo column number) compartment. Each compartment receive the corresponding results of fun_permut(), i.e., data (permuted mat1.perm), warning message, cor (final correlation) and count (number of permutations)
+ cl = Clust,
+ x = parallel::clusterSplit(Clust, tempo.list),
+ # split 1:ncol(mat1.perm) vector according to the number of cluster and put into x for each cpu. Allow to take only the column of mat1.perm with no NA corr
+ rho1 = rho1,
+ mat1.perm = mat1.perm,
+ mat2.perm = mat2.perm,
+ print.count = print.count,
+ # very important because another R
+ cute = cute,
+ req.package.list = req.package.list,
+ lib.path = lib.path,
+ # end very important because another R
+ fun = function(x,
+ mat1.perm,
+ mat2.perm,
+ rho1,
+ print.count,
+ cute,
+ req.package.list,
+ lib.path) {
+ # check again: very important because another R
+ process.id <- Sys.getpid()
+ source(cute, local = .GlobalEnv)
+ fun_pack(req.package = req.package.list,
+ lib.path = lib.path,
+ load = TRUE) # load = TRUE to be sure that functions are present in the environment. And this prevent to use R.lib.path argument of fun_python_pack()
+ # end check again: very important because another R
+ output <- vector("list", length(x))
+ names(output) <- as.character(x) # paste0("V", x)
+ # see also Protocol 100-rev0 Parallelization in R.docx
+ if (exists(".Random.seed", envir = .GlobalEnv)) {
+ # if .Random.seed does not exists, it means that no random operation has been performed yet in any R environment
+ tempo.random.seed <- .Random.seed
+ on.exit(assign(".Random.seed", tempo.random.seed, env = .GlobalEnv))
+ } else{
+ on.exit(set.seed(NULL)) # inactivate seeding -> return to complete randomness
+ }
+ for (i0 in 1:length(x)) {
+ if (i0 == 1) {
+ set.seed(x[i0]) # take the first number of x for seed, which is different for each parallelization
+ }
+ tempo.cor <-
+ suppressWarnings(
+ cor(
+ mat1.perm[, x[i0]],
+ mat2.perm[, x[i0]],
+ use = "pairwise.complete.obs",
+ method = "spearman"
+ )
+ )
+ if (length(table(mat1.perm[, x[i0]])) == 1) {
+ output[[i0]] <- list(
+ data = mat1.perm[, x[i0]],
+ warnings = paste0(
+ "NO PERMUTATION PERFORMED BECAUSE MAT1 MADE OF IDENTICAL ELEMENTS: ",
+ names(table(mat1.perm[, x[i0]]))
+ ),
+ cor = NA,
+ count = 0
+ )
+ } else if (length(table(mat2.perm[, x[i0]])) == 1) {
+ output[[i0]] <- list(
+ data = mat1.perm[, x[i0]],
+ warnings = paste0(
+ "NO PERMUTATION PERFORMED BECAUSE MAT2 MADE OF IDENTICAL ELEMENTS: ",
+ names(table(mat2.perm[, x[i0]]))
+ ),
+ cor = NA,
+ count = 0
+ )
+ } else if (tempo.cor <= rho1[x[i0]]) {
+ output[[i0]] <- list(
+ data = mat1.perm[, x[i0]],
+ warnings = paste0(
+ "NO PERMUTATION PERFORMED BECAUSE THE ABSOLUTE VALUE OF THE CORRELATION ",
+ fun_round(tempo.cor),
+ " BETWEEN MAT1 AND MAT2 HAS BEEN DETECTED AS BELOW THE CORRELATION LIMIT PARAMETER ",
+ fun_round(rho1[x[i0]])
+ ),
+ cor = tempo.cor,
+ count = 0
+ )
+ } else{
+ output[[i0]] <-
+ fun_permut(
+ data1 = mat1.perm[, x[i0]],
+ data2 = mat2.perm[, x[i0]],
+ seed = NULL,
+ text.print = paste0("PROCESS ", process.id, " | DIAG NB ", x[i0]),
+ print.count = print.count,
+ cor.method = "spearman",
+ cor.limit = rho1[x[i0]]
+ ) # with seed = NULL, take the global random seed that already exist because set above
+ }
+ }
+ return(output)
+ }
+ )
+ print("mada daijoubu 7?")
+ parallel::stopCluster(Clust)
+ tempo.date <- Sys.time()
+ tempo.time <- as.numeric(tempo.date)
+ tempo.lapse <-
+ round(lubridate::seconds_to_period(tempo.time - perm.ini.time))
+ tempo.cat <-
+ paste0(
+ "PERMUTATION RUN ON THEO MATRICES ACHIEVED AT: ",
+ tempo.date,
+ " | TIME LAPSE: ",
+ tempo.lapse
+ )
+ cat(paste0("\n", tempo.cat, "\n"))
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ # end parallelization
+ # recover the results
+ permut.list <-
+ vector("list", ncol(mat1.perm)) # list containing all the columns of mat.perm permuted
+ warning.list <-
+ vector("list", ncol(mat1.perm)) # list containing the corresponding warnings messages
+ cor.list <-
+ vector("list", ncol(mat1.perm)) # list containing the corresponding final correlations
+ count.list <-
+ vector("list", ncol(mat1.perm)) # list containing the corresponding permutation count
+ # BEWARE: erratic situations when NULL is assigned to a list. See https://stackoverflow.com/questions/7944809/assigning-null-to-a-list-element-in-r
+ for (i0 in 1:length(paral.output.list)) {
+ # compartment relatives to each parallelization
+ for (i1 in 1:length(paral.output.list[[i0]])) {
+ # compartment relatives to each diagonal inside parallelization
+ permut.list[[as.integer(names(paral.output.list[[i0]])[i1])]] <-
+ paral.output.list[[i0]][[i1]]$data
+ names(permut.list)[as.integer(names(paral.output.list[[i0]])[i1])] <-
+ names(paral.output.list[[i0]])[i1]
+ warning.list[[as.integer(names(paral.output.list[[i0]])[i1])]] <-
+ if (is.null(paral.output.list[[i0]][[i1]]$warn)) {
+ "NO WARNING"
+ } else{
+ paral.output.list[[i0]][[i1]]$warn
+ } # no NULL assignation in list
+ names(warning.list)[as.integer(names(paral.output.list[[i0]])[i1])] <-
+ names(paral.output.list[[i0]])[i1]
+ cor.list[[as.integer(names(paral.output.list[[i0]])[i1])]] <-
+ paral.output.list[[i0]][[i1]]$cor
+ names(cor.list)[as.integer(names(paral.output.list[[i0]])[i1])] <-
+ names(paral.output.list[[i0]])[i1]
+ count.list[[as.integer(names(paral.output.list[[i0]])[i1])]] <-
+ paral.output.list[[i0]][[i1]]$count
+ names(count.list)[as.integer(names(paral.output.list[[i0]])[i1])] <-
+ names(paral.output.list[[i0]])[i1]
+ }
+ }
+ if (!identical(as.integer(names(permut.list)), sort(unlist(
+ parallel::clusterSplit(Clust, tempo.list)
+ )))) {
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ names(permut.list) AND sort(unlist(parallel::clusterSplit(Clust, tempo.list)))
+ SHOULD BE IDENTICAL\n\n============\n\n"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ stop("\n", tempo.cat, "\n")
+ }
+ if (!identical(names(permut.list), names(warning.list))) {
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ names(permut.list) AND names(warning.list) SHOULD BE IDENTICAL\n\n============\n\n"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ stop("\n", tempo.cat, "\n")
+ }
+ if (!identical(names(permut.list), names(cor.list))) {
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ names(permut.list) AND names(cor.list) SHOULD BE IDENTICAL\n\n============\n\n"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ stop("\n", tempo.cat, "\n")
+ }
+ if (!identical(names(permut.list), names(count.list))) {
+ tempo.cat <-
+ paste0(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ names(permut.list) AND names(count.list) SHOULD BE IDENTICAL\n\n============\n\n"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ stop("\n", tempo.cat, "\n")
+ }
+ # end recover the results
+ # result print
+ tempo.cat <-
+ paste0(
+ "THE CORRELATION THRESHOLD SET FOR THE PERMUTATION STEP IS: ",
+ paste(fun_round(as.numeric(names(
+ table(rho1)
+ ))), collapse = " ")
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ tempo.cat <-
+ paste0(
+ "THE FINAL CORRELATION BETWEEN THE COLUMNS OF MAT THEO 1 AND 2
+ (OBS CORRESPONDING DIAGONAL CORRELATION) ARE:\nCOLUMN\tCORR\n",
+ paste(
+ names(cor.list),
+ fun_round(unlist(cor.list)),
+ sep = "\t",
+ collapse = "\n"
+ )
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ tempo.cat <-
+ paste0(
+ "THE ASSOCIATED WARNING MESSAGES FROM THE fun_permut() FUNCTION ARE:\n",
+ paste(
+ "COLUMN NB ",
+ names(unlist(warning.list)),
+ ": ",
+ unlist(warning.list),
+ collapse = "\n"
+ )
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_open(
+ pdf.disp = TRUE,
+ fun.path = "./",
+ pdf.name.file = paste0("correlation_plots_", analysis.nb),
+ width.fun = width.wind,
+ height.fun = height.wind
+ )
+ tempo.max <-
+ max(as.integer(names(permut.list)), na.rm = TRUE)
+ if (tempo.max > 40) {
+ cor.print.loop <- c(1:20, (tempo.max - 19):tempo.max)
+ tempo.max <- 40
+ tempo.cat <-
+ paste0(
+ "ONLY THE 20 FIRST AND 20 LAST DIAGONALS ARE PLOTTED IN THE correlation_plots.pdf FILE"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ } else{
+ cor.print.loop <- 1:tempo.max
+ }
+ print("mada daijoubu 8?")
+ count.loop <- 0
+ for (i0 in cor.print.loop) {
+ count.loop <- count.loop + 1
+ tempo.data.plot <-
+ data.frame(MAT1 = mat1.perm[, i0], MAT2 = mat2.perm[, i0])
+ x.tempo.range <-
+ range(tempo.data.plot[, "MAT1"], na.rm = TRUE, finite = TRUE)
+ y.tempo.range <-
+ range(tempo.data.plot[, "MAT2"], na.rm = TRUE, finite = TRUE)
+ tempo.cor <-
+ suppressWarnings(
+ cor(
+ x = tempo.data.plot[, "MAT1"],
+ y = tempo.data.plot[, "MAT2"],
+ use = "pairwise.complete.obs",
+ method = "spearman"
+ )
+ )
+ tempo.title <-
+ paste0(
+ "BEFORE PERMUTATION | (MAT1 THEO / MAT2 THEO) SPEARMAN CORRELATION\n
+ OBS MATRIX CORRESPONDING DIAGONAL NUMBER: ",
+ i0,
+ "\nCORRELATION VALUE: ",
+ if (is.na(tempo.cor)) {
+ NA
+ } else{
+ fun_round(tempo.cor)
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(x.tempo.range, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(y.tempo.range, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = tempo.data.plot,
+ x = "MAT1",
+ y = "MAT2",
+ color = grey(0.40),
+ geom = "geom_point",
+ alpha = 0.5,
+ dot.size = dot.size,
+ x.lim = if (diff(x.tempo.range) == 0) {
+ c(unique(x.tempo.range) - 1, unique(x.tempo.range) + 1)
+ } else{
+ x.tempo.range
+ },
+ x.tick.nb = 8,
+ y.lim = if (diff(y.tempo.range) == 0) {
+ c(unique(y.tempo.range) - 1, unique(y.tempo.range) + 1)
+ } else{
+ y.tempo.range
+ },
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = FALSE
+ )
+ tempo.data.plot <-
+ data.frame(MAT1 = permut.list[[i0]], MAT2 = mat2.perm[, i0])
+ x.tempo.range <-
+ range(tempo.data.plot[, "MAT1"], na.rm = TRUE, finite = TRUE)
+ y.tempo.range <-
+ range(tempo.data.plot[, "MAT2"], na.rm = TRUE, finite = TRUE)
+ tempo.cor <-
+ suppressWarnings(
+ cor(
+ x = tempo.data.plot[, "MAT1"],
+ y = tempo.data.plot[, "MAT2"],
+ use = "pairwise.complete.obs",
+ method = "spearman"
+ )
+ )
+ tempo.title <-
+ paste0(
+ "AFTER PERMUTATION | (MAT1 THEO / MAT2 THEO) SPEARMAN CORRELATION\n
+ OBS MATRIX CORRESPONDING DIAGONAL NUMBER: ",
+ i0,
+ "\nCORRELATION VALUE: ",
+ if (is.na(tempo.cor)) {
+ NA
+ } else{
+ fun_round(tempo.cor)
+ },
+ "\nCORRELATION INDICATED BY THE fun_permut() FUNCTION: ",
+ if (is.na(cor.list[[i0]])) {
+ NA
+ } else{
+ fun_round(cor.list[[i0]])
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(x.tempo.range, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(y.tempo.range, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = tempo.data.plot,
+ x = "MAT1",
+ y = "MAT2",
+ color = fun_gg_palette(1),
+ geom = "geom_point",
+ alpha = 0.5,
+ dot.size = dot.size,
+ x.lim = if (diff(x.tempo.range) == 0) {
+ c(unique(x.tempo.range) - 1, unique(x.tempo.range) + 1)
+ } else{
+ x.tempo.range
+ },
+ x.tick.nb = 8,
+ y.lim = if (diff(y.tempo.range) == 0) {
+ c(unique(y.tempo.range) - 1, unique(y.tempo.range) + 1)
+ } else{
+ y.tempo.range
+ },
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = FALSE
+ )
+ cat(paste0(
+ "\nPRINT CORR GRAPH NB ",
+ count.loop,
+ " / ",
+ tempo.max,
+ " (DIAG NB ",
+ i0,
+ ")"
+ ))
+ }
+ cat("\n")
+ dev.off()
+ # end result print
+ # mat1.perm filling
+ for (i0 in 1:ncol(mat1.perm)) {
+ mat1.perm[, i0] <-
+ permut.list[[i0]] # final permutation of the values using the permuted positions
+ }
+ # end mat1.perm filling
+ }
+ print("mada daijoubu 9?")
+ if (keep == FALSE) {
+ tempo.list <- c("mat1.ini", "mat1.perm", "mat2.ini", "mat2.perm")
+ tempo.cat <-
+ paste0(
+ "INITIAL AND PERMUTED THEO MATRICES SAVED IN: ",
+ paste0(tempo.list, collapse = "_"),
+ "_backup.RData"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ save(list = tempo.list,
+ file = paste0(tempo.list, collapse = "_"),
+ "_backup.RData")
+ rm(list = c("mat1.ini", "mat2.ini")) # .perm still needed
+ }
+ # end Permutation of the mat1.ini values to have the mat1.obs correlation on the diagonales between mat1 and mat2
+ # mean / cor of the theoretical matrices
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ suppressWarnings(data.frame(
+ MEAN = (
+ apply(X = mat1.perm, MARGIN = 2, FUN = "mean") +
+ apply(X = mat2.perm, MARGIN = 2, FUN = "mean")
+ ) / 2,
+ COR = mapply(
+ FUN = "cor",
+ x = as.data.frame(mat1.perm),
+ y = as.data.frame(mat2.perm),
+ use = "pairwise.complete.obs",
+ method = "spearman",
+ SIMPLIFY = TRUE
+ )
+ ))
+ if (transfo != "no") {
+ tempo.data.plot[, "MEAN"] <-
+ get(transfo)(tempo.data.plot[, "MEAN"]) # log(x + 1) only for heatmap
+ }
+ tempo.title <- paste0(
+ "AFTER PERMUTATION\n
+ (MAT1 THEO / MAT2 THEO) MEAN VERSUS (MAT1 THEO / MAT2 THEO) SPEARMAN CORRELATION\n",
+ if (transfo == "log2") {
+ "MEAN LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_cor.x.range2, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_cor.y.range2, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = tempo.data.plot,
+ x = "MEAN",
+ y = "COR",
+ color = grey(0.40),
+ geom = "geom_point",
+ alpha = 0.5,
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_cor.x.range2,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_cor.y.range2,
+ y.log = "no",
+ y.lab = "CORRELATION",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
+ # end mean / cor of the theoretical matrices
+ print("mada daijoubu 10?")
+ # correlation versus index before and after permutation
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ if (length(rho2) != length(unlist(cor.list))) {
+ # important because rho1 will be modified, and rho2 kept as the initial correlation between obs mat1 and mat2
+ tempo.cat <-
+ paste0(
+ "\n\n================\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ THE TWO CORRELATIONS rho2 AND cor.list DO NOT HAVE THE SAME LENGTH\n\n================\n\n"
+ ) # message for developers
+ stop(tempo.cat)
+ }
+ tempo.data.plot <-
+ data.frame(
+ CORRELATION = c(rho2, unlist(cor.list)),
+ COLUMN_NB = c(1:length(rho2), 1:length(rho2)),
+ KIND = rep(c("OBS", "THEO"), each = length(rho2))
+ )
+ tempo.title <-
+ paste0(
+ "SPEARMAN CORRELATION BETWEEN MAT1 OBS / MAT2 OBS\n
+ COMPARISON WITH MAT1 THEO / MAT2 THEO AFTER PERMUTATION\nX SCALE RANGE: ",
+ paste(range(
+ 1:length(rho2), na.rm = TRUE, finite = TRUE
+ ), collapse = " , "),
+ "\nY SCALE RANGE: -1, 1"
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot),
+ x = list("COLUMN_NB"),
+ y = list("CORRELATION"),
+ categ = list("KIND"),
+ geom = list("geom_point"),
+ alpha = list(0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.log = "no",
+ x.lab = "DIAGONAL INDEX",
+ x.tick.nb = 8,
+ y.log = "no",
+ y.lab = "CORRELATION",
+ y.lim = c(-1, 1),
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster
+ )
+ # end correlation versus index before and after permutation
+
+ print("mada daijoubu 11?")
+ ################ End Taking correlation into account
+
+
+ ################ sub sampling
+
+
+ cat("\nTHEO MATRICES SUBSAMPLING\n")
+ fun_report(
+ data = "\n\n################################ THEO MATRICES SUBSAMPLING",
+ path = "./",
+ output = log.file,
+ sep = 4
+ )
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ fun_gg_empty_graph(text = "THEO MATRICES\nSUBSAMPLING", text.size = 3)
+
+
+ # theoretical matrix subsampling (this allow to have smaller values on the mean x of the MD plot)
+ # division of the coverage in each cell of column i0 of theo mat by sub.factor1[i0] (reduction of the coverage), and then random sampling of one value considering that the coverage is a mean coverage of the poisson law (is poisson law, lamnda = mean = variance). Thus, sapply(lambda, FUN = rpois, n = 1)
+ mat1.down <- mat1.perm
+ for (i0 in 1:ncol(mat1.down)) {
+ if (!all(is.na(mat1.down[, i0]))) {
+ mat1.down[, i0] <-
+ sapply(mat1.down[, i0] / sub.factor1[i0], FUN = rpois, n = 1)
+ }
+ }
+ mat2.down <- mat2.perm
+ for (i0 in 1:ncol(mat2.down)) {
+ if (!all(is.na(mat2.down[, i0]))) {
+ mat2.down[, i0] <-
+ sapply(mat2.down[, i0] / sub.factor2[i0], FUN = rpois, n = 1)
+ }
+ }
+ # randomize the mat1.down row values in each column, to break the order in the first matrix, and use the same row order in mat2.down before using serpentine to keep the correlation between columns intact
+ # In fact, change nothing to shuffle or not
+ if (nrow(mat1.down) > 1) {
+ shuffled.row.pos <-
+ sample(
+ x = 1:nrow(mat1.down),
+ size = nrow(mat1.down),
+ replace = FALSE
+ )
+ } else{
+ stop(
+ "\n\n============\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ A SINGLE DIAGONAL PRESENT IN THEO MATRIX 1 (mat1.down)\n\n============\n\n"
+ )
+ }
+ # shuffling the rows of mat1.down and mat2.down (same repositionning for both matrix, to keep the relationship between rows (correlation))
+ mat1.mix <- mat1.down[shuffled.row.pos,]
+ mat2.mix <- mat2.down[shuffled.row.pos,]
+ if (keep == FALSE) {
+ tempo.list <- c("mat1.down", "mat2.down")
+ tempo.cat <- paste0(
+ "DOWNSAMPLED THEO MATRICES SAVED IN: ",
+ paste0(tempo.list, collapse = "_"),
+ "_backup.RData"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ save(list = tempo.list,
+ file = paste0(tempo.list, collapse = "_"),
+ "_backup.RData")
+ rm(list = tempo.list) # not saved because initial matrices
+ }
+ # export of theo matrices before binning
+
+ # end export of theo matrices before binning
+ # end theoretical matrix subsampling (this allow to have smaller values on the mean x of the MD plot)
+
+
+ # mean versus index plot before sub sampling
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ data.frame(
+ MEAN = apply(
+ X = mat1.perm,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ),
+ MEAN.MINUS.SD = apply(
+ X = mat1.perm,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ) -
+ apply(
+ mat1.perm,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ ),
+ MEAN.PLUS.SD = apply(
+ X = mat1.perm,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ) +
+ apply(
+ mat1.perm,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ )
+ )
+ if (transfo != "no") {
+ tempo.data.plot <-
+ suppressWarnings(get(transfo)(tempo.data.plot)) # log(x + 1) only for heatmap
+ if (any(is.na(tempo.data.plot$MEAN.MINUS.SD))) {
+ tempo.data.plot$MEAN.MINUS.SD[is.na(tempo.data.plot$MEAN.MINUS.SD)] <-
+ tempo.data.plot$MEAN[is.na(tempo.data.plot$MEAN.MINUS.SD)]
+ }
+ }
+ tempo.data.plot <-
+ data.frame(COLUMN_NB = 1:nrow(tempo.data.plot), tempo.data.plot)
+ tempo.title <-
+ paste0(
+ "MAT1 THEO\nAFTER PERMUTATION AND BEFORE SUB SAMPLING\nMEAN PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x)\nABSENT SD IF LOG2(M - SD) < 0 "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x)\nABSENT SD IF LOG10(M - SD) < 0 "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(range(
+ 1:nrow(tempo.data.plot),
+ na.rm = TRUE,
+ finite = TRUE
+ ), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.y.range2, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot),
+ x = list("COLUMN_NB"),
+ y = list("MEAN"),
+ color = list(grey(0.40)),
+ geom = list("geom_point"),
+ alpha = list(0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.log = "no",
+ x.lab = "COLUMN NB",
+ x.tick.nb = 8,
+ y.log = transfo,
+ y.lab = "MEAN",
+ y.lim = m_sd.y.range2,
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ add = paste0(
+ '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot$COLUMN_NB,
+ xend = tempo.data.plot$COLUMN_NB, y = tempo.data.plot$MEAN.MINUS.SD, yend = tempo.data.plot$MEAN.PLUS.SD),
+ ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
+ )
+ )
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ data.frame(
+ MEAN = apply(
+ X = mat2.perm,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ),
+ MEAN.MINUS.SD = apply(
+ X = mat2.perm,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ) -
+ apply(
+ mat2.perm,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ ),
+ MEAN.PLUS.SD = apply(
+ X = mat2.perm,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ) +
+ apply(
+ mat2.perm,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ )
+ )
+ if (transfo != "no") {
+ tempo.data.plot <-
+ suppressWarnings(get(transfo)(tempo.data.plot)) # log(x + 1) only for heatmap
+ if (any(is.na(tempo.data.plot$MEAN.MINUS.SD))) {
+ tempo.data.plot$MEAN.MINUS.SD[is.na(tempo.data.plot$MEAN.MINUS.SD)] <-
+ tempo.data.plot$MEAN[is.na(tempo.data.plot$MEAN.MINUS.SD)]
+ }
+ }
+ tempo.data.plot <-
+ data.frame(COLUMN_NB = 1:nrow(tempo.data.plot), tempo.data.plot)
+ tempo.title <-
+ paste0(
+ "MAT2 THEO\nAFTER PERMUTATION AND BEFORE SUB SAMPLING\nMEAN PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x)\nABSENT SD IF LOG2(M - SD) < 0 "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x)\nABSENT SD IF LOG10(M - SD) < 0 "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(range(
+ 1:nrow(tempo.data.plot),
+ na.rm = TRUE,
+ finite = TRUE
+ ),
+ collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.y.range2, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot),
+ x = list("COLUMN_NB"),
+ y = list("MEAN"),
+ color = list(grey(0.40)),
+ geom = list("geom_point"),
+ alpha = list(0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.log = "no",
+ x.lab = "COLUMN NB",
+ x.tick.nb = 8,
+ y.log = transfo,
+ y.lab = "MEAN",
+ y.lim = m_sd.y.range2,
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ add = paste0(
+ '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot$COLUMN_NB,
+ xend = tempo.data.plot$COLUMN_NB, y = tempo.data.plot$MEAN.MINUS.SD, yend = tempo.data.plot$MEAN.PLUS.SD),
+ ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
+ )
+ )
+ # end mean versus index plot before sub sampling
+ if (keep == FALSE) {
+ tempo.list <- c("mat1.perm", "mat2.perm")
+ # save(list = tempo.list, file = "", paste0(tempo.list, collapse = "_"), "_backup.RData") # not saved here because already saved before
+ rm(list = tempo.list) # not saved because initial matrices
+ }
+ # mean versus index plot after sub sampling
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ data.frame(
+ MEAN = apply(
+ X = mat1.mix,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ),
+ MEAN.MINUS.SD = apply(
+ X = mat1.mix,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ) -
+ apply(
+ mat1.mix,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ ),
+ MEAN.PLUS.SD = apply(
+ X = mat1.mix,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ) +
+ apply(
+ mat1.mix,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ )
+ )
+ if (transfo != "no") {
+ tempo.data.plot <-
+ suppressWarnings(get(transfo)(tempo.data.plot)) # log(x + 1) only for heatmap
+ if (any(is.na(tempo.data.plot$MEAN.MINUS.SD))) {
+ tempo.data.plot$MEAN.MINUS.SD[is.na(tempo.data.plot$MEAN.MINUS.SD)] <-
+ tempo.data.plot$MEAN[is.na(tempo.data.plot$MEAN.MINUS.SD)]
+ }
+ }
+ tempo.data.plot <-
+ data.frame(COLUMN_NB = 1:nrow(tempo.data.plot), tempo.data.plot)
+ tempo.title <-
+ paste0(
+ "MAT1 THEO\nAFTER PERMUTATION AND AFTER SUB SAMPLING\nMEAN PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x)\nABSENT SD IF LOG2(M - SD) < 0 "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x)\nABSENT SD IF LOG10(M - SD) < 0 "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(range(
+ 1:nrow(tempo.data.plot),
+ na.rm = TRUE,
+ finite = TRUE
+ ),
+ collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.y.range2, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot),
+ x = list("COLUMN_NB"),
+ y = list("MEAN"),
+ color = list(grey(0.40)),
+ geom = list("geom_point"),
+ alpha = list(0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.log = "no",
+ x.lab = "COLUMN NB",
+ x.tick.nb = 8,
+ y.log = transfo,
+ y.lab = "MEAN",
+ y.lim = m_sd.y.range2,
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ add = paste0(
+ '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot$COLUMN_NB,
+ xend = tempo.data.plot$COLUMN_NB, y = tempo.data.plot$MEAN.MINUS.SD, yend = tempo.data.plot$MEAN.PLUS.SD),
+ ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
+ )
+ )
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ data.frame(
+ MEAN = apply(
+ X = mat2.mix,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ),
+ MEAN.MINUS.SD = apply(
+ X = mat2.mix,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ) -
+ apply(
+ mat2.mix,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ ),
+ MEAN.PLUS.SD = apply(
+ X = mat2.mix,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ ) +
+ apply(
+ mat2.mix,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE
+ )
+ )
+ if (transfo != "no") {
+ tempo.data.plot <-
+ suppressWarnings(get(transfo)(tempo.data.plot)) # log(x + 1) only for heatmap
+ if (any(is.na(tempo.data.plot$MEAN.MINUS.SD))) {
+ tempo.data.plot$MEAN.MINUS.SD[is.na(tempo.data.plot$MEAN.MINUS.SD)] <-
+ tempo.data.plot$MEAN[is.na(tempo.data.plot$MEAN.MINUS.SD)]
+ }
+ }
+ tempo.data.plot <-
+ data.frame(COLUMN_NB = 1:nrow(tempo.data.plot), tempo.data.plot)
+ tempo.title <-
+ paste0(
+ "MAT2 THEO\nAFTER PERMUTATION AND AFTER SUB SAMPLING\nMEAN PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x)\nABSENT SD IF LOG2(M - SD) < 0 "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x)\nABSENT SD IF LOG10(M - SD) < 0 "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(range(
+ 1:nrow(tempo.data.plot),
+ na.rm = TRUE,
+ finite = TRUE
+ ),
+ collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.y.range2, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot),
+ x = list("COLUMN_NB"),
+ y = list("MEAN"),
+ color = list(grey(0.40)),
+ geom = list("geom_point"),
+ alpha = list(0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.log = "no",
+ x.lab = "COLUMN NB",
+ x.tick.nb = 8,
+ y.log = transfo,
+ y.lab = "MEAN",
+ y.lim = m_sd.y.range2,
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ add = paste0(
+ '+ ggplot2::geom_segment(data = data.frame(x = tempo.data.plot$COLUMN_NB,
+ xend = tempo.data.plot$COLUMN_NB, y = tempo.data.plot$MEAN.MINUS.SD, yend = tempo.data.plot$MEAN.PLUS.SD),
+ ggplot2::aes(x = x, y = y, xend = xend, yend = yend), color = grey(0.40), alpha = 0.3)'
+ )
+ )
+ # end mean versus index plot after sub sampling
+
+
+ # MD plot for the theoretical matrix 1 after sub sampling and permutation
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ x.MEAN <-
+ apply(
+ X = mat1.mix,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ )
+ y.SD <- apply(mat1.mix,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE)
+ tempo.data.plot <- data.frame(MEAN = x.MEAN, SD = y.SD)
+ if (transfo != "no") {
+ tempo.data.plot <-
+ get(transfo)(tempo.data.plot) # log(x + 1) only for heatmap
+ tempo.data.pois <-
+ data.frame(
+ x.pois = tempo.data.plot$MEAN,
+ y.sd.pois = tempo.data.plot$MEAN / 2,
+ y.cv.pois = get(transfo)(1) - tempo.data.plot$MEAN / 2
+ ) # because poisson distrib is mean = variance, thus sd = mean ^0.5, ie each mean as x is square rooted for y and then x.MEAN / 2 because log2(mean^0.5) = 0.5 * log2(mean). For cv, cv = sd/m -> log(cv) = log(sd/m) = log(m/m^0.5) = log(1/m^0.5) = log(1) - log(m^0.5) = log(1) - log(m)/2
+ tempo.data.negbinom <-
+ data.frame(
+ x.green = get(transfo)(mean.nb1),
+ y.green = get(transfo)(cv.nb1 * mean.nb1)
+ ) # neg binomiale distrib
+ } else{
+ tempo.data.pois <-
+ data.frame(
+ x.pois = tempo.data.plot$MEAN,
+ y.sd.pois = tempo.data.plot$MEAN ^ 0.5,
+ y.cv.pois = 1 / tempo.data.plot$MEAN ^
+ 0.5
+ )
+ tempo.data.negbinom <-
+ data.frame(x.green = mean.nb1, y.green = cv.nb1 * mean.nb1) # neg binomiale distrib
+ }
+ tempo.title <-
+ paste0(
+ "MAT1 THEO\nAFTER PERMUTATION AND SUB SAMPLING\nMEAN DEVIATION (MD) PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_sd.x.range2, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.y.range2, 2), collapse = " , "),
+ "\nRED LINE: POISSON DISTRIB\nGREEN LINE: NEG BINOM DISTRIB"
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot, tempo.data.pois, tempo.data.negbinom),
+ x = list("MEAN", "x.pois", "x.green"),
+ y = list("SD", "y.sd.pois", "y.green"),
+ color = list(grey(0.40), "red", "green"),
+ geom = list("geom_point", "geom_line", "geom_line"),
+ alpha = list(0.5, 1, 1),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_sd.x.range2,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_sd.y.range2,
+ y.log = transfo,
+ y.lab = "SD",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
+ # end MD plot for the theoretical matrix 1 after sub sampling and permutation
+
+ # MD plot for the theoretical matrix 2 after sub sampling and permutation
+ x.MEAN <-
+ apply(
+ X = mat2.mix,
+ MARGIN = 2,
+ FUN = "mean",
+ na.rm = TRUE
+ )
+ y.SD <- apply(mat2.mix,
+ MARGIN = 2,
+ FUN = "sd",
+ na.rm = TRUE)
+ tempo.data.plot <- data.frame(MEAN = x.MEAN, SD = y.SD)
+ if (transfo != "no") {
+ tempo.data.plot <-
+ get(transfo)(tempo.data.plot) # log(x + 1) only for heatmap
+ tempo.data.pois <-
+ data.frame(
+ x.pois = tempo.data.plot$MEAN,
+ y.sd.pois = tempo.data.plot$MEAN / 2,
+ y.cv.pois = get(transfo)(1) - tempo.data.plot$MEAN / 2
+ ) # because poisson distrib is mean = variance, thus sd = mean ^0.5, ie each mean as x is square rooted for y and then x.MEAN / 2 because log2(mean^0.5) = 0.5 * log2(mean). For cv, cv = sd/m -> log(cv) = log(sd/m) = log(m/m^0.5) = log(1/m^0.5) = log(1) - log(m^0.5) = log(1) - log(m)/2
+ tempo.data.negbinom <-
+ data.frame(
+ x.green = get(transfo)(mean.nb2),
+ y.green = get(transfo)(cv.nb2 * mean.nb2)
+ ) # neg binomiale distrib
+ } else{
+ tempo.data.pois <-
+ data.frame(
+ x.pois = tempo.data.plot$MEAN,
+ y.sd.pois = tempo.data.plot$MEAN ^ 0.5,
+ y.cv.pois = 1 / tempo.data.plot$MEAN ^
+ 0.5
+ )
+ tempo.data.negbinom <-
+ data.frame(x.green = mean.nb2, y.green = cv.nb2 * mean.nb2) # neg binomiale distrib
+ }
+ tempo.title <-
+ paste0(
+ "MAT2 THEO\nAFTER PERMUTATION AND SUB SAMPLING\nMEAN DEVIATION (MD) PLOT\n",
+ if (transfo == "log2") {
+ "MEAN AND SD LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND SD LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_sd.x.range2, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_sd.y.range2, 2), collapse = " , "),
+ "\nRED LINE: POISSON DISTRIB\n
+ GREEN LINE: NEG BINOM DISTRIB"
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot, tempo.data.pois, tempo.data.negbinom),
+ x = list("MEAN", "x.pois", "x.green"),
+ y = list("SD", "y.sd.pois", "y.green"),
+ color = list(grey(0.40), "red", "green"),
+ geom = list("geom_point", "geom_line", "geom_line"),
+ alpha = list(0.5, 1, 1),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_sd.x.range2,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_sd.y.range2,
+ y.log = transfo,
+ y.lab = "SD",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
+ # end MD plot for the theoretical matrix 2 after sub sampling and permutation
+
+ # mean / cor of the theoretical matrices
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ suppressWarnings(data.frame(
+ MEAN = (
+ apply(X = mat1.mix, MARGIN = 2, FUN = "mean") +
+ apply(X = mat2.mix, MARGIN = 2, FUN = "mean")
+ ) / 2,
+ COR = mapply(
+ FUN = "cor",
+ x = as.data.frame(mat1.mix),
+ y = as.data.frame(mat2.mix),
+ use = "pairwise.complete.obs",
+ method = "spearman",
+ SIMPLIFY = TRUE
+ )
+ ))
+ if (transfo != "no") {
+ tempo.data.plot[, "MEAN"] <-
+ get(transfo)(tempo.data.plot[, "MEAN"]) # log(x + 1) only for heatmap
+ }
+ tempo.title <- paste0(
+ "AFTER PERMUTATION AND SUB SAMPLING\n
+ (MAT1 THEO / MAT2 THEO) MEAN VERSUS (MAT1 THEO / MAT2 THEO) SPEARMAN CORRELATION\n",
+ if (transfo == "log2") {
+ "MEAN LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(m_cor.x.range2, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(m_cor.y.range2, 2), collapse = " , ")
+ )
+ fun_gg_scatter(
+ data1 = tempo.data.plot,
+ x = "MEAN",
+ y = "COR",
+ color = grey(0.40),
+ geom = "geom_point",
+ alpha = 0.5,
+ dot.size = dot.size,
+ line.size = line.size,
+ x.lim = m_cor.x.range2,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.lim = m_cor.y.range2,
+ y.log = "no",
+ y.lab = "CORRELATION",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0
+ ) # x.left.extra.margin = 0, x.right.extra.margin = 0, y.top.extra.margin = 0, y.bottom.extra.margin = 0 because already in m_sd.coord.obs
+ # correlation versus index before and after subsampling
+ tempo.cor <-
+ suppressWarnings(mapply(
+ FUN = "cor",
+ c(data.frame(mat1.mix)),
+ c(data.frame(mat2.mix)),
+ use = "pairwise.complete.obs",
+ method = "spearman"
+ ))
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ if (length(rho2) != length(tempo.cor)) {
+ #
+ tempo.cat <-
+ paste0(
+ "\n\n================\n\nINTERNAL ERROR CODE IN SLITHERINE\n
+ THE TWO CORRELATIONS rho2 AND tempo.cor DO NOT HAVE THE SAME LENGTH\n\n================\n\n"
+ ) # message for developers
+ stop(tempo.cat)
+ }
+ tempo.data.plot <-
+ data.frame(
+ CORRELATION = c(rho2, unlist(cor.list), tempo.cor),
+ COLUMN_NB = c(1:length(rho2), 1:length(rho2), 1:length(rho2)),
+ KIND = rep(
+ c("OBS", "THEO_AFTER_PERMUTATION", "THEO_AFTER_DOWNSAMPLING"),
+ each = length(rho2)
+ )
+ )
+ tempo.title <-
+ paste0(
+ "SPEARMAN CORRELATION BETWEEN MAT1 OBS / MAT2 OBS\n
+ COMPARISON WITH MAT1 THEO / MAT2 THEO 1) AFTER PERMUTATION AND 2)
+ AFTER PERMUTATION AND DOWNSAMPLING\nX SCALE RANGE: ",
+ paste(range(
+ 1:length(rho2),
+ na.rm = TRUE, finite = TRUE
+ ), collapse = " , "),
+ "\nY SCALE RANGE: -1, 1"
+ )
+ fun_gg_scatter(
+ data1 = list(tempo.data.plot),
+ x = list("COLUMN_NB"),
+ y = list("CORRELATION"),
+ categ = list("KIND"),
+ geom = list("geom_point"),
+ alpha = list(0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.log = "no",
+ x.lab = "DIAGONAL INDEX",
+ x.tick.nb = 8,
+ y.log = "no",
+ y.lab = "CORRELATION",
+ y.lim = c(-1, 1),
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster
+ )
+ # end correlation versus index before and after subsampling
+
+
+ ################ end sub sampling
+
+
+ ################ matrix visualization before comparison
+
+
+} else{
+ # message d'erreur à changer
+ tempo.warning <-
+ paste0(
+ "THE serp.binning PARAMETER SETTING HAS BEEN SET TO TRUE,
+ BUT THEORETICAL MATRICES HAVE BEEN IMPORTED\n
+ -> PRE SERPENTINE ANALYSIS IS SUFFICIENT (IF YOU NEED MORE SERPENTINE BINNING,
+ INCREASE THE VALUE OF THE serp.iter.nb PARAMETER)\n-> serp.binning PARAMETER RESET TO FALSE"
+ )
+ cat(paste0("\nWARNING: ", tempo.warning, "\n"))
+ warning.message <-
+ paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+
+}
+
+
+
+
+cat("\nMATRIX VISUALIZATION BEFORE COMPARISON\n")
+fun_report(
+ data = "\n\n################################ MATRIX VISUALIZATION BEFORE COMPARISON",
+ path = "./",
+ output = log.file,
+ sep = 4
+)
+if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+} else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+}
+fun_gg_empty_graph(text = "MATRIX VISUALIZATION BEFORE COMPARISON", text.size = 3)
+if (ratio.normalization == TRUE) {
+ fun_report(
+ data = paste0(
+ "SIGNIFICANT DIFFERENCES BY SEGMENTATION PERFORMED ON NON NORMALIZED MATRICES\n
+ BUT CUTOFF, APPLIED JUST AFTER SEGMENTATION, PERFORMED ON NORMALIZED MATRICES:\n
+ THEO MATRICES:\nCELLS MEAN: NO NORMALIZATION (BECAUSE SELECTION IS PERFORMED ON CELL
+ RATIOS AND BECAUSE CELL MEANS REMAIN DISCRETE VALUES,
+ WHICH IS IMPORTANT FOR THE SEGMENTATION STEP AS DOTS REMAINS PERFECTLY OVERLAID)\n
+ CELLS RATIO: DIVISION BY THE NORMALIZATION FACTOR( CELL ADJUSTED MEAN OF MATRIX 2
+ DIVIDED BY CELL ADJUSTED MEAN OF MATRIX 1)\nOBS MATRICES:\n
+ CELLS MEAN: NO NORMALIZATION (AS FOR THEO MATRICES)\n
+ CELLS RATIO: DIVISION BY THE MEAN OF CELL RATIOS\n
+ SEE EXPLANATION ABOUT ADJUSTED MEAN IN THE CODE OF THE adj.mean.fun FUNCTION"
+ ),
+ output = log.file,
+ path = "./"
+ )
+} else{
+ fun_report(
+ data = paste0(
+ "SIGNIFICANT DIFFERENCES BY SEGMENTATION PERFORMED ON NON NORMALIZED MATRICES\n
+ AND CUTOFF, APPLIED JUST AFTER SEGMENTATION, ALSO PERFORMED ON NON NORMALIZED MATRICES:\n
+ THEO MATRICES:\nCELLS MEAN: NO NORMALIZATION (BECAUSE SELECTION IS PERFORMED ON CELL
+ RATIOS AND BECAUSE CELL MEANS REMAIN DISCRETE VALUES, WHICH IS IMPORTANT
+ FOR THE SEGMENTATION STEP AS DOTS REMAINS PERFECTLY OVERLAID)\n
+ CELLS RATIO: NO NORMALIZATION ACCORDING TO THE ratio.normalization USER PARAMETER SETTING"
+ ),
+ output = log.file,
+ path = "./"
+ )
+}
+# matrix preparation
+# theo dataframe alone
+theo.mean.mat <- (mat1.mix + mat2.mix) / 2
+theo.ratio.mat <-
+ mat2.mix / mat1.mix # mat2.mix / mat1.mix to respect serpentine convention. Here nomralization before ratio
+mat1.theo.mean <- adj.mean.fun(x_3fun = mat1.mix, text_3fun = "")
+mat2.theo.mean <- adj.mean.fun(x_3fun = mat2.mix, text_3fun = "")
+if (ratio.normalization == TRUE) {
+ theo.ratio.factor <- mat2.theo.mean / mat1.theo.mean
+ fun_report(
+ data = paste0(
+ "NORMALIZATION FACTOR OF CELL RATIOS OF THEO MATRICES: ",
+ fun_round(theo.ratio.factor),
+ "\nUSING CELL ADJUSTED MEAN OF MATRIX 2: ",
+ fun_round(mat2.theo.mean),
+ "\nAND CELL ADJUSTED MEAN OF MATRIX 1: ",
+ fun_round(mat1.theo.mean)
+ ),
+ output = log.file,
+ path = "./"
+ )
+} else{
+ theo.ratio.factor <- 1 # division by 1 means no norm
+}
+mat1.mix.norm <- mat1.mix / mat1.theo.mean
+mat2.mix.norm <- mat2.mix / mat2.theo.mean
+theo.ratio.mat.norm <-
+ theo.ratio.mat / theo.ratio.factor # not normalized if ratio.normalization == FALSE because theo.ratio.factor == 1
+if (transfo != "no") {
+ fun_report(
+ data = paste0(
+ "SIGNIFICANT DIFFERENCES PERFORMED ON ",
+ toupper(transfo),
+ " TRANSFORMED DATA"
+ ),
+ output = log.file,
+ path = "./"
+ )
+ mat1.mix.norm.trans <-
+ get(transfo)(mat1.mix.norm + 1) # for single heatmap
+ mat2.mix.norm.trans <-
+ get(transfo)(mat2.mix.norm + 1) # for single heatmap
+ theo.mean.mat.trans <- get(transfo)(theo.mean.mat)
+ theo.ratio.mat.trans <-
+ get(transfo)(theo.ratio.mat) # required for segmentation (theo.df.pre.for.segm)
+ theo.ratio.mat.norm.trans <- get(transfo)(theo.ratio.mat.norm)
+ theo.df.pre <-
+ data.frame(
+ MEAN = as.vector(theo.mean.mat.trans),
+ RATIO = as.vector(theo.ratio.mat.norm.trans),
+ MATRICES = "Theo",
+ coord_1D = 1:(nrow(mat1.mix) * ncol(mat1.mix)),
+ stringsAsFactors = FALSE
+ ) # The coord_1D coordinate is the 1D position of a cell in a matrix
+ theo.df.pre.for.segm <-
+ data.frame(
+ MEAN = as.vector(theo.mean.mat.trans),
+ RATIO = as.vector(theo.ratio.mat.trans),
+ MATRICES = "Theo",
+ coord_1D = 1:(nrow(mat1.mix) * ncol(mat1.mix)),
+ stringsAsFactors = FALSE
+ ) # The coord_1D coordinate is the 1D position of a cell in a matrix
+} else{
+ fun_report(
+ data = paste0(
+ "SIGNIFICANT DIFFERENCES PERFORMED ON ",
+ toupper(transfo),
+ "N TRANSFORMED DATA"
+ ),
+ output = log.file,
+ path = "./"
+ )
+ theo.df.pre <-
+ data.frame(
+ MEAN = as.vector(theo.mean.mat),
+ RATIO = as.vector(theo.ratio.mat.norm),
+ MATRICES = "Theo",
+ coord_1D = 1:(nrow(mat1.mix) * ncol(mat1.mix)),
+ stringsAsFactors = FALSE
+ ) # The coord_1D coordinate is the 1D position of a cell in a matrix
+ theo.df.pre.for.segm <-
+ data.frame(
+ MEAN = as.vector(theo.mean.mat),
+ RATIO = as.vector(theo.ratio.mat),
+ MATRICES = "Theo",
+ coord_1D = 1:(nrow(mat1.mix) * ncol(mat1.mix)),
+ stringsAsFactors = FALSE
+ ) # The coord_1D coordinate is the 1D position of a cell in a matrix
+}
+# obs dataframe alone
+obs.mean.mat <- (mat1.obs + mat2.obs) / 2
+obs.ratio.mat <-
+ mat2.obs / mat1.obs # mat2.obs / mat1.obs to respect serpentine convention. Here nomralization before ratio
+mat1.obs.mean <-
+ mean(mat1.obs[is.finite(as.vector(mat1.obs))], na.rm = TRUE)
+mat2.obs.mean <-
+ mean(mat2.obs[is.finite(as.vector(mat2.obs))], na.rm = TRUE)
+if (ratio.normalization == TRUE) {
+ obs.ratio.factor <- mat2.obs.mean / mat1.obs.mean
+ fun_report(
+ data = paste0(
+ "NORMALIZATION FACTOR OF CELL RATIOS OF OBS MATRICES: ",
+ fun_round(obs.ratio.factor),
+ "\nUSING CELL ADJUSTED MEAN OF MATRIX 2: ",
+ fun_round(mat2.obs.mean),
+ "\nAND CELL ADJUSTED MEAN OF MATRIX 1: ",
+ fun_round(mat1.obs.mean)
+ ),
+ output = log.file,
+ path = "./"
+ )
+} else{
+ obs.ratio.factor <- 1
+}
+mat1.obs.norm <- mat1.obs / mat1.obs.mean
+mat2.obs.norm <- mat2.obs / mat2.obs.mean
+obs.ratio.mat.norm <-
+ obs.ratio.mat / obs.ratio.factor # not normalized if ratio.normalization == FALSE because obs.ratio.factor == 1
+obs.ratio.mat.norm[obs.ratio.mat.norm == 0] <-
+ NA # replacement of zero by NA because zero values means "no reads". Thus, not interesting for the significativity
+if (transfo != "no") {
+ mat1.obs.norm.trans <-
+ get(transfo)(mat1.obs.norm + 1) # for single heatmap
+ mat2.obs.norm.trans <-
+ get(transfo)(mat2.obs.norm + 1) # for single heatmap
+ obs.mean.mat.trans <- get(transfo)(obs.mean.mat)
+ obs.ratio.mat.trans <-
+ get(transfo)(obs.ratio.mat) # required for segmentation (obs.df.pre.for.segm)
+ obs.ratio.mat.norm.trans <- get(transfo)(obs.ratio.mat.norm)
+ obs.df.pre <-
+ data.frame(
+ MEAN = as.vector(obs.mean.mat.trans),
+ RATIO = as.vector(obs.ratio.mat.norm.trans),
+ MATRICES = "Obs",
+ coord_1D = 1:(nrow(mat1.obs) * ncol(mat1.obs)),
+ stringsAsFactors = FALSE
+ ) # The coord_1D coordinate is the 1D position of a cell in a matrix
+ obs.df.pre.for.segm <-
+ data.frame(
+ MEAN = as.vector(obs.mean.mat.trans),
+ RATIO = as.vector(obs.ratio.mat.trans),
+ MATRICES = "Obs",
+ coord_1D = 1:(nrow(mat1.obs) * ncol(mat1.obs)),
+ stringsAsFactors = FALSE
+ ) # The coord_1D coordinate is the 1D position of a cell in a matrix
+} else{
+ obs.df.pre <-
+ data.frame(
+ MEAN = as.vector(obs.mean.mat),
+ RATIO = as.vector(obs.ratio.mat.norm),
+ MATRICES = "Obs",
+ coord_1D = 1:(nrow(mat1.obs) * ncol(mat1.obs)),
+ stringsAsFactors = FALSE
+ ) # The coord_1D coordinate is the 1D position of a cell in a matrix
+ obs.df.pre.for.segm <-
+ data.frame(
+ MEAN = as.vector(obs.mean.mat),
+ RATIO = as.vector(obs.ratio.mat),
+ MATRICES = "Obs",
+ coord_1D = 1:(nrow(mat1.obs) * ncol(mat1.obs)),
+ stringsAsFactors = FALSE
+ ) # The coord_1D coordinate is the 1D position of a cell in a matrix
+}
+final.df.pre <- rbind(theo.df.pre, obs.df.pre)
+if (transfo != "no") {
+ loop.mat.names <-
+ c(
+ "mat1.mix.norm.trans",
+ "mat2.mix.norm.trans",
+ "mat1.obs.norm.trans",
+ "mat2.obs.norm.trans"
+ )
+ diff.loop.mat.names <-
+ c("theo.ratio.mat.norm.trans", "obs.ratio.mat.norm.trans")
+ s.obs.heatmap.range.norm.pre <-
+ range(mat1.obs.norm.trans,
+ mat2.obs.norm.trans,
+ na.rm = TRUE,
+ finite = TRUE)
+ s.both.heatmap.range.norm.pre <-
+ range(
+ mat1.mix.norm.trans,
+ mat2.mix.norm.trans,
+ s.obs.heatmap.range.norm.pre,
+ na.rm = TRUE,
+ finite = TRUE
+ )
+ tempo.range <-
+ max(abs(range(
+ final.df.pre$RATIO, na.rm = TRUE, finite = TRUE
+ )), na.rm = TRUE)
+ diff.both.heatmap.range.norm.pre <-
+ c(-tempo.range, tempo.range) # to center the scale on log() = 0, whatever normalization or not. If no normalization, red or blue can be predominant
+} else{
+ loop.mat.names <-
+ c("mat1.mix.norm",
+ "mat2.mix.norm",
+ "mat1.obs.norm",
+ "mat2.obs.norm")
+ diff.loop.mat.names <-
+ c("theo.ratio.mat.norm", "obs.ratio.mat.norm")
+ s.obs.heatmap.range.norm.pre <-
+ range(mat1.obs.norm,
+ mat2.obs.norm,
+ na.rm = TRUE,
+ finite = TRUE)
+ s.both.heatmap.range.norm.pre <-
+ range(
+ mat1.mix.norm,
+ mat2.mix.norm,
+ s.obs.heatmap.range.norm.pre,
+ na.rm = TRUE,
+ finite = TRUE
+ )
+ diff.both.heatmap.range.norm.pre <-
+ range(final.df.pre$RATIO, na.rm = TRUE, finite = TRUE) #
+}
+# end matrix preparation
+# heatmap
+loop.heatmap.title1 <-
+ c(
+ "THEO MAT1 BEFORE SERPENTINE",
+ "THEO MAT2 BEFORE SERPENTINE",
+ "OBS MAT1 BEFORE SERPENTINE",
+ "OBS MAT2 BEFORE SERPENTINE"
+ )
+loop.heatmap.title2 <-
+ c(
+ "NO SYMMETRIC MATRIX",
+ "NO SYMMETRIC MATRIX",
+ ifelse(
+ serp.symmet.input == TRUE,
+ "SYMMETRIC MATRIX (FORCED BY USER OPTION)",
+ "NO SYMMETRIC MATRIX"
+ ),
+ ifelse(
+ serp.symmet.input == TRUE,
+ "SYMMETRIC MATRIX (FORCED BY USER OPTION)",
+ "NO SYMMETRIC MATRIX"
+ )
+ )
+loop.heatmap.title3 <-
+ c(
+ "WEIGHTED DIAGONAL MEAN DIVISION",
+ "WEIGHTED DIAGONAL MEAN DIVISION",
+ "GLOBAL MEAN DIVISION",
+ "GLOBAL MEAN DIVISION"
+ )
+loop.heatmap.title <- paste0(
+ loop.heatmap.title1,
+ "\n",
+ if (transfo == "log2") {
+ "LOG2(x + 1) "
+ } else if (transfo == "log10") {
+ "LOG10(x + 1) "
+ } else{
+ "NO "
+ },
+ "TRANSFORMATION\nSCALE RANGE: ",
+ paste(fun_round(s.both.heatmap.range.norm.pre, 2),
+ collapse = " , "),
+ "\nNORMALIZED DISPLAY (",
+ loop.heatmap.title3,
+ ")\n",
+ loop.heatmap.title2
+)
+for (i0 in 1:length(loop.mat.names)) {
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ fun_gg_heatmap(
+ data1 = get(loop.mat.names[i0]),
+ legend.name1 = "",
+ limit1 = s.both.heatmap.range.norm.pre,
+ midpoint1 = mean(s.both.heatmap.range.norm.pre, na.rm = TRUE),
+ title = loop.heatmap.title[i0],
+ text.size = heatmap.text.size,
+ title.text.size = title.text.size
+ )
+}
+# end heatmap
+# differential heatmap
+if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+} else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+}
+loop.heatmap.title1 <-
+ c(
+ "DIFFERENTIAL THEO BEFORE SERPENTINE (THEO2 / THEO1)",
+ "DIFFERENTIAL OBS BEFORE SERPENTINE (OBS2 / OBS1)"
+ )
+loop.heatmap.title2 <- c(
+ "NO SYMMETRIC MATRIX",
+ ifelse(
+ serp.symmet.input == TRUE,
+ "SYMMETRIC MATRIX (FORCED BY USER OPTION)",
+ "NO SYMMETRIC MATRIX"
+ )
+)
+if (ratio.normalization == TRUE) {
+ loop.heatmap.title3 <-
+ c(
+ "NORMALIZED DISPLAY (WEIGHTED DIAGONAL MEAN DIVISION)",
+ "NORMALIZED DISPLAY (GLOBAL MEAN DIVISION)"
+ )
+} else{
+ loop.heatmap.title3 <-
+ c("NO RATIO NORMALIZATION", "NO RATIO NORMALIZATION")
+}
+loop.heatmap.title <- paste0(
+ loop.heatmap.title1,
+ "\n",
+ if (transfo == "log2") {
+ "LOG2(x + 1) "
+ } else if (transfo == "log10") {
+ "LOG10(x + 1) "
+ } else{
+ "NO "
+ },
+ "TRANSFORMATION\nSCALE RANGE: ",
+ paste(fun_round(diff.both.heatmap.range.norm.pre, 2),
+ collapse = " , "),
+ "\n",
+ loop.heatmap.title3,
+ "\n",
+ loop.heatmap.title2
+)
+for (i0 in 1:length(diff.loop.mat.names)) {
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ fun_gg_heatmap(
+ data1 = get(diff.loop.mat.names[i0]),
+ legend.name = "",
+ limit1 = diff.both.heatmap.range.norm.pre,
+ midpoint1 = mean(diff.both.heatmap.range.norm.pre, na.rm = TRUE),
+ title = loop.heatmap.title[i0],
+ title.text.size = title.text.size
+ )
+
+}
+# end differential heatmap
+
+print("koko made daijoubu")
+
+################ significant differences pre serpentine (SLITHERINE)
+
+
+
+cat("\nSIGNIFICANT DIFFERENCES PRE SERPENTINE (SLITHERINE)\n")
+fun_report(
+ data = "\n\n################################ SIGNIFICANT DIFFERENCES PRE SERPENTINE (SLITHERINE)",
+ path = "./",
+ output = log.file,
+ sep = 4
+)
+if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+} else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+}
+fun_gg_empty_graph(text = "SIGNIFICANT DIFFERENCES PRE SERPENTINE\n(SLITHERINE)", text.size = 3)
+# BEWARE: segment.pre.serp, final.df.pre, obs.df.pre and theo.df.pre potentially integrate log transfo already + normalized for theo
+# segmentation
+fun_report(
+ data = paste0(
+ "SEGMENTATION OF THE THEORETICAL DOT CLOUD (MEAN CELL / RATIO CELL PLOT) PERFORMED ON
+ NON NORMALIZED DATA\nBECAUSE OF DISCRETE RATIO VALUES THAT ARE PRESENTS FOR LOW MEANS\n
+ INDEED, NORMALIZATION SLIGHTLY SHIFTS THE RATIO VALUES BETWEEN THEO AND OBS CLOUDS,
+ WHICH INDUCES LOW MEAN CELL DOTS (I.E., NOISE) TO BE SIGNIFICANT AFTER SEGMENTATION.
+ THEN, DEPENDING ON USER SETTINGS (SEE ABOVE), RATIO NORMALIZATION ARE PERFORMED ON
+ SEGMENTATION RESULT DATA, BEFORE APPLYING THE CUTOFFS FILTERING"
+ ),
+ output = log.file,
+ path = "./"
+)
+segment.pre.serp <-
+ fun_segmentation(
+ data1 = theo.df.pre.for.segm,
+ x1 = "MEAN",
+ y1 = "RATIO",
+ x.range.split = range.split,
+ x.step.factor = step.factor,
+ error = error,
+ data2 = obs.df.pre.for.segm,
+ x2 = "MEAN",
+ y2 = "RATIO",
+ data2.pb.dot = "signif",
+ plot = FALSE,
+ graph.in.file = FALSE
+ ) # fun_seg create the outline MD plot
+fun_report(
+ data = "UNKNOWN DOTS HAVE BEEN CONSIDERED AS SIGNIFICANTS
+ (ARGUMENT data2.pb.dot OF fun_segmentation() SET TO \"signif\")",
+ output = log.file,
+ path = "./"
+)
+
+
+
+# cat(paste0("\n", segment.pre.serp$warn, "\n"))
+warning.message <-
+ paste0(warning.message,
+ ifelse(is.null(warning.message), "", "\n"),
+ segment.pre.serp$warn) #
+fun_report(data = segment.pre.serp$warn,
+ output = log.file,
+ path = "./")
+if (!is.null(segment.pre.serp$hframe)) {
+ names(segment.pre.serp$hframe)[names(segment.pre.serp$hframe) == "x"] <-
+ "MEAN" #
+ names(segment.pre.serp$hframe)[names(segment.pre.serp$hframe) == "y"] <-
+ "RATIO" #
+ names(segment.pre.serp$hframe)[names(segment.pre.serp$hframe) == "kind"] <-
+ "FRAMES" #
+} else{
+ tempo.cat <-
+ paste0("BEWARE: NO HORIZONTAL FRAME DETECTED DURING SEGMENTATION PRE SERPENTINE")
+ cat(paste0("\n", tempo.cat, "\n"))
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+}
+
+
+# jsp
+# normalization post segmentation if required
+if (ratio.normalization == TRUE) {
+ fun_report(
+ data = "DATA FRAMES IN segment.pre.serp OBJECT HAVE THE RATIO COLUMN NORMALIZED ACCORDING TO
+ USER PARAMETER SETTINGS",
+ output = log.file,
+ path = "./"
+ )
+ for (i in 1:length(segment.pre.serp)) {
+ if (all(class(segment.pre.serp[[i]]) == "data.frame") &
+ grepl(x = names(segment.pre.serp[i]), pattern = "data1|frame")) {
+ # modify only theoretical data and frames (made on theoretical data)
+ if (nrow(segment.pre.serp[[i]]) > 0) {
+ if (transfo != "no") {
+ segment.pre.serp[[i]]$RATIO <-
+ segment.pre.serp[[i]]$RATIO - get(transfo)(theo.ratio.factor)
+ } else{
+ segment.pre.serp[[i]]$RATIO <-
+ segment.pre.serp[[i]]$RATIO / theo.ratio.factor
+ }
+ }
+ }
+ if (all(class(segment.pre.serp[[i]]) == "data.frame") &
+ grepl(x = names(segment.pre.serp[i]), pattern = "data2")) {
+ # modify only obs data
+ if (nrow(segment.pre.serp[[i]]) > 0) {
+ if (transfo != "no") {
+ segment.pre.serp[[i]]$RATIO <-
+ segment.pre.serp[[i]]$RATIO - get(transfo)(obs.ratio.factor)
+ } else{
+ segment.pre.serp[[i]]$RATIO <-
+ segment.pre.serp[[i]]$RATIO / obs.ratio.factor
+ }
+ }
+ }
+ }
+} else{
+ fun_report(
+ data = "DATA FRAMES IN segment.pre.serp OBJECT DO NOT HAVE THE RATIO COLUMN
+ NORMALIZED ACCORDING TO USER PARAMETER SETTINGS",
+ output = log.file,
+ path = "./"
+ )
+}
+# end normalization post segmentation if required
+# end segmentation
+
+
+# second y filtering:
+# because theo and obs objects are already nomalized -> very simple to adjust the ratio.limit.sig
+if (transfo != "no") {
+ ratio.cutoff.sup.pre <-
+ get(transfo)(ratio.limit.sig) # no need to adjust because theo and obs objects are already normalized
+ ratio.cutoff.inf.pre <- -get(transfo)(ratio.limit.sig) #
+} else{
+ ratio.cutoff.sup.pre <- ratio.limit.sig #
+ ratio.cutoff.inf.pre <- -ratio.limit.sig #
+}
+fun_report(
+ data = paste0(
+ "CUT-OFFS SET TO ",
+ ratio.limit.sig,
+ " BY THE USER CORRESPOND TO ",
+ fun_round(ratio.cutoff.inf.pre),
+ " AND ",
+ fun_round(ratio.cutoff.sup.pre),
+ " ON THE SEGMENTATION GRAPHS"
+ ),
+ output = log.file,
+ path = "./"
+)
+# end weighting the cell ratio before computing the global mean ratio, after moving NA, Inf columns and also NA, Inf cells in columns with values
+signif.theo.dot.pre <-
+ segment.pre.serp$data1.signif.dot # significant data frame of data1 pre serpentine
+if (!is.null(signif.theo.dot.pre)) {
+ if (all(
+ signif.theo.dot.pre$RATIO > ratio.cutoff.inf.pre &
+ signif.theo.dot.pre$RATIO < ratio.cutoff.sup.pre
+ )) {
+ tempo.cat <-
+ paste0(
+ "BEWARE: SIGNIFICANT THEO DOTS DETECTED DURING SEGMENTATION PRE SERPENTINE\n
+ BUT NOT ANYMORE AFTER USING THE ratio.limit.sig PARAMETER (",
+ ratio.limit.sig,
+ ")\n
+ SIGNIFICANT USER LIMITS: ",
+ paste(fun_round(
+ c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre)
+ ), collapse = " ")
+ )
+ cat(paste0("\n", tempo.cat, "\n"))
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(
+ data = "THE SIGNIFICANT DOTS ARE:",
+ output = log.file,
+ path = "./",
+ sep = 1
+ )
+ fun_report(data = signif.theo.dot.pre,
+ output = log.file,
+ path = "./")
+ signif.theo.dot.pre <- NULL
+ } else{
+ signif.theo.dot.pre <- unique(signif.theo.dot.pre[!(
+ signif.theo.dot.pre$RATIO > ratio.cutoff.inf.pre &
+ signif.theo.dot.pre$RATIO < ratio.cutoff.sup.pre
+ ),]) # only dot nb are finally kept
+ }
+} else{
+ tempo.cat <-
+ paste0("NO SIGNIFICANT THEO DOTS DETECTED DURING SEGMENTATION PRE SERPENTINE")
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+}
+signif.obs.dot.pre <-
+ segment.pre.serp$data2.signif.dot # significant table of data2 pre serpentine
+sup.signif.obs.dot.pre <- NULL
+inf.signif.obs.dot.pre <- NULL
+if (!is.null(signif.obs.dot.pre)) {
+ if (all(
+ signif.obs.dot.pre$RATIO > ratio.cutoff.inf.pre &
+ signif.obs.dot.pre$RATIO < ratio.cutoff.sup.pre
+ )) {
+ tempo.cat <-
+ paste0(
+ "BEWARE: SIGNIFICANT OBS DOTS DETECTED DURING SEGMENTATION PRE SERPENTINE\n
+ BUT NOT ANYMORE AFTER USING THE ratio.limit.sig PARAMETER (",
+ ratio.limit.sig,
+ ")\n
+ SIGNIFICANT USER LIMITS: ",
+ paste(fun_round(
+ c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre)
+ ),
+ collapse = " ")
+ )
+ cat(paste0("\n", tempo.cat, "\n"))
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ fun_report(
+ data = "THE SIGNIFICANT DOTS ARE:",
+ output = log.file,
+ path = "./",
+ sep = 1
+ )
+ fun_report(data = signif.obs.dot.pre,
+ output = log.file,
+ path = "./")
+ signif.obs.dot.pre <- NULL
+ } else{
+ signif.obs.dot.pre <- unique(signif.obs.dot.pre[!(
+ signif.obs.dot.pre$RATIO > ratio.cutoff.inf.pre &
+ signif.obs.dot.pre$RATIO < ratio.cutoff.sup.pre
+ ),]) #
+ sup.signif.obs.dot.pre <-
+ signif.obs.dot.pre[signif.obs.dot.pre$RATIO > 0,] # positive log ratio, i.e., mat2 > mat1
+ inf.signif.obs.dot.pre <-
+ signif.obs.dot.pre[signif.obs.dot.pre$RATIO < 0,] # negative log ratio, i.e., mat2 < mat1
+ }
+} else{
+ tempo.cat <-
+ paste0("NO SIGNIFICANT OBS DOTS DETECTED DURING SEGMENTATION PRE SERPENTINE")
+ cat(paste0("\n", tempo.cat, "\n"))
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+}
+# end second y filtering
+
+fun_report(
+ data = paste0(
+ "PRE SERPENTINE SEGMENTATION DATA (RATIO NORMALIZED AND MEAN & RATIO POTENTIALLY LOG TRANSFORMED)
+ SAVED IN: ",
+ "segmentation_pre_serp.RData"
+ ),
+ output = log.file,
+ path = "./"
+)
+save(
+ list = c(
+ "segment.pre.serp",
+ "signif.theo.dot.pre",
+ "signif.obs.dot.pre",
+ "sup.signif.obs.dot.pre",
+ "inf.signif.obs.dot.pre",
+ "theo.df.pre",
+ "obs.df.pre"
+ ),
+ file = "segmentation_pre_serp.RData"
+)
+# segment.pre.serp result of segmentation (no second y filtering)
+# signif.theo.dot.pre significant theo dot after second y filtering
+# signif.obs.dot.pre significant obs dot after second y filtering
+# sup.signif.obs.dot.pre dots from signif.obs.dot.pre with positive log2ratio
+# inf.signif.obs.dot.pre dots from signif.obs.dot.pre with negative log2ratio
+# theo.df.pre mean and ratio cells of the 2 theo matrices, with ratio normalization and potentialy with transformation, used for the segmentation
+# obs.df.pre mean and ratio cells of the 2 theo matrices, with ratio normalization and potentialy with transformation, used for the segmentation
+
+# plot verif obs dots outside
+# MD overlay plot before serpentine
+segm.x.range.pre <-
+ range(final.df.pre$MEAN, na.rm = TRUE, finite = TRUE)
+segm.y.range.pre <-
+ range(
+ c(
+ final.df.pre$RATIO,
+ ratio.cutoff.inf.pre,
+ ratio.cutoff.sup.pre
+ ),
+ na.rm = TRUE,
+ finite = TRUE
+ )
+if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+} else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+}
+if (!is.null(signif.theo.dot.pre)) {
+ # signif dots in theo matrices
+ tempo.title <-
+ paste0(
+ "SEGMENTATION OF THE MEAN / RATIO MATRIX CELLS\n
+ THEO MAT ALONE + THEO SIGNIFICANT DOTS\n",
+ ifelse(
+ ratio.normalization == TRUE,
+ "THEO AND OBS RATIOS HAVE BEEN NORMALIZED (EACH CENTERED ON RATIO 1)\n",
+ ""
+ ),
+ if (transfo == "log2") {
+ "MEAN AND RATIO LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND RATIO LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(segm.x.range.pre, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(segm.y.range.pre, 2), collapse = " , "),
+ "\nCUT-OFFS DEFINED BY THE USER: ",
+ fun_round(ratio.cutoff.inf.pre),
+ " AND
+ ",
+ fun_round(ratio.cutoff.sup.pre)
+ )
+ fun_gg_scatter(
+ data1 = list(
+ L1 = theo.df.pre,
+ L2 = signif.theo.dot.pre,
+ L3 = segment.pre.serp$hframe,
+ L4 = data.frame(
+ y = c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre),
+ CUTOFFS = c("INF_LIMIT", "SUP_LIMIT")
+ )
+ ),
+ x = list(
+ L1 = "MEAN",
+ L2 = "MEAN",
+ L3 = "MEAN",
+ L4 = NULL
+ ),
+ y = list(
+ L1 = "RATIO",
+ L2 = "RATIO",
+ L3 = "RATIO",
+ L4 = "y"
+ ),
+ categ = list(
+ L1 = "MATRICES",
+ L2 = "MATRICES",
+ L3 = "FRAMES",
+ L4 = "CUTOFFS"
+ ),
+ legend.name = list(
+ L1 = "MATRICES",
+ L2 = "SIGNIF DOTS",
+ L3 = "FRAMES",
+ L4 = paste0(fun_round(ratio.limit.sig), " X CUTOFFS")
+ ),
+ color = list(
+ L1 = fun_gg_palette(2)[2],
+ L2 = "black",
+ L3 = "blue",
+ L4 = "orange"
+ ),
+ geom = list(
+ L1 = "geom_point",
+ L2 = "geom_point",
+ L3 = "geom_path",
+ L4 = "geom_hline"
+ ),
+ alpha = list(
+ L1 = 0.25,
+ L2 = 1,
+ L3 = 0.5,
+ L4 = 0.5
+ ),
+ dot.size = dot.size,
+ line.size = line.size,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.log = transfo,
+ x.lim = segm.x.range.pre,
+ y.lim = segm.y.range.pre,
+ y.lab = "RATIO",
+ y.tick.nb = 8,
+ title = tempo.title,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0.05,
+ x.right.extra.margin = 0.05,
+ y.top.extra.margin = 0.05,
+ y.bottom.extra.margin = 0.05
+ )
+} else{
+ tempo.title <-
+ paste0(
+ "SEGMENTATION OF THE MEAN / RATIO MATRIX CELLS\nTHEO MAT ALONE (NO THEO SIGNIFICANT DOTS)\n",
+ ifelse(
+ ratio.normalization == TRUE,
+ "THEO AND OBS RATIOS HAVE BEEN NORMALIZED (EACH CENTERED ON RATIO 1)\n",
+ ""
+ ),
+ if (transfo == "log2") {
+ "MEAN AND RATIO LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND RATIO LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(segm.x.range.pre, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(segm.y.range.pre, 2), collapse = " , "),
+ "\nCUT-OFFS DEFINED BY THE USER: ",
+ fun_round(ratio.cutoff.inf.pre),
+ " AND ",
+ fun_round(ratio.cutoff.sup.pre)
+ )
+ fun_gg_scatter(
+ data1 = list(
+ L1 = theo.df.pre,
+ L3 = segment.pre.serp$hframe,
+ L4 = data.frame(
+ y = c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre),
+ CUTOFFS = c("INF_LIMIT", "SUP_LIMIT")
+ )
+ ),
+ x = list(L1 = "MEAN", L3 = "MEAN", L4 = NULL),
+ y = list(L1 = "RATIO", L3 = "RATIO", L4 = "y"),
+ categ = list(L1 = "MATRICES", L3 = "FRAMES", L4 = "CUTOFFS"),
+ legend.name = list(
+ L1 = "MATRICES",
+ L3 = "FRAMES",
+ L4 = paste0(fun_round(ratio.limit.sig), " X CUTOFFS")
+ ),
+ color = list(L1 = fun_gg_palette(2)[2], L3 = "blue", L4 = "orange"),
+ geom = list(L1 = "geom_point", L3 = "geom_path", L4 = "geom_hline"),
+ alpha = list(L1 = 0.25, L3 = 0.5, L4 = 0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.log = transfo,
+ x.lim = segm.x.range.pre,
+ y.lim = segm.y.range.pre,
+ y.lab = "RATIO",
+ y.tick.nb = 8,
+ title = tempo.title,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0.05,
+ x.right.extra.margin = 0.05,
+ y.top.extra.margin = 0.05,
+ y.bottom.extra.margin = 0.05
+ )
+}
+
+if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+} else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+}
+if (!is.null(signif.obs.dot.pre)) {
+ # signif dots in obs matrices
+ tempo.title <-
+ paste0(
+ "SEGMENTATION OF THE MEAN / RATIO MATRIX CELLS\nOBS MAT ALONE + OBS SIGNIFICANT DOTS\n",
+ ifelse(
+ ratio.normalization == TRUE,
+ "THEO AND OBS RATIOS HAVE BEEN NORMALIZED (EACH CENTERED ON RATIO 1)\n",
+ ""
+ ),
+ if (transfo == "log2") {
+ "MEAN AND RATIO LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND RATIO LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(segm.x.range.pre, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(segm.y.range.pre, 2), collapse = " , "),
+ "\nCUT-OFFS DEFINED BY THE USER: ",
+ fun_round(ratio.cutoff.inf.pre),
+ " AND ",
+ fun_round(ratio.cutoff.sup.pre)
+ )
+ fun_gg_scatter(
+ data1 = list(
+ L1 = obs.df.pre,
+ L2 = signif.obs.dot.pre,
+ L3 = segment.pre.serp$hframe,
+ L4 = data.frame(
+ y = c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre),
+ CUTOFFS = c("INF_LIMIT", "SUP_LIMIT")
+ )
+ ),
+ x = list(
+ L1 = "MEAN",
+ L2 = "MEAN",
+ L3 = "MEAN",
+ L4 = NULL
+ ),
+ y = list(
+ L1 = "RATIO",
+ L2 = "RATIO",
+ L3 = "RATIO",
+ L4 = "y"
+ ),
+ categ = list(
+ L1 = "MATRICES",
+ L2 = "MATRICES",
+ L3 = "FRAMES",
+ L4 = "CUTOFFS"
+ ),
+ legend.name = list(
+ L1 = "MATRICES",
+ L2 = "SIGNIF DOTS",
+ L3 = "FRAMES",
+ L4 = paste0(fun_round(ratio.limit.sig),
+ " X CUTOFFS")
+ ),
+ color = list(
+ L1 = fun_gg_palette(2)[1],
+ L2 = "black",
+ L3 = "blue",
+ L4 = "orange"
+ ),
+ geom = list(
+ L1 = "geom_point",
+ L2 = "geom_point",
+ L3 = "geom_path",
+ L4 = "geom_hline"
+ ),
+ alpha = list(
+ L1 = 0.25,
+ L2 = 1,
+ L3 = 0.5,
+ L4 = 0.5
+ ),
+ dot.size = dot.size,
+ line.size = line.size,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.log = transfo,
+ x.lim = segm.x.range.pre,
+ y.lim = segm.y.range.pre,
+ y.lab = "RATIO",
+ y.tick.nb = 8,
+ title = tempo.title,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0.05,
+ x.right.extra.margin = 0.05,
+ y.top.extra.margin = 0.05,
+ y.bottom.extra.margin = 0.05
+ )
+} else{
+ tempo.title <-
+ paste0(
+ "SEGMENTATION OF THE MEAN / RATIO MATRIX CELLS\nOBS MAT ALONE (NO OBS SIGNIFICANT DOTS)\n",
+ ifelse(
+ ratio.normalization == TRUE,
+ "THEO AND OBS RATIOS HAVE BEEN NORMALIZED (EACH CENTERED ON RATIO 1)\n",
+ ""
+ ),
+ if (transfo == "log2") {
+ "MEAN AND RATIO LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND RATIO LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(segm.x.range.pre, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(segm.y.range.pre, 2), collapse = " , "),
+ "\nCUT-OFFS DEFINED BY THE USER: ",
+ fun_round(ratio.cutoff.inf.pre),
+ " AND ",
+ fun_round(ratio.cutoff.sup.pre)
+ )
+ fun_gg_scatter(
+ data1 = list(
+ L1 = obs.df.pre,
+ L3 = segment.pre.serp$hframe,
+ L4 = data.frame(
+ y = c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre),
+ CUTOFFS = c("INF_LIMIT", "SUP_LIMIT")
+ )
+ ),
+ x = list(L1 = "MEAN", L3 = "MEAN", L4 = NULL),
+ y = list(L1 = "RATIO", L3 = "RATIO", L4 = "y"),
+ categ = list(L1 = "MATRICES", L3 = "FRAMES", L4 = "CUTOFFS"),
+ legend.name = list(
+ L1 = "MATRICES",
+ L3 = "FRAMES",
+ L4 = paste0(fun_round(ratio.limit.sig), " X CUTOFFS")
+ ),
+ color = list(L1 = fun_gg_palette(2)[1], L3 = "blue", L4 = "orange"),
+ geom = list(L1 = "geom_point", L3 = "geom_path", L4 = "geom_hline"),
+ alpha = list(L1 = 0.25, L3 = 0.5, L4 = 0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.log = transfo,
+ x.lim = segm.x.range.pre,
+ y.lim = segm.y.range.pre,
+ y.lab = "RATIO",
+ y.tick.nb = 8,
+ title = tempo.title,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0.05,
+ x.right.extra.margin = 0.05,
+ y.top.extra.margin = 0.05,
+ y.bottom.extra.margin = 0.05
+ )
+}
+if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+} else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+}
+if (!is.null(signif.obs.dot.pre)) {
+ # signif dots in obs matrices
+ tempo.title <-
+ paste0(
+ "SEGMENTATION OF THE MEAN / RATIO MATRIX CELLS\nOBS AND THEO MAT + OBS SIGNIFICANT DOTS\n",
+ ifelse(
+ ratio.normalization == TRUE,
+ "THEO AND OBS RATIOS HAVE BEEN NORMALIZED (EACH CENTERED ON RATIO 1)\n",
+ ""
+ ),
+ if (transfo == "log2") {
+ "MEAN AND RATIO LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND RATIO LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(segm.x.range.pre, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(segm.y.range.pre, 2), collapse = " , "),
+ "\nCUT-OFFS DEFINED BY THE USER: ",
+ fun_round(ratio.cutoff.inf.pre),
+ " AND ",
+ fun_round(ratio.cutoff.sup.pre)
+ )
+ fun_gg_scatter(
+ data1 = list(
+ L1 = final.df.pre,
+ L2 = signif.obs.dot.pre,
+ L3 = segment.pre.serp$hframe,
+ L4 = data.frame(
+ y = c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre),
+ CUTOFFS = c("INF_LIMIT", "SUP_LIMIT")
+ )
+ ),
+ x = list(
+ L1 = "MEAN",
+ L2 = "MEAN",
+ L3 = "MEAN",
+ L4 = NULL
+ ),
+ y = list(
+ L1 = "RATIO",
+ L2 = "RATIO",
+ L3 = "RATIO",
+ L4 = "y"
+ ),
+ categ = list(
+ L1 = "MATRICES",
+ L2 = "MATRICES",
+ L3 = "FRAMES",
+ L4 = "CUTOFFS"
+ ),
+ legend.name = list(
+ L1 = "MATRICES",
+ L2 = "SIGNIF DOTS",
+ L3 = "FRAMES",
+ L4 = paste0(fun_round(ratio.limit.sig), " X CUTOFFS")
+ ),
+ color = list(
+ L1 = fun_gg_palette(2),
+ L2 = "black",
+ L3 = "blue",
+ L4 = "orange"
+ ),
+ geom = list(
+ L1 = "geom_point",
+ L2 = "geom_point",
+ L3 = "geom_path",
+ L4 = "geom_hline"
+ ),
+ alpha = list(
+ L1 = 0.25,
+ L2 = 1,
+ L3 = 0.5,
+ L4 = 0.5
+ ),
+ dot.size = dot.size,
+ line.size = line.size,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.log = transfo,
+ x.lim = segm.x.range.pre,
+ y.lim = segm.y.range.pre,
+ y.lab = "RATIO",
+ y.tick.nb = 8,
+ title = tempo.title,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0.05,
+ x.right.extra.margin = 0.05,
+ y.top.extra.margin = 0.05,
+ y.bottom.extra.margin = 0.05
+ )
+} else{
+ tempo.title <-
+ paste0(
+ "SEGMENTATION OF THE MEAN / RATIO MATRIX CELLS\nOBS AND THEO MAT (NO OBS SIGNIFICANT DOTS)\n",
+ ifelse(
+ ratio.normalization == TRUE,
+ "THEO AND OBS RATIOS HAVE BEEN NORMALIZED (EACH CENTERED ON RATIO 1)\n",
+ ""
+ ),
+ if (transfo == "log2") {
+ "MEAN AND RATIO LOG2(x) "
+ } else if (transfo == "log10") {
+ "MEAN AND RATIO LOG10(x) "
+ } else{
+ "NO LOG TRANSFORMATION"
+ },
+ "\nX SCALE RANGE: ",
+ paste(fun_round(segm.x.range.pre, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(segm.y.range.pre, 2), collapse = " , "),
+ "\nCUT-OFFS DEFINED BY THE USER: ",
+ fun_round(ratio.cutoff.inf.pre),
+ " AND ",
+ fun_round(ratio.cutoff.sup.pre)
+ )
+ fun_gg_scatter(
+ data1 = list(
+ L1 = final.df.pre,
+ L3 = segment.pre.serp$hframe,
+ L4 = data.frame(
+ y = c(ratio.cutoff.inf.pre, ratio.cutoff.sup.pre),
+ CUTOFFS = c("INF_LIMIT", "SUP_LIMIT")
+ )
+ ),
+ x = list(L1 = "MEAN", L3 = "MEAN", L4 = NULL),
+ y = list(L1 = "RATIO", L3 = "RATIO", L4 = "y"),
+ categ = list(L1 = "MATRICES", L3 = "FRAMES", L4 = "CUTOFFS"),
+ legend.name = list(
+ L1 = "MATRICES",
+ L3 = "FRAMES",
+ L4 = paste0(fun_round(ratio.limit.sig), " X CUTOFFS")
+ ),
+ color = list(L1 = fun_gg_palette(2),
+ L3 = "blue", L4 = "orange"),
+ geom = list(L1 = "geom_point", L3 = "geom_path", L4 = "geom_hline"),
+ alpha = list(L1 = 0.25, L3 = 0.5, L4 = 0.5),
+ dot.size = dot.size,
+ line.size = line.size,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ x.log = transfo,
+ x.lab = "MEAN",
+ x.tick.nb = 8,
+ y.log = transfo,
+ x.lim = segm.x.range.pre,
+ y.lim = segm.y.range.pre,
+ y.lab = "RATIO",
+ y.tick.nb = 8,
+ title = tempo.title,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0.05,
+ x.right.extra.margin = 0.05,
+ y.top.extra.margin = 0.05,
+ y.bottom.extra.margin = 0.05
+ )
+}
+# end plot verif obs dots outside
+# end MD overlay plot before serpentine
+
+
+# Mask of the obs data outside the cloud of the theo data on the MDMR plot (Mean Difference Mean Ratio)
+if (is.null(signif.obs.dot.pre)) {
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ fun_gg_empty_graph(
+ title = "PRE SERPENTINE MASK",
+ text = "NO MASK TO APPLY OVER HEATMAPS\nBECAUSE\n
+ NO SIGNIFICANT DOT DETECTED",
+ text.size = 3,
+ title.size = title.text.size
+ )
+ fun_report(
+ data = "NO MASK TO APPLY OVER HEATMAPS\nBECAUSE\n
+ NO SIGNIFICANT DOT DETECTED",
+ output = log.file,
+ path = "./"
+ )
+} else{
+ # file saving
+ sup.obs.mask.pre <-
+ matrix(0, nrow = nrow(mat1.obs), ncol = nrow(mat1.obs)) # matrix same dim as obs full of zero
+ inf.obs.mask.pre <-
+ matrix(0, nrow = nrow(mat1.obs), ncol = nrow(mat1.obs)) # matrix same dim as obs full of zero
+ if (nrow(sup.signif.obs.dot.pre) > 0) {
+ sup.obs.mask.pre[sup.signif.obs.dot.pre$coord_1D] <-
+ 1 # create the mask. If signif.obs.dot.pre is NULL, no 1 added
+ fun_report(
+ data = paste0(
+ "PRE SERPENTINE MAT2 > MAT1 MASK DATA SAVED IN: ",
+ "sup_mask_pre_serp.txt"
+ ),
+ output = log.file,
+ path = "./"
+ )
+ write.table(
+ sup.obs.mask.pre,
+ file = "sup_mask_pre_serp.txt",
+ row.names = FALSE,
+ col.names = FALSE,
+ append = FALSE,
+ quote = FALSE,
+ sep = "\t"
+ )
+ }
+ if (nrow(inf.signif.obs.dot.pre) > 0) {
+ inf.obs.mask.pre[inf.signif.obs.dot.pre$coord_1D] <-
+ 1 # create the mask. If signif.obs.dot.pre is NULL, no 1 added
+ fun_report(
+ data = paste0(
+ "PRE SERPENTINE MAT2 < MAT1 MASK DATA SAVED IN: ",
+ "inf_mask_pre_serp.txt"
+ ),
+ output = log.file,
+ path = "./"
+ )
+ write.table(
+ inf.obs.mask.pre,
+ file = "inf_mask_pre_serp.txt",
+ row.names = FALSE,
+ col.names = FALSE,
+ append = FALSE,
+ quote = FALSE,
+ sep = "\t"
+ )
+ }
+ obs.mask.pre <-
+ sup.obs.mask.pre + inf.obs.mask.pre # full mask matrix
+ fun_report(
+ data = paste0("PRE SERPENTINE FULL MASK DATA SAVED IN: ", "mask_pre_serp.txt"),
+ output = log.file,
+ path = "./"
+ )
+ write.table(
+ inf.obs.mask.pre,
+ file = "mask_pre_serp.txt",
+ row.names = FALSE,
+ col.names = FALSE,
+ append = FALSE,
+ quote = FALSE,
+ sep = "\t"
+ )
+ # end file saving
+
+ # heatmaps
+ if (transfo != "no") {
+ tempo.mat1.obs.norm <- "mat1.obs.norm.trans"
+ tempo.mat2.obs.norm <- "mat2.obs.norm.trans"
+ tempo.obs.ratio.mat.norm <- "obs.ratio.mat.norm.trans"
+ } else{
+ tempo.mat1.obs.norm <- "mat1.obs.norm"
+ tempo.mat2.obs.norm <- "mat2.obs.norm"
+ tempo.obs.ratio.mat.norm <- "obs.ratio.mat.norm"
+ }
+ if (nrow(sup.signif.obs.dot.pre) > 0) {
+ mask.plot.fun(
+ mask_4fun = sup.obs.mask.pre,
+ mat1_4fun = get(tempo.mat1.obs.norm),
+ mat2_4fun = get(tempo.mat2.obs.norm),
+ diff.mat_4fun = get(tempo.obs.ratio.mat.norm),
+ serp_kind_4fun = "BEFORE",
+ mask_kind_4fun = "POSITIVE (MAT2 > MAT1)",
+ text_4fun = "",
+ heatmap.range_4fun = s.obs.heatmap.range.norm.pre,
+ diff.heatmap.range_4fun = diff.both.heatmap.range.norm.pre,
+ activate.pdf_4fun = activate.pdf,
+ pdf.nb_4fun = pdf.nb,
+ width.wind_4fun = width.wind,
+ height.wind_4fun = height.wind,
+ dot.size_4fun = dot.size,
+ text.size_4fun = text.size,
+ title.text.size_4fun = title.text.size,
+ raster_4fun = raster,
+ transfo_4fun = transfo,
+ ratio.limit.sig_4fun = ratio.limit.sig,
+ line.size_4fun = line.size,
+ heatmap.text.size_4fun = heatmap.text.size
+ )
+ } else{
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ fun_gg_empty_graph(
+ title = "PRE SERPENTINE MASK",
+ text = "NO MASK TO APPLY OVER HEATMAPS\nBECAUSE\n
+ NO MAT2 > MAT1 SIGNIFICANT DOTS DETECTED",
+ text.size = 3,
+ title.size = title.text.size
+ )
+ fun_report(data = "NO MASK TO APPLY OVER HEATMAPS\nBECAUSE\nNO MAT2 > MAT1 SIGNIFICANT DOTS DETECTED",
+ output = log.file,
+ path = "./")
+ }
+
+ if (nrow(inf.signif.obs.dot.pre) > 0) {
+ mask.plot.fun(
+ mask_4fun = inf.obs.mask.pre,
+ mat1_4fun = get(tempo.mat1.obs.norm),
+ mat2_4fun = get(tempo.mat2.obs.norm),
+ diff.mat_4fun = get(tempo.obs.ratio.mat.norm),
+ serp_kind_4fun = "BEFORE",
+ mask_kind_4fun = "NEGATIVE (MAT2 < MAT1)",
+ text_4fun = "",
+ heatmap.range_4fun = s.obs.heatmap.range.norm.pre,
+ diff.heatmap.range_4fun = diff.both.heatmap.range.norm.pre,
+ activate.pdf_4fun = activate.pdf,
+ pdf.nb_4fun = pdf.nb,
+ width.wind_4fun = width.wind,
+ height.wind_4fun = height.wind,
+ dot.size_4fun = dot.size,
+ text.size_4fun = text.size,
+ title.text.size_4fun = title.text.size,
+ raster_4fun = raster,
+ transfo_4fun = transfo,
+ ratio.limit.sig_4fun = ratio.limit.sig,
+ line.size_4fun = line.size,
+ heatmap.text.size_4fun = heatmap.text.size
+ )
+ } else{
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ fun_gg_empty_graph(
+ title = "PRE SERPENTINE MASK",
+ text = "NO MASK TO APPLY OVER HEATMAPS\nBECAUSE\n
+ NO MAT2 < MAT1 SIGNIFICANT DOTS DETECTED",
+ text.size = 3,
+ title.size = title.text.size
+ )
+ fun_report(data = "NO MASK TO APPLY OVER HEATMAPS\nBECAUSE\nNO MAT2 < MAT1 SIGNIFICANT DOTS DETECTED",
+ output = log.file,
+ path = "./")
+ }
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+
+ mask.plot.fun(
+ mask_4fun = obs.mask.pre,
+ mat1_4fun = get(tempo.mat1.obs.norm),
+ mat2_4fun = get(tempo.mat2.obs.norm),
+ diff.mat_4fun = get(tempo.obs.ratio.mat.norm),
+ serp_kind_4fun = "BEFORE",
+ mask_kind_4fun = "FULL",
+ text_4fun = "",
+ heatmap.range_4fun = s.obs.heatmap.range.norm.pre,
+ diff.heatmap.range_4fun = diff.both.heatmap.range.norm.pre,
+ activate.pdf_4fun = activate.pdf,
+ pdf.nb_4fun = pdf.nb,
+ width.wind_4fun = width.wind,
+ height.wind_4fun = height.wind,
+ dot.size_4fun = dot.size,
+ text.size_4fun = text.size,
+ title.text.size_4fun = title.text.size,
+ raster_4fun = raster,
+ transfo_4fun = transfo,
+ ratio.limit.sig_4fun = ratio.limit.sig,
+ line.size_4fun = line.size,
+ heatmap.text.size_4fun = heatmap.text.size
+ )
+ # end heatmaps
+}
+if (keep == FALSE) {
+ tempo.list <-
+ c("obs.mask.pre", "sup.obs.mask.pre", "inf.obs.mask.pre")
+ tempo.cat <-
+ paste0(
+ "PRE SERPENTINE SLITHERINE MASK MATRICES SAVED IN: ",
+ "",
+ paste0(tempo.list, collapse = "_"),
+ "_backup.RData"
+ )
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ save(
+ list = tempo.list,
+ file = "",
+ paste0(tempo.list, collapse = "_"),
+ "_backup.RData"
+ )
+ rm(list = tempo.list) # not saved because initial matrices
+}
+
+print("end signif diff pre-serp")
+################ end significant differences pre serpentine (SLITHERINE)
+
+
+################ significant differences pre serpentine (HIC COMPARE)
+
+
+# see https://bioconductor.org/packages/release/bioc/manuals/HiCcompare/man/HiCcompare.pdf
+# In https://bioconductor.org/packages/devel/bioc/vignettes/HiCcompare/inst/doc/HiCcompare-vignette.html, it is written: "For use in HiCcompare you want the raw data so you should selected NONE. The second argument is the .hic file name. Next is the chromosome numbers of the matrix you want. For an intrachromosomal contact map both should be the same as in the above example. If you want a matrix of interchromosomal interactions you can use different chromosomes i.e. interactions between chromosome 1 and chromosome 2 (Note that HiCcompare is only meant to be used on intrachromosomal interactions at this point in development)."
+# Thus, HiC compare needs raw read number, not normalized !
+
+if (hiccomp == TRUE) {
+ cat("\nSIGNIFICANT DIFFERENCES PRE SERPENTINE (HIC COMPARE)\n")
+ fun_report(
+ data = "\n\n################################ SIGNIFICANT DIFFERENCES PRE SERPENTINE (HIC COMPARE)",
+ path = "./",
+ output = log.file,
+ sep = 4
+ )
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ fun_gg_empty_graph(text = "SIGNIFICANT DIFFERENCES PRE SERPENTINE\n(HIC COMPARE)", text.size = 3)
+ # p values computations
+ sparse.name.pre <-
+ cumsum(c(0, rep(binning, ncol(mat1.obs) - 1)))
+ mat1.obs.sparse.pre <- mat1.obs
+ mat2.obs.sparse.pre <- mat2.obs
+ fun_report(
+ data = paste0(
+ "NON NORMALIZED OBS CELL RATIO MATRICES USED FOR HIC COMPARE,
+ AS DEFINED BY THE HIC COMPARE MANUAL (THUS, ratio.normalization PARAMETER SETTING NOT RESPECTED FOR HIC COMPARE"
+ ),
+ output = log.file,
+ path = "./"
+ ) # ratio of mat2.obs.norm / mat1.obs.norm is equivalent to obs.ratio.mat / obs.ratio.factor
+ print("koko ?")
+
+ # names of the matrices to use for heatmaps
+ if (transfo != "no") {
+ mat1.obs.for.plot <- "mat1.obs.norm.trans"
+ mat2.obs.for.plot <- "mat2.obs.norm.trans"
+ obs.ratio.mat.for.plot <-
+ "obs.ratio.mat.norm.trans" # non normalized if ratio.normalization = FALSE
+
+ } else{
+ mat1.obs.for.plot <- "mat1.obs.norm"
+ mat2.obs.for.plot <- "mat2.obs.norm"
+ obs.ratio.mat.for.plot <-
+ "obs.ratio.mat.norm" # non normalized if ratio.normalization = FALSE
+ }
+ print("kono ato dayone")
+ # end names of the matrices to use for heatmaps
+ colnames(mat1.obs.sparse.pre) <- sparse.name.pre
+
+ mat1.obs.sparse.pre <-
+ HiCcompare::full2sparse(mat1.obs.sparse.pre)
+
+ colnames(mat2.obs.sparse.pre) <- sparse.name.pre
+
+ mat2.obs.sparse.pre <-
+ HiCcompare::full2sparse(mat2.obs.sparse.pre)
+
+ hic.table.pre <-
+ HiCcompare::create.hic.table(mat1.obs.sparse.pre, mat2.obs.sparse.pre, chr = "chr5") # chr must be filled, thus I put anything
+ print("doko ?")
+ tempo.warning <-
+ fun_get_message(data = "HiCcompare::hic_loess(hic.table.pre)",
+ kind = "warning",
+ text = "IN HiCcompare::hic_loess FUNCTION OF SLITHERINE")
+
+ warning.message <-
+ paste0(warning.message, ifelse(is.null(warning.message), "", "\n"), tempo.warning) #
+
+ norm.hic.table.pre <-
+ suppressMessages(suppressWarnings(HiCcompare::hic_loess(hic.table.pre))) # see the help of the hic_loess() function for the description of the returned table
+
+ diff.res.pre <-
+ suppressMessages(HiCcompare::hic_compare(norm.hic.table.pre))
+ diff.res.pre <- as.data.frame(diff.res.pre)
+ diff.res.pre <-
+ data.frame(diff.res.pre, PVAL_MASK = 0L, PADJ_MASK = 0L) # add two columns to make the mask matrices
+ print("naze ?")
+ tempo.log.pvalue <- diff.res.pre$p.value <= 0.05
+ tempo.log.padj <- diff.res.pre$p.adj <= 0.05
+
+ if (sum(tempo.log.pvalue, na.rm = TRUE) > 0) {
+ diff.res.pre$PVAL_MASK[tempo.log.pvalue] <- 1
+ }
+ print("wakaran")
+ if (sum(tempo.log.padj, na.rm = TRUE) > 0) {
+ diff.res.pre$PADJ_MASK[tempo.log.padj] <- 1
+ }
+
+ print("ta")
+ # end p values computations
+ # loess transformation plot
+ # below section is equivalent to suppressMessages(HiCcompare::MD.plot1(M = diff.res.pre$M, D = diff.res.pre$D, mc = diff.res.pre$mc, smooth = FALSE))
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ tempo.data.plot <-
+ data.frame(
+ DISTANCE = diff.res.pre$D,
+ RATIO = diff.res.pre$M,
+ ADJ_RATIO = diff.res.pre$adj.M,
+ LOESS = diff.res.pre$mc
+ ) # BEWARE RATIO laready log2
+ x.range.dist <-
+ range(tempo.data.plot$DISTANCE,
+ na.rm = TRUE,
+ finite = TRUE)
+ y.range.ratio <-
+ range(tempo.data.plot$RATIO, na.rm = TRUE, finite = TRUE)
+ tempo.title <-
+ paste0(
+ "OBS MATRICES\nMD PLOT FROM THE HICCOMPARE TABLE AND LOESS CURVE (ORANGE LINE)\n
+ RATIO, CELL RATIO BETWEEN THE TWO OBS MATRICES; DISTANCE,
+ CELL DISTANCE FROM THE MAIN DIAG (IN NB OF CELLS)\nRATIO IS LOG2(x) TRANSFORMED\n
+ X SCALE RANGE: ",
+ paste(fun_round(x.range.dist, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(y.range.ratio, 2), collapse = " , ")
+ )
+ print("su")
+ fun_gg_scatter(
+ data1 = list(L1 = tempo.data.plot[, c("DISTANCE", "RATIO")],
+ L2 = tempo.data.plot[, c("DISTANCE", "LOESS")]),
+ x = list(L1 = "DISTANCE",
+ L2 = "DISTANCE"),
+ y = list(L1 = "RATIO",
+ L2 = "LOESS"),
+ categ = NULL,
+ color = list(L1 = grey(0.20),
+ L2 = "orange"),
+ geom = list(L1 = "geom_point",
+ L2 = "geom_line"),
+ legend.name = NULL,
+ alpha = list(0.2, 1),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.log = "no",
+ x.lab = "DISTANCE (D)",
+ x.tick.nb = 8,
+ y.log = "log2",
+ y.lab = "RATIO (M)",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0.05,
+ x.right.extra.margin = 0.05,
+ y.top.extra.margin = 0.05,
+ y.bottom.extra.margin = 0.05
+ ) #
+ print("ke")
+ if (activate.pdf == TRUE) {
+ invisible(dev.set(pdf.nb))
+ } else{
+ fun_open(pdf.disp = activate.pdf,
+ width.fun = width.wind,
+ height.fun = height.wind)
+ }
+ # x.range.dist <- range(tempo.data.plot$DISTANCE, na.rm = TRUE, finite = TRUE) # already computed
+ y.range.ratio.adj <-
+ range(tempo.data.plot$ADJ_RATIO,
+ na.rm = TRUE,
+ finite = TRUE)
+ tempo.title <-
+ paste0(
+ "OBS MATRICES\nMD PLOT FROM THE HICCOMPARE TABLE AFTER LOESS ADJUSTMENT\n
+ ADJUSTED RATIO, LOESS ADJUSTED CELL RATIO BETWEEN THE TWO OBS MATRICES; DISTANCE,
+ CELL DISTANCE FROM THE MAIN DIAG (IN NB OF CELLS)\nRATIO IS LOG2(x) TRANSFORMED\n
+ X SCALE RANGE: ",
+ paste(fun_round(x.range.dist, 2), collapse = " , "),
+ "\nY SCALE RANGE: ",
+ paste(fun_round(y.range.ratio.adj, 2), collapse = " , ")
+ )
+ print("te")
+ fun_gg_scatter(
+ data1 = list(
+ L1 = tempo.data.plot[, c("DISTANCE", "ADJ_RATIO")],
+ L2 = data.frame(DISTANCE = tempo.data.plot["DISTANCE"], ADJ_LOESS = 0)
+ ),
+ x = list(L1 = "DISTANCE",
+ L2 = "DISTANCE"),
+ y = list(L1 = "ADJ_RATIO",
+ L2 = "ADJ_LOESS"),
+ categ = NULL,
+ color = list(L1 = grey(0.20),
+ L2 = "orange"),
+ geom = list(L1 = "geom_point",
+ L2 = "geom_line"),
+ legend.name = NULL,
+ alpha = list(L1 = 0.2,
+ L2 = 1),
+ dot.size = dot.size,
+ line.size = line.size,
+ x.log = "no",
+ x.lab = "DISTANCE (D)",
+ x.tick.nb = 8,
+ y.log = "log2",
+ y.lab = "RATIO (M)",
+ y.tick.nb = 8,
+ title = tempo.title,
+ text.size = text.size,
+ title.text.size = title.text.size,
+ article = TRUE,
+ legend.width = NULL,
+ raster = raster,
+ x.left.extra.margin = 0.05,
+ x.right.extra.margin = 0.05,
+ y.top.extra.margin = 0.05,
+ y.bottom.extra.margin = 0.05
+ ) #
+ # end loess transformation plot
+ print("kokkara ga mondai deshou")
+ # non adjusted p value graphs
+ hiccomp.pvalue.mask.pre <- hiccompare.graphs.fun(
+ hictable_5fun = diff.res.pre,
+ mat1_5fun = get(mat1.obs.for.plot),
+ mat2_5fun = get(mat2.obs.for.plot),
+ ratio.mat_5fun = get(obs.ratio.mat.for.plot),
+ df_5fun = obs.df.pre,
+ serp.kind_5fun = "BEFORE",
+ pvalue.text_5fun = "NON ADJUSTED",
+ pvalue.col_5fun = "p.value",
+ sparse.name_5fun = sparse.name.pre,
+ text_5fun = "",
+ heatmap.range_5fun = s.obs.heatmap.range.norm.pre,
+ # this already integrates normalization and potential log transformation
+ diff.heatmap.range_5fun = diff.both.heatmap.range.norm.pre,
+ # this already integrates potential normalization and log transformation
+ ratio.cutoff.inf_5fun = ratio.cutoff.inf.pre,
+ ratio.cutoff.sup_5fun = ratio.cutoff.sup.pre,
+ activate.pdf_5fun = activate.pdf,
+ pdf.nb_5fun = pdf.nb,
+ width.wind_5fun = width.wind,
+ height.wind_5fun = height.wind,
+ dot.size_5fun = dot.size,
+ text.size_5fun = text.size,
+ title.text.size_5fun = title.text.size,
+ raster_5fun = raster,
+ transfo_5fun = transfo,
+ ratio.limit.sig_5fun = ratio.limit.sig,
+ line.size_5fun = line.size,
+ heatmap.text.size_5fun = heatmap.text.size
+ )
+ if (!is.null(hiccomp.pvalue.mask.pre)) {
+ # no mask finally
+ # file saving
+ fun_report(
+ data = paste0(
+ "PRE SERPENTINE FULL MASK DATA SAVED IN: ",
+ "hicc_mask_pre_serp.txt"
+ ),
+ output = log.file,
+ path = "./"
+ )
+ write.table(
+ hiccomp.pvalue.mask.pre,
+ file = "hicc_pvalue_mask_pre_serp.txt",
+ row.names = FALSE,
+ col.names = FALSE,
+ append = FALSE,
+ quote = FALSE,
+ sep = "\t"
+ )
+ # end file saving
+ }
+ # end non adjusted p value graphs
+ # adjusted p value graphs
+ hiccomp.padj.mask.pre <- hiccompare.graphs.fun(
+ hictable_5fun = diff.res.pre,
+ mat1_5fun = get(mat1.obs.for.plot),
+ mat2_5fun = get(mat2.obs.for.plot),
+ ratio.mat_5fun = get(obs.ratio.mat.for.plot),
+ df_5fun = obs.df.pre,
+ serp.kind_5fun = "BEFORE",
+ pvalue.text_5fun = "ADJUSTED",
+ pvalue.col_5fun = "p.adj",
+ sparse.name_5fun = sparse.name.pre,
+ text_5fun = "",
+ heatmap.range_5fun = s.obs.heatmap.range.norm.pre,
+ # this already integrates normalization and potential log transformation
+ diff.heatmap.range_5fun = diff.both.heatmap.range.norm.pre,
+ # this already integrates potential normalization and log transformation
+ ratio.cutoff.inf_5fun = ratio.cutoff.inf.pre,
+ ratio.cutoff.sup_5fun = ratio.cutoff.sup.pre,
+ activate.pdf_5fun = activate.pdf,
+ pdf.nb_5fun = pdf.nb,
+ width.wind_5fun = width.wind,
+ height.wind_5fun = height.wind,
+ dot.size_5fun = dot.size,
+ text.size_5fun = text.size,
+ title.text.size_5fun = title.text.size,
+ raster_5fun = raster,
+ transfo_5fun = transfo,
+ ratio.limit.sig_5fun = ratio.limit.sig,
+ line.size_5fun = line.size,
+ heatmap.text.size_5fun = heatmap.text.size
+ )
+ if (!is.null(hiccomp.padj.mask.pre)) {
+ # no mask finally
+ # file saving
+ fun_report(
+ data = paste0(
+ "PRE SERPENTINE FULL MASK DATA SAVED IN: ",
+ "hicc_mask_pre_serp.txt"
+ ),
+ output = log.file,
+ path = "./"
+ )
+ write.table(
+ hiccomp.padj.mask.pre,
+ file = "hicc_padj_mask_pre_serp.txt",
+ row.names = FALSE,
+ col.names = FALSE,
+ append = FALSE,
+ quote = FALSE,
+ sep = "\t"
+ )
+ # end file saving
+ }
+ # end adjusted p value graphs
+ if (keep == FALSE) {
+ tempo.list <-
+ c(
+ "mat1.obs.sparse.pre",
+ "mat2.obs.sparse.pre",
+ "diff.res.pre",
+ "hiccomp.pvalue.mask.pre",
+ "hiccomp.padj.mask.pre"
+ )
+ tempo.cat <- "PRE SERPENTINE HIC COMPARE DATA SAVED IN: pre_serp_hiccomp_backup.RData"
+ fun_report(data = tempo.cat,
+ output = log.file,
+ path = "./")
+ save(list = tempo.list, file = "pre_serp_hiccomp_backup.RData")
+ rm(list = tempo.list) # not saved because initial matrices
+ }
+}
+
+loop.mat.names <- c("mat1.mix", "mat2.mix")
+print("kokomade korenssho")
+
+
+
+for (i0 in 1:length(loop.mat.names)) {
+ write.table(
+ get(loop.mat.names[i0]),
+ file = paste0("mat", i0, ".theo.txt"),
+ row.names = FALSE,
+ col.names = FALSE,
+ append = FALSE,
+ quote = FALSE,
+ sep = "\t"
+ )
+}
+
+
+
+################ Pdf window closing
+
+
+graphics.off()
+
+
+################ end Pdf window closing
+
+
+################ Seeding inactivation
+
+
+set.seed(NULL)
+
+
+################ end Seeding inactivation
+
+
+################ Environment saving
+
+
+save(list = ls(), file = "./all_objects.RData")
+fun_report(data = paste0("\n\n################################ RUNNING END"), output = log.file, path = "./")
+end.date <- Sys.time()
+end.time <- as.numeric(end.date)
+total.lapse <- round(lubridate::seconds_to_period(end.time - ini.time))
+fun_report(data = paste0("\n\nEND TIME: ", end.date), output = log.file, path = "./")
+fun_report(data = paste0("\n\nTOTAL TIME LAPSE: ", total.lapse), output = log.file, path = "./")
+fun_report(data = paste0("\n\nALL DATA SAVED IN all_objects.RData"), output = log.file, path = "./")
+
+
+################ end Environment saving
+
+
+################ Warning messages
+
+
+fun_report(data = paste0("\n\n################################ RECAPITULATION OF WARNING MESSAGES"), output = log.file, path = "./")
+if( ! is.null(warning.message)){
+ tempo.cat <- paste0("IN slitherine_part1.R OF THE NEXFLOW EXECUTION:\n\n", warning.message)
+ fun_report(data = tempo.cat, output = log.file, path = "./")
+ cat(tempo.cat)
+}else{
+ fun_report(data = paste0("\n\nNO WARNING MESSAGE TO REPORT"), output = log.file, path = "./")
+}
+on.exit(exp = options(warning.length = ini.warning.length), add = TRUE)
+
+
+
+################ end Warning messages
+
+
+################ Parameter printing
+
+
+fun_report(data = paste0("\n\n################################ INITIAL SETTINGS OF PARAMETERS"), output = log.file, path = "./")
+fun_report(data = param.ini.settings, output = log.file, path = "./", , vector.cat = TRUE)
+fun_report(data = paste0("\n\n################################ R SYSTEM AND PACKAGES"), output = log.file, path = "./")
+tempo <- sessionInfo()
+tempo$otherPkgs <- tempo$otherPkgs[order(names(tempo$otherPkgs))] # sort the packages
+tempo$loadedOnly <- tempo$loadedOnly[order(names(tempo$loadedOnly))] # sort the packages
+fun_report(data = tempo, output = log.file, path = "./", , vector.cat = TRUE)
+fun_report(data = paste0("\n\n################################ JOB END\n\nTIME: ", end.date, "\n\nTOTAL TIME LAPSE: ", total.lapse, "\n"), output = log.file, path = "./")
+
+
+################ end Parameter printing
+
+
+################################ End Main code
diff --git a/slitherine.config b/slitherine.config
index b1cfeb0957d5c8482023ebbc99d42377aaaab0ef..a4e57e16d9bf70d9f83c13b0140fc7b374a7f589 100644
--- a/slitherine.config
+++ b/slitherine.config
@@ -7,8 +7,8 @@
## Slitherine ##
## ##
## Mia Legras ##
+## Gael A. Millot ##
## Bioinformatics and Biostatistics Hub ##
-## Computational Biology Department ##
## Institut Pasteur Paris ##
## ##
#########################################################################
@@ -22,65 +22,91 @@
#########################################################################
*/
+// THEO1 and THEO2 matrices are synthetic matrices that are computed by slitherine using data from the 2 oberved matrices. These theoretical matrices are used to define significant difference between the two observed matrices (i.e., pixel difference far from random fluctuations). Each THEO1 and THEO2 matrix are made of n colums, each column of THEO1 representing the diagonales of OBS1, and each column of THEO2 representing the diagonales of OBS2. Thus, the number of colums of column in THEO1 and THEO2 is defined by the dimension of the observed matrices. Now the number of rows of THEO1 and THEO2, set by the n.row parameter (see below), is a variable associated to power of the significance. Greater n.row is, greater is the puissance but longer is slitherine to achieve a run, in particularly during the permutation process. Of note, In observed matrices, if the dimension is 4, 4 (square matrix) the first diagonal (main diagonal) is made of 4 values, and the last diagonal (corner diagonal) of 1 value. In theoretical matrices, such number of value is constant among the different columns representing the diagonals of the observed matrices
+
+
+///////// TODO
+// lib_path : deal with the fact that it could have several pathes. But If I rewrite with parallelization by nextfolw and not R, I do not it it anymore.
+
+
+/*
+##########################
+## ##
+## Slitherine ##
+## ##
+##########################
+*/
env {
- project_name = "slitherine"
- //// path and files
- lib_path = "NULL"
- in_path = "/home/gael/slitherine/slitherine-commit-145/dataset"
- out_path = "/home/gael/slitherine/slitherine-commit-145/result"
- matrix_file1 = "AT_Dndj1_D_T0.filt.2500.rebin_1162-1388.txt"
- matrix_file2 = "AT200_Aurel_T6.filt.2500.rebin_1162-1388.txt"
- serp_binning = true
- thr_tot = '70'
- thr_min = '7'
+ // path and files
+ lib_path = "NULL_1" // single character strings that define the absolute pathway of the folders containing the R packages (separated by a single space). Write "NULL_1" for the default path. BEWARE: default path is dependent on the system and interface used. For instance, using cygwin64 on windows 7, the path is "C:/Program Files/R/R-3.5.3/library". On the same computer using the R classical interface, the paths are lib_path = "C:/Users/Gael/Documents/R/win-library/3.5 C:/Program Files/R/R-3.5.3/library"
+ in_path = "/home/gael/slitherine/slitherine-commit-145/dataset" // single character string of the absolute pathway of the folder containing the input data files (file.name1 and file.name2)
+ out_path = "/home/gael/slitherine/slitherine-commit-145/result" // single character string of the absolute pathway of the destination folder that will contain the results (exported data)
+
+ matrix_file1 = "AT_Dndj1_D_T0.filt.2500.rebin_1162-1388.txt" // single character string of the name of the first matrix file
+ matrix_file2 = "AT200_Aurel_T6.filt.2500.rebin_1162-1388.txt" // single character string of the name of the second matrix file
+
+ theo_path_in = "NULL_2" // single character string of the absolute pathway of the folder containing the input data files (theo_file_name1 and theo_file_name2). Write "NULL_2" if not required
+ theo_file_name1 = "mat1.theo.serp.txt" // single character string of the name of the first theo matrix file associated to the first observed matrix. Ignored if theo_path_in is "NULL_3"
+ theo_file_name2 = "mat2.theo.serp.txt" // single character string of the name of the first theo matrix file associated to the second observed matrix. Ignored if theo_path_in is "NULL_4"
+
+ // other path and files
+ path_function1 = "https://gitlab.pasteur.fr/gmillot/cute_little_R_functions/-/raw/c1dd8832f14d76c1901a60ca2a7c87af01a82b61/cute_little_R_functions.R" // single character string of the file (and absolute pathway) of the required cute_little_R_functions toolbox. With ethernet connection available, this can also be used: "https://gitlab.pasteur.fr/gmillot/cute_little_R_functions/raw/v5.1.0/cute_little_R_functions.R"
+ adj_mean = "$projectDir/bin/adj_mean.R" // single character string of the adj_mean.R file (and absolute pathway)
+ hiccompare_graph = "$projectDir/bin/hiccompare_graph.R" // single character string of the hiccompare_graph.R file (and absolute pathway)
+ intern_funct_check = "$projectDir/bin/intern_funct_check.R" // single character string of the intern_funct_check.R file (and absolute pathway)
+ mask_plot = "$projectDir/bin/mask_plot.R" // single character string of the mask_plot.R file (and absolute pathway)
+ //// end path and files
+
+ path_cv_rho = "NULL_5" // single character string of the name and path of the cv1_cv2_rho1_rho2_backup.RData file of the coefficient of variation (cv) of observed matrices 1 and 2, as well as correlation between observed matrices 1 and 2 already obtained. Write "NULL_5" if not required (not already obtained)
+ path_theo1_theo2 = "NULL_6" // single character string of the permut_mat1_mat2_backup.RData file and absolute pathway of the theoretical matrix with permutation already obtained. Write "NULL_6" if not required
+
+ project_name = "slitherine" // single character string of the projet name
// matrix struct
- empty_cell_string = 0 // if the imported matrix are half filled, put here the character string ("-" for instance) or number (0 for instance) or reserved R word (NA for instance) used to fill the empty part of the matrix. Slitherine will automatically complete the imported matrix. Write NULL if the imported matrix are not half empty
- thread_nb = "NULL" // Integer specifying th
+ empty_cell_string = "0" // single character string of the character used in matrices for emty cell. If the imported matrix are half filled, put here the character string ("-" for instance) or number ("0" for instance) or reserved R word ("NA" for instance) used to fill the empty part of the matrix. Slitherine will automatically complete the imported matrix. Write "NULL" if the imported matrix are not half empty
+ thread_nb = "NULL" // single character string of the integer specifying the number of threads available. BEWARE: it is possible to have several threads per cpu (https://en.wikipedia.org/wiki/Thread_(computing)). Slitherine can parallelized some part of its job (including serpentine job) using thread.nb to speed up the run. If NULL, slitherine will take the number of threads available - 1. If non null, will use thread.nb if thread.nb <= number of threads available and number of threads available otherwise// Integer specifying th
// HiCcompare
- hiccomp = false
- binning = 2500
+ hiccomp = "FALSE" // WARNING. For the moment, cannot be TRUE. single character string indicating if HICcompare is required. Either "TRUE" or "FALSE". See https://bioconductor.org/packages/release/bioc/manuals/HiCcompare/man/HiCcompare.pdf. If TRUE, the binning parameter must be non null
+ binning = "2500" // single character string of the integer that specifies the binning size of the imported matrices (in bp). If NULL, Hic Compare cannot be used
+
+ // Serpentine
+ serp_binning = "TRUE" // single character string indicating if serpentine binning is required. Either "TRUE" or "FALSE"
+ thr_tot = '70' // single character string of the positive numeric value indicating the serpentine threshold parameter
+ thr_min = '7' // single character string of the positive numeric value indicating the serpentine min threshold parameter
+ iter_nb = "128" // single character string of the total serpentine iteration number parameter (this number will be split by thread.nb parameter, by progressively decreasing thread.nb til serp.iter.nb %% thread.nb != 0 (to have the same serp.iter.nb per thread)
+ serp_symmet_input = "TRUE" // single character string indicating if input matrices are symmetric. Either "TRUE" or "FALSE"
+
// Theor matrix comput
- theo_import = false
- theo_file_name1 = "mat1.theo.serp.txt"
- theo_file_name2 = "mat2.theo.serp.txt"
- theo_path_in = "${in_path}"
- n_row = 300
- win_size = 20
- cv_rho_obtained = false
- path_cv_rho = "NULL" //cv1_cv2_rho1_rho2_backup.RData <- option
- correl_mat_obtained = false
- path_theo1_theo2 = "NULL" //permut_mat1_mat2_backup.RData <- option
- single_corr = "MAX" // either "VALUE", "MAX", "DEC1", "QUART1", "MED", "MIN" or "NO" abs.corr.limit <- 0.2 # parameter used when single_corr <- "VALUE" or single_corr <- "NO". See the single_corr parameter description
- print_count = 1e6
- keep = true
- // Signif regions between the 2 compared matrices
- ratio_limit_sig = 2
- error = 0 // from 0 to 1.
- range_split = 25
- step_factor = 10
- ratio_normalization = true
+ n_row = "300" // single character string of the integer value setting the number of rows of the theoretical matrices. If "NULL", n_row will take as value the number of column of the theoretical matrices
+ win_size = "20" // single character string of the positive integer indicating the nb of cv values taken in the sliding windows on the CV / MEAN plot to define an average cv at the rupture slope on the CV / MEAN plot (must be less than matrix dimension - 2). Increase this value if warning messages appears saying: "PARAMETER MUST BE SUCH THAT cv^2 > 1/mu"
+
+
+
+ single_corr = "MAX" // either "VALUE", "MAX", "DEC1", "QUART1", "MED", "MIN" or "NO" # use MAX by default. if VALUE, a unique arbitrary value, defined in the abs.corr.limit parameter below, is used as reference to generate the correlation between the related diagonals of the theoretical theo1 and theo2 matrices (all the correlations between theo1 and theo2 diagonals will be close to abs.corr.limit). If MAX, the maximal correlation value between the observed mat1 and mat2 matrix diagonals will be used to generate the correlation between the related diagonals of theo1 and theo2 matrices (all the correlations between theo1 and theo2 diagonals will be close to max(rho1)). If DEC1, QUART1 MED or MIN, the same as MAX but using the first decile, first quartile, median or minimal correlation value between the observed mat1 and mat2 matrix diagonals, respectively. If NO, each of the observed correlations between the related diagonals of the mat1 and mat2 matrices will be used to generate the correlation of the corresponding theo1 and theo2 diagonal. In the case of NO, any observed correlation below the abs.corr.limit parameter will be set to abs.corr.limit (to avoid very long computing needed for very weak correlations)
+ abs_corr_limit = "0.2" // single character string of the positive proportion used when single.corr <- "VALUE" or single.corr <- "NO". See the single.corr parameter description
+ print_count = "1000000" // single character string of the positive integer number of loop performed before printing the correlation adjustment process (print a message every print_count)
+ keep = "TRUE" // single character string indicating if the intermediate matrices and big objects in the working environment must be kept til the end? Either "TRUE" or "FALSE". If "TRUE", everything is saved in the final all_objects.RData. If "FALSE", intermediate matrices are saved in different .RData files and then removed all along the script execution
+ ratio_limit_sig = "2" // single character string of the positive numeric ratio value between the two matrice pixel, below which ratio is not significant? From 1 to +Inf (2 means coverage ratio less than 2 is not significant, 1 means no cutoffs in ratio values)
+ error = "0" // single character string of the positive proportion of false positives (i.e., theo dots considered as observed dots). 0.05 means 5%, 0 means that the significant observed dot are outside of the theo cloud
+ range_split = "25" // single character string of the positive numeric value for the significant dots. If x.range is the range of the dots on the x-axis, then abs(diff(x.range) / range_split) gives the window size. Window size decreases when range_split increases
+ step_factor = "10" // single character string of the positive numeric value (at least 1) for the significant dots. x.win.size / step.factor gives the shift step of the window. When step.factor = 1, no overlap during the sliding. If step.factor = 2, 50% of overlap during 1 slide
+ ratio_normalization = "TRUE" // single character string indicating if the cell ratio matrix mat2 / mat1 (differential matrix) has to be divided by the ratio factor mean(mat2) / mean(mat1)? Either "TRUE" or "FALSE". If TRUE, this means that the mean of the normalized cell ratio matrix is 1, and log (parameter transfo <- TRUE)is 0
// Graphical and display parameters
- activate_pdf = true
- optional_text = "NULL"
- width_wind = 7
- height_wind = 7
- dot_size = 2
- line_size = 0.75
- heatmap_text_size = 16
- text_size = 12
- title_text_size = 6
- raster = true
- transfo = "log2"
- warn_secu = false
- iter_nb = 128 //total serpentine iteration number parameter (this number will be split by thread.nb parameter, by progressively decreasing thread.nb til serp.iter.nb %% thread.nb != 0 (to have the same serp.iter.nb per thread)
- serp_symmet_input = true //are input matrices symmetric?
- // functions dependencies
- path_function1 = "https://gitlab.pasteur.fr/gmillot/cute_little_R_functions/-/raw/c1dd8832f14d76c1901a60ca2a7c87af01a82b61/cute_little_R_functions.R"
- adj_mean = "$projectDir/bin/adj_mean.R"
- hiccompare_graph = "$projectDir/bin/hiccompare_graph.R"
- intern_funct_check = "$projectDir/bin/intern_funct_check.R"
- mask_plot = "$projectDir/bin/mask_plot.R"
+ activate_pdf = "TRUE" // write "TRUE" for pdf display and "FALSE" for R display (main graphs)
+ optional_text = "NULL" // single character string of the optional text to include in results and graphs. Write "NULL" if not required
+ width_wind = "7" // single character string of the positive numeric value indicating the window width (in inches)
+ height_wind = "7" // single character string of the positive numeric value indicating the window height (in inches)
+ dot_size = "2" // single character string of the positive numeric value indicating the size of the dots
+ line_size = "0.75" // single character string of the positive numeric value indicating the size of the lines
+ heatmap_text_size = "16" // single character string of the positive numeric value indicating the size of the heatmap scale text
+ text_size = "12" // single character string of the positive numeric value indicating the
+ title_text_size = "6" // single character string of the positive numeric value indicating the size of the axis text and legend text
+ raster = "TRUE" // single character string indicating if the raster mode for dot plots has to be used? Either "TRUE" or "FALSE"
+ transfo = "log2" // Either "log2" (matrix values will be log2 converted, and sometimes log2(x +1) converted, +1 to deal with zero) or "log10" ((matrix values will be log10 converted and sometimes log10(x +1) converted, +1 to deal with zero). BEWARE: observed matrices must remain integers for serpentine. Log is only applied for display, the reason why the option "no" is not proposed (which would mean data already log converted)
+ warn_secu = "FALSE" // single character string indicating if internal homemade functions of anova_contrasts and anova_contrasts have variables that are present in other environments? Either "TRUE" or "FALSE"
+
+
+
}
//////// end variables that will be used only in the script.nf
@@ -116,7 +142,7 @@ env{
singularity_path = "NULL" // single character string of the path of the singularity folder (where all the singularity images are are pulled and stored for proper nextflow execution). Write "NULL" for default path (but will not work in most cases). Example: singularity_path='/pasteur/zeus/projets/p01/BioIT/gmillot/singularity'. Example: singularity_path='/mnt/c/Users/gmillot/singularity'. Example: singularity_path="$baseDir/singularity" # do not forget double quotes
out_path_ini = "$baseDir/results" // single character string of where the output files will be saved. Example out_path_ini = '.' for where the main.nf run is executed or out_path_ini = "$baseDir/results" to put the results in a result folder (created if required), $baseDir indicating where the main.nf run is executed. Example: out_path_ini = '/mnt/c/Users/Gael/Desktop'. Example : out_path_ini="/pasteur/zeus/projets/p01/BioIT/gmillot/08002_bourgeron/results". Warning: this does not work: out_path_ini = "/mnt/share/Users/gael/Desktop"
-result_folder_name="Ig_clustering" // single character string.of the name of the folder where the results files are dorpped
+result_folder_name="slitherine" // single character string.of the name of the folder where the results files are dorpped
/*
@@ -250,6 +276,4 @@ process {
}
-//////// end directives
-
-
\ No newline at end of file
+//////// end directives
\ No newline at end of file
diff --git a/slitherine.nf b/slitherine.nf
index 162925fb09d8f0530ed1c6303274db04c31b18b6..cce761e134de00dde2c0c947ff765c473c1795f5 100644
--- a/slitherine.nf
+++ b/slitherine.nf
@@ -1,4 +1,4 @@
-nextflow.enable.dsl=1
+nextflow.enable.dsl=2
/*
#############################################################
## ##
@@ -6,58 +6,52 @@ nextflow.enable.dsl=1
## Slitherine ##
## ##
## Mia Legras ##
+## Gael A. Millot ##
## Bioinformatics and Biostatistics Hub ##
-## Computational Biology Department ##
## Institut Pasteur Paris ##
## ##
#############################################################
*/
-// Variables
-config_file = file("${projectDir}/nextflow.config")
-log_file = file("${launchDir}/.nextflow.log")
+//////// Processes
-// Variables from config.file that need to be checked
-matrix1_ch_test = file("${in_path}/${matrix_file1}") // to test if exist below
-matrix2_ch_test = file("${in_path}/${matrix_file2}")
-// end Variables
+process workflowParam { // create a file with the workflow parameters in out_path
+ label 'bash'
+ publishDir "${out_path}/reports", mode: 'copy', overwrite: false
+ cache 'false'
+ input:
+ val modules
-// Channels
+ output:
+ path "Run_info.txt"
-matrix_ch1 = Channel.fromPath("${in_path}/${matrix_file1}", checkIfExists: false) //to perform the check below, in order to have a more explicit error message
-matrix_ch2 = Channel.fromPath("${in_path}/${matrix_file2}", checkIfExists: false)
-if(theo_import){ //if theo_import == true
- theo_mat_ch1 = Channel.fromPath("${in_path}/${theo_file_name1}")
- theo_mat_ch2 = Channel.fromPath("${in_path}/${theo_file_name2}")
-}
-// end Channels
-
-// Checks
-
-if(system_exec == 'local' || system_exec == 'slurm'){
- def file_exists1 = matrix1_ch_test.exists()
- def file_exists2 = matrix2_ch_test.exists()
- if( ! file_exists1 && ! file_exists2){
- print("\n\nERROR IN NEXTFLOW EXECUTION\n\n"
- + "INVALID in_path AND matrix_file PARAMETERS IN nextflow.config FILE: "
- + "${matrix_file1} or ${matrix_file2}\n\n"
- + "IF POINTING TO A DISTANT SERVER, CHECK THAT IT IS MOUNTED\n\n")
- }
-} else{
- print("\n\nERROR IN NEXTFLOW EXECUTION\n\n"
- + "INVALID system_exec PARAMETER IN nextflow.config FILE: ${system_exec}\n"
- + "THE ONLY POSSIBLE VALUES ARE local, slurm OR slurm_local\n\n")
+ script:
+ """
+ echo "Project (empty means no .git folder where the main.nf file is present): " \$(git -C ${projectDir} remote -v | head -n 1) > Run_info.txt # works only if the main script run is located in a directory that has a .git folder, i.e., that is connected to a distant repo
+ echo "Git info (empty means no .git folder where the main.nf file is present): " \$(git -C ${projectDir} describe --abbrev=10 --dirty --always --tags) >> Run_info.txt # idem. Provide the small commit number of the script and nextflow.config used in the execution
+ echo "Cmd line: ${workflow.commandLine}" >> Run_info.txt
+ echo "execution mode": ${system_exec} >> Run_info.txt
+ modules=$modules # this is just to deal with variable interpretation during the creation of the .command.sh file by nextflow. See also \$modules below
+ if [[ ! -z \$modules ]] ; then
+ echo "loaded modules (according to specification by the user thanks to the --modules argument of main.nf): ${modules}" >> Run_info.txt
+ fi
+ echo "Manifest's pipeline version: ${workflow.manifest.version}" >> Run_info.txt
+ echo "result path: ${out_path}" >> Run_info.txt
+ echo "nextflow version: ${nextflow.version}" >> Run_info.txt
+ echo -e "\\n\\nIMPLICIT VARIABLES:\\n\\nlaunchDir (directory where the workflow is run): ${launchDir}\\nprojectDir (directory where the main.nf script is located): ${projectDir}\\nworkDir (directory where tasks temporary files are created): ${workDir}" >> Run_info.txt
+ echo -e "\\n\\nUSER VARIABLES:\\n\\nout_path: ${out_path}\\in_path: ${in_path}" >> Run_info.txt
+ """
}
+//${projectDir} nextflow variable
+//${workflow.commandLine} nextflow variable
+//${workflow.manifest.version} nextflow variable
+//Note that variables like ${out_path} are interpreted in the script block
-// end Checks
-
-
-// Process
process PRE_SERPENTINE {
label 'R'
publishDir "${out_path}", mode: 'copy', pattern: "{*.txt, *.RData, *.pdf}", overwrite: false
@@ -65,25 +59,24 @@ process PRE_SERPENTINE {
cache 'true'
input:
- stdin in_path
- stdin out_path
+ path mat1
+ path mat2
+ val theo_path_in // can be NULL
+ path mat1_theo // NULL if does not exists
+ path mat2_theo // NULL if does not exists
+ path cute_file
+ path lib_path
+ path path_cv_rho // can be "NULL"
+ path path_theo1_theo2 // can be "NULL"
val project_name
- val lib_path
- stdin path_function1
- file mat1 from matrix_ch1 //file.name1
- file mat2 from matrix_ch2 //file.name2
val empty_cell_string
val thread_nb
val hiccomp
val binning
- val theo_import
val n_row
val win_size
- val cv_rho_obtained
- stdin path_cv_rho
- val correl_mat_obtained
- stdin path_theo1_theo2
val single_corr
+ val abs_corr_limit
val print_count
val keep
val ratio_limit_sig
@@ -106,48 +99,63 @@ process PRE_SERPENTINE {
val serp_symmet_input
val adj_mean
val hiccompare_graph
- val intern_funct_check
val mask_plot
- if(theo_import){
- file mat1_theo from theo_mat_ch1
- file mat2_theo from theo_mat_ch2
- path theo_path_in
- }
-
+
output:
- path "mat1.obs.txt" into matrix_norm_ch1
- path 'mat2.obs.txt' into matrix_norm_ch2
- path 'mat1.theo.txt' into matrix_theo_ch1
- path 'mat2.theo.txt' into matrix_theo_ch2
+ path "mat1.obs.txt", emit: matrix_norm_ch1
+ path 'mat2.obs.txt', emit: matrix_norm_ch2
+ path 'mat1.theo.txt', emit: matrix_theo_ch1
+ path 'mat2.theo.txt', emit: matrix_theo_ch2
path '*.RData'
path '*.pdf'
script:
- if(theo_import==true)
- """
- slith_part1.R "${in_path}" "${out_path}" "${project_name}" "${lib_path}" "${path_function1}" \
- "${mat1}" "${mat2}" "${empty_cell_string}" "${thread_nb}" "${hiccomp}" \
- "${binning}" "${theo_import}" "${n_row}" "${win_size}" "${cv_rho_obtained}" \
- "${path_cv_rho}" "${correl_mat_obtained}" "${path_theo1_theo2}" "${single_corr}" \
- "${print_count}" "${keep}" "${ratio_limit_sig}" "${error}" "${range_split}" \
- "${step_factor}" "${ratio_normalization}" "${activate_pdf}" "${optional_text}" \
- "${width_wind}" "${height_wind}" "${dot_size}" "${line_size}" "${heatmap_text_size}" \
- "${text_size}" "${title_text_size}" "${raster}" "${transfo}" "${warn_secu}" \
- "${serp_symmet_input}" "${adj_mean}" "${hiccompare_graph}" "${intern_funct_check}" "${mask_plot}" \
- "${mat1_theo}" "${mat2_theo}" "${theo_path_in}"
- """
- else
- """
- slith_part1.R "${in_path}" "${out_path}" "${project_name}" "${lib_path}" "${path_function1}" \
- "${mat1}" "${mat2}" "${empty_cell_string}" "${thread_nb}" "${hiccomp}" \
- "${binning}" "${theo_import}" "${n_row}" "${win_size}" "${cv_rho_obtained}" \
- "${path_cv_rho}" "${correl_mat_obtained}" "${path_theo1_theo2}" "${single_corr}" \
- "${print_count}" "${keep}" "${ratio_limit_sig}" "${error}" "${range_split}" \
- "${step_factor}" "${ratio_normalization}" "${activate_pdf}" "${optional_text}" \
- "${width_wind}" "${height_wind}" "${dot_size}" "${line_size}" "${heatmap_text_size}" \
- "${text_size}" "${title_text_size}" "${raster}" "${transfo}" "${warn_secu}" "${serp_symmet_input}" \
- "${adj_mean}" "${hiccompare_graph}" "${intern_funct_check}" "${mask_plot}"
+ """
+ #!/bin/bash -ue
+ slitherine_part1.R \
+"${mat1}" \
+"${mat2}" \
+"${theo_path_in}" \
+"${mat1_theo}" \
+"${mat2_theo}" \
+"${cute_file}" \
+"${lib_path}" \
+"${path_cv_rho}" \
+"${path_theo1_theo2}" \
+"${project_name}" \
+"${empty_cell_string}" \
+"${thread_nb}" \
+"${hiccomp}" \
+"${binning}" \
+"${n_row}" \
+"${win_size}" \
+"${single_corr}" \
+"${abs_corr_limit}" \
+"${print_count}" \
+"${keep}" \
+"${ratio_limit_sig}" \
+"${error}" \
+"${range_split}" \
+"${step_factor}" \
+"${ratio_normalization}" \
+"${activate_pdf}" \
+"${optional_text}" \
+"${width_wind}" \
+"${height_wind}" \
+"${dot_size}" \
+"${line_size}" \
+"${heatmap_text_size}" \
+"${text_size}" \
+"${title_text_size}" \
+"${raster}" \
+"${transfo}" \
+"${warn_secu}" \
+"${serp_symmet_input}" \
+"${adj_mean}" \
+"${hiccompare_graph}" \
+"${mask_plot}"
"""
+// the difference between the 2 is just: ${mat1_theo}" "${mat2_theo}" "${theo_path_in}
}
if (serp_binning == true){
@@ -184,14 +192,12 @@ if (serp_binning == true){
cache 'true'
input:
- stdin in_path
- stdin out_path
val project_name
stdin path_function1
- path mat1obs from matrixbin_ch1
- path mat2obs from matrixbin_ch2
- path mat1theo from matrixbin_theo_ch1
- path mat2theo from matrixbin_theo_ch2
+ path mat1obs from matrixbin_ch1
+ path mat2obs from matrixbin_ch2
+ path mat1theo from matrixbin_theo_ch1
+ path mat2theo from matrixbin_theo_ch2
val hiccomp
val binning
val keep
@@ -224,7 +230,7 @@ if (serp_binning == true){
script:
"""
- slith_part2.R "${project_name}" "${in_path}" "${out_path}" "${path_function1}" \
+ slith_part2.R "${project_name}" "./" "./" "${path_function1}" \
"${mat1obs}" "${mat2obs}" "${mat1theo}" "${mat2theo}" "${hiccomp}" \
"${binning}" "${keep}" "${ratio_limit_sig}" "${error}" "${range_split}" \
"${step_factor}" "${ratio_normalization}" "${activate_pdf}" "${optional_text}" \
@@ -235,4 +241,171 @@ if (serp_binning == true){
}
}
-// end Processes
+
+process backup {
+ label 'bash'
+ publishDir "${out_path}/reports", mode: 'copy', overwrite: false // since I am in mode copy, all the output files will be copied into the publishDir. See \\wsl$\Ubuntu-20.04\home\gael\work\aa\a0e9a739acae026fb205bc3fc21f9b
+ cache 'false'
+
+ input:
+ path config_file
+ path log_file
+
+ output:
+ path "${config_file}" // warning message if we use path config_file
+ path "${log_file}" // warning message if we use path log_file
+ path "Log_info.txt"
+
+ script:
+ """
+ #!/bin/bash -ue
+ echo -e "full .nextflow.log is in: ${launchDir}\nThe one in the result folder is not complete (miss the end)" > Log_info.txt
+ """
+}
+
+
+//////// End Processes
+
+//////// Workflow
+
+
+
+
+
+workflow {
+
+ //////// Options of nextflow run
+
+ print("\n\nINITIATION TIME: ${workflow.start}")
+
+ //////// end Options of nextflow run
+
+
+ //////// Options of nextflow run
+
+ // --modules (it is just for the process workflowParam)
+ params.modules = "" // if --module is used, this default value will be overridden
+ // end --modules (it is just for the process workflowParam)
+
+ //////// end Options of nextflow run
+
+
+ //////// Variables
+
+ modules = params.modules // remove the dot -> can be used in bash scripts
+ config_file = workflow.configFiles[0] // better to use this than config_file = file("${projectDir}/ig_clustering.config") because the latter is not good if -c option of nextflow run is used
+ log_file = file("${launchDir}/.nextflow.log")
+
+ //////// end Variables
+
+
+ //////// Checks
+
+
+
+
+ // below : those variable are already used in the config file. Thus, to late to check them. And not possible to check inside the config file
+ // out_ini
+ print("\n\nRESULT DIRECTORY: ${out_path}")
+ print("\n\nWARNING: PARAMETERS ALREADY INTERPRETED IN THE .config FILE:")
+ print(" system_exec: ${system_exec}")
+ print(" out_path: ${out_path_ini}")
+ if("${system_exec}" != "local"){
+ print(" queue: ${queue}")
+ print(" qos: ${qos}")
+ print(" add_options: ${add_options}")
+ }
+ print("\n\n")
+
+ //////// end Checks
+
+
+ //////// Variable modification
+
+
+ //////// end Variable modification
+
+
+ //////// Channels
+
+
+ //////// end Channels
+
+
+ //////// files import
+
+ mat1 = file("${in_path}/${matrix_file1}")
+ mat2 = file("${in_path}/${matrix_file2}")
+ mat1_theo = file("${in_path}/${theo_file_name1}") // NULL file if does not exists
+ mat2_theo = file("${in_path}/${theo_file_name2}") // NULL file if does not exists
+ cute_file = file("${path_function1}") // in variable because a single file
+ adj_mean = file("${adj_mean}") // in variable because a single file
+ hiccompare_graph = file("${hiccompare_graph}") // in variable because a single file
+ intern_funct_check = file("${intern_funct_check}") // in variable because a single file
+ mask_plot = file("${mask_plot}") // in variable because a single file
+ lib_path = file("${lib_path}") // in variable because a single folder
+ path_cv_rho = file("${path_cv_rho}") // in variable because a single file
+ path_theo1_theo2 = file("${path_theo1_theo2}") // in variable because a single folder
+
+
+ //////// end files import
+
+
+ //////// Main
+
+ workflowParam(
+ modules
+ )
+
+
+
+ PRE_SERPENTINE(
+ mat1,
+ mat2,
+ theo_path_in,
+ mat1_theo,
+ mat2_theo,
+ cute_file,
+ lib_path,
+ path_cv_rho,
+ path_theo1_theo2,
+ project_name,
+ empty_cell_string,
+ thread_nb,
+ hiccomp,
+ binning,
+ n_row,
+ win_size,
+ single_corr,
+ abs_corr_limit,
+ print_count,
+ keep,
+ ratio_limit_sig,
+ error,
+ range_split,
+ step_factor,
+ ratio_normalization,
+ activate_pdf,
+ optional_text,
+ width_wind,
+ height_wind,
+ dot_size,
+ line_size,
+ heatmap_text_size,
+ text_size,
+ title_text_size,
+ raster,
+ transfo,
+ warn_secu,
+ serp_symmet_input,
+ adj_mean,
+ hiccompare_graph,
+ mask_plot
+ )
+
+}
+
+
+
+
+