diff --git a/check/Function check-list.docx b/check/Function check-list.docx
deleted file mode 100644
index 3ef88195fccbe50a045e0f1e5d03005b9570baee..0000000000000000000000000000000000000000
Binary files a/check/Function check-list.docx and /dev/null differ
diff --git a/check/checklist.docx b/check/checklist.docx
new file mode 100644
index 0000000000000000000000000000000000000000..4b1aaedae7302233109836971ae1e5b153dbf488
Binary files /dev/null and b/check/checklist.docx differ
diff --git a/cute_little_R_functions.R b/cute_little_R_functions.R
index 6780b441d7f8229c353e7b4191dada78af86e9ec..7f87f5de77402104f2e5a18fd9ecbc994b67f3d2 100755
--- a/cute_little_R_functions.R
+++ b/cute_little_R_functions.R
@@ -413,12 +413,15 @@ fun_check <- function(
problem <- FALSE
text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT")
if(( ! is.null(options)) & (all(base::typeof(data) == "character") | all(base::typeof(data) == "integer") | all(base::typeof(data) == "double"))){ # all() without na.rm -> ok because typeof() never returns NA
+ test.log <- TRUE
if(all(base::typeof(data) == "double")){
if( ! all(data %% 1 == 0L, na.rm = TRUE)){
problem <- TRUE
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nBUT IS NOT EVEN TYPE CHARACTER OR INTEGER")
+ test.log <- FALSE
}
- }else{
+ }
+ if(test.log == TRUE){
text <- ""
if( ! all(data %in% options)){ # no need of na.rm = TRUE for all() because %in% does not output NA
problem <- TRUE
@@ -1978,8 +1981,7 @@ fun_test <- function(
"arg",
"val"
)
- tempo <- eval(parse(text = paste0("missing(", paste0(mandat.args, collapse = ") | missing("), "))")))
- print(tempo)
+ tempo <- eval(parse(text = paste0("missing(", paste0(mandat.args, collapse = ") | missing("), ")")))
if(any(tempo)){ # normally no NA for missing() output
tempo.cat <- paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", ifelse(sum(tempo, na.rm = TRUE) > 1, "S HAVE", " HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", paste0(mandat.args[tempo], collapse = "\n"))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
@@ -8898,7 +8900,6 @@ path_lib = sys.path
tempo.try[[i2]] <- suppressWarnings(try(reticulate::import_from_path(req.package[i1], path = lib.path[i2]), silent = TRUE)) # done twice to avoid the error message about flushing present the first time but not the second time. see https://stackoverflow.com/questions/57357001/reticulate-1-13-error-in-sysstdoutflush-attempt-to-apply-non-function
}
if(all(sapply(tempo.try, FUN = grepl, pattern = "[Ee]rror"))){
- print(tempo.try)
tempo.cat <- paste0("ERROR IN ", function.name, ": PACKAGE ", req.package[i1], " MUST BE INSTALLED IN THE MENTIONNED DIRECTORY:\n", paste(lib.path, collapse = "\n"))
stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
} # else{
@@ -9095,6 +9096,14 @@ fun_get_message <- function(
}
# end required function checking
# no need to use reserved words to avoid bugs, because it is local, and exists("tempo.warning", inherit = FALSE), never use the scope
+mandat.args <- c(
+"data"
+)
+tempo <- eval(parse(text = paste0("c(missing(", paste0(mandat.args, collapse = "),missing("), "))")))
+if(any(tempo)){ # normally no NA for missing() output
+tempo.cat <- paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", ifelse(sum(tempo, na.rm = TRUE) > 1, "S HAVE", " HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", paste0(mandat.args, collapse = "\n"))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+}
# argument checking
# argument checking with fun_check()
arg.check <- NULL #
diff --git a/cute_little_R_functions.docx b/cute_little_R_functions.docx
index ed0f438baa99fa0cea1d42ec207fa69183b991f5..9e72e0662469035c08fdea6ea49733d8d1719c6e 100755
Binary files a/cute_little_R_functions.docx and b/cute_little_R_functions.docx differ
diff --git a/fun_gg_boxplot.R b/fun_gg_boxplot.R
index 1f5a985f7913f41600f5bd1052d59e4885c84f76..ebb9c1e7dd7e54b2c5b5c8a746c250c5004879f2 100644
--- a/fun_gg_boxplot.R
+++ b/fun_gg_boxplot.R
@@ -235,11 +235,11 @@ mandat.args <- c(
"y",
"categ"
)
-tempo <- eval(parse(text = paste0("missing(", paste0(mandat.args, collapse = ") | missing("), ")")))
-if(any(tempo)){ # normally no NA for missing() output
-tempo.cat <- paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", ifelse(sum(tempo, na.rm = TRUE) > 1, "S HAVE", "HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", paste0(mandat.args, collapse = "\n"))
-stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
-}
+ tempo <- eval(parse(text = paste0("missing(", paste0(mandat.args, collapse = ") | missing("), ")")))
+ if(any(tempo)){ # normally no NA for missing() output
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", ifelse(sum(tempo, na.rm = TRUE) > 1, "S HAVE", "HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", paste0(mandat.args, collapse = "\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
# end arg with no default values
# argument primary checking
arg.check <- NULL #
diff --git a/fun_gg_miami.R b/fun_gg_miami.R
new file mode 100644
index 0000000000000000000000000000000000000000..31eaa304f11ce5f7937ca09f435953594be9fb80
--- /dev/null
+++ b/fun_gg_miami.R
@@ -0,0 +1,768 @@
+fun_gg_miami <- function(
+ fisher,
+ chr,
+ top.y.column,
+ bottom.y.column,
+ x.lim = "whole",
+ vgrid = FALSE,
+ color.column = NULL,
+ dot.border.color = NULL,
+ y.lim1 = NULL,
+ y.lim2 = NULL,
+ reverse1 = FALSE,
+ reverse2 = FALSE,
+ y.threshold1 = NULL,
+ y.threshold2 = NULL,
+ y.log1 = FALSE,
+ y.log2 = FALSE
+
+ # x_lim: single character string of the x-axis limits. Either whole for the whole genome, region to have the regions of the region parameter (i.e., whole if region == none), or a character string written like the region parameter, to have the x-axis limited to the x_lim parameter. Write NULL to does not plot results
+ # vgrid: single character string of logical value TRUE or FALSE. Display the chromosome separators in the miami plot? Example: vgrid = TRUE
+ # top_y_column = NEG_LOG10_P_VALUE_CARRIER_MODEL: single character string of any of the quantitative column of the res_fisher.tsv file for the y-axis of the manhattan plot at the top of the miami plot. Can also be an added column through the tsv_extra_fields parameter.
+ # bottom_y_column = AF: as the top_y_column parameter but for the bottom manhattan plot of the miami plot. NULL generates a simple manhattan plot
+ # color_column = NULL: single character string of one of the column name of the res_fisher.tsv file (see bottom_y_column) in order color the dots. Write NULL if not required (dots will be alternatively grey and blue, according to chromo order)
+ # dot_border_color = NULL: single color character string to color the border of the dots. Write NULL if not required
+ # y_lim1 = NULL: single character string of the y-axis limits of the top panel in the miami plot, made of two numbers, separated by a single space. Example: y_lim1 = 0 3. Write NULL for no particular limit
+ # y_lim2 = NULL: single character string of the y-axis limits of the bottom panel in the miami plot, made of two numbers, separated by a single space. Example: y_lim2 = 0 3 .Write NULL for no particular limit. Not considered if bottom_y_column = NULL
+ # y_reverse1 = FALSE: single character string of logical value TRUE or FALSE, y-axis coordinates flip for the top panel in the miami plot. Example: y_reverse1 = TRUE
+ # y_reverse2 = FALSE: single character string of logical value TRUE or FALSE, y-axis coordinates flip for the bottom panel in the miami plot. Example: y_reverse2 = TRUE
+ # y_threshold: single character string made of 1 numeric value for the y-axis threshold of the top panel in the miami plot, beyond which values are of interest. Example: y_threshold1 = 3. Write NULL for no particular threshold
+ # y_threshold2: single numeric value for the y-axis threshold of the bottom panel in the miami plot, beyond which values are of interest. Example: y_threshold2 = 3. Write NULL for no particular threshold. Not considered if bottom_y_column = NULL
+ # y_log1: single logical value TRUE or FALSE for the y-axis log10 scale of the top panel in the miami plot. Example: y_log1 = TRUE
+ # y_log2: single logical value TRUE or FALSE for the y-axis log10 scale of the bottom panel in the miami plot. Example: y_log2 = TRUE
+
+
+ # AIM
+ # Plot a ggplot2 donut using contingency data, systematically in the decreasing order of frequencies, starting at the top and turning clockwise
+ # For ggplot2 specifications, see: https://ggplot2.tidyverse.org/articles/ggplot2-specs.html
+ # WARNINGS
+ # Rows containing NA in data1[, c(freq, categ)] will be removed before processing, with a warning (see below)
+ # Size arguments (hole.text.size, border.size, title.text.size and annotation.size) are in mm. See Hadley comment in https://stackoverflow.com/questions/17311917/ggplot2-the-unit-of-size. See also http://sape.inf.usi.ch/quick-reference/ggplot2/size). Unit object are not accepted, but conversion can be used (e.g., grid::convertUnit(grid::unit(0.2, "inches"), "mm", valueOnly = TRUE))
+ # ARGUMENTS
+ # data1: a dataframe compatible with ggplot2
+ # freq: single character string of the data1 column name of the frequencies
+ # categ: single character string of the data1 column name of categories (qualitative variable)
+ # fill.palette: single character string of a palette name (see ?ggplot2::scale_fill_brewer() for the list).Ignored if fill.color is not NULL
+ # fill.color: either (1) NULL, or (2) a vector of character strings or integers of same length as the number of classes in categ. Colors can be color names (see ?colors() in R), hexadecimal color codes, or integers (according to the ggplot2 palette). The order of the elements will be used according to the frequency values, from highest to lowest. An easy way to use this argument is to sort data1 according to the frequencies values, add a color column with the corresponding desired colors and use the content of this column as values of fill.color. If color is NULL and fill.palette is NULL, default colors of ggplot2 are used. If color is not NULL, it overrides fill.palette
+ # hole.size: single positive proportion of donut central hole, 0 meaning no hole (pie chart) and 1 no plot (donut with a null thickness)
+ # hole.text: logical (either TRUE or FALSE). Display the sum of frequencies (column of data1 indicated in the freq argument) ?
+ # hole.text.size: single positive numeric value of the title font size in mm. Ignored if hole.text is FALSE
+ # border.color: a single character string or integer. Colors can be color names (see ?colors() in R), hexadecimal color codes, or integers (according to the ggplot2 palette)
+ # border.size: single numeric value of border tickness in mm. Write zero for no dot border
+ # title: single character string of the graph title
+ # title.text.size: single numeric value of the title font size in mm
+ # annotation: single character string of the data1 column name of annotations. Values inside this column will be displayed over the corresponding slices of the donut. Write NULL if not required
+ # annotation.distance: single positive numeric value of the distance from the center of the slice. 0 means center of the slice, 0.5 means at the edge. Above 0.5, the donut will be reduced to make place for the annotation. Ignored if annotation is NULL
+ # annotation.size: single positive numeric value of the annotation font size in mm. Ignored if annotation is NULL
+ # annotation.force: single positive numeric value of the force of repulsion between overlapping text labels. See ?ggrepel::geom_text_repel() in R. Ignored if annotation is NULL
+ # annotation.force.pull: single positive numeric value of the force of attraction between a text label and its corresponding data point. See ?ggrepel::geom_text_repel() in R. Ignored if annotation is NULL
+ # legend.show: logical (either TRUE or FALSE). Show legend?
+ # legend.width: single proportion (between 0 and 1) indicating the relative width of the legend sector (on the right of the plot) relative to the width of the plot. Value 1 means that the window device width is split in 2, half for the plot and half for the legend. Value 0 means no room for the legend, which will overlay the plot region. Write NULL to inactivate the legend sector. In such case, ggplot2 will manage the room required for the legend display, meaning that the width of the plotting region can vary between graphs, depending on the text in the legend
+ # legend.name: character string of the legend title. If legend.name is NULL then legend.name is the value of the categ argument. Write legend.name = "" to remove the legend
+ # legend.text.size: single numeric value of the font size in mm of the legend labels
+ # legend.box.size: single numeric value of the size of the legend squares in mm
+ # legend.box.space: single numeric value of the space between the legend boxes in mm
+ # legend.limit: single positive proportion of the classes displayed in the legend for which the corresponding proportion is over legend.limit. Write NULL to display all the classes
+ # legend.add.prop: logical (either TRUE or FALSE). add the proportion after the class names in the legend ?
+ # add: character string allowing to add more ggplot2 features (dots, lines, themes, facet, etc.). Ignored if NULL
+ # WARNING: (1) the string must start with "+", (2) the string must finish with ")" and (3) each function must be preceded by "ggplot2::". Example: "+ ggplot2::coord_flip() + ggplot2::theme_bw()"
+ # If the character string contains the "ggplot2::theme" string, then the article argument of fun_gg_donut() (see above) is ignored with a warning. In addition, some arguments can be overwritten, like x.angle (check all the arguments)
+ # Handle the add argument with caution since added functions can create conflicts with the preexisting internal ggplot2 functions
+ # WARNING: the call of objects inside the quotes of add can lead to an error if the name of these objects are some of the fun_gg_donut() arguments. Indeed, the function will use the internal argument instead of the global environment object. Example article <- "a" in the working environment and add = '+ ggplot2::ggtitle(article)'. The risk here is to have TRUE as title. To solve this, use add = '+ ggplot2::ggtitle(get("article", envir = .GlobalEnv))'
+ # return: logical (either TRUE or FALSE). Return the graph parameters?
+ # return.ggplot: logical (either TRUE or FALSE). Return the ggplot object in the output list? Ignored if return argument is FALSE. WARNING: always assign the fun_gg_donut() function (e.g., a <- fun_gg_donut()) into something if the return.ggplot argument is TRUE, otherwise, double plotting is performed. See $ggplot in the RETURN section below for more details
+ # return.gtable: logical (either TRUE or FALSE). Return the full graph (main, title and legend) as a gtable of grobs in the output list? See $gtable in the RETURN section below for more details
+ # plot: logical (either TRUE or FALSE). Plot the graphic? If FALSE and return argument is TRUE, graphical parameters and associated warnings are provided without plotting
+ # warn.print: logical (either TRUE or FALSE). Print warnings at the end of the execution? ? If FALSE, warning messages are never printed, but can still be recovered in the returned list. Some of the warning messages (those delivered by the internal ggplot2 functions) are not apparent when using the argument plot = FALSE
+ # lib.path: vector of character strings indicating the absolute path of the required packages (see below). if NULL, the function will use the R library default folders
+ # RETURN
+ # a donut plot if plot argument is TRUE
+ # a list of the graph info if return argument is TRUE:
+ # $data: the initial data with modifications and with graphic information added
+ # $removed.row.nb: a list of the removed rows numbers in data frames (because of NA). NULL if no row removed
+ # $removed.rows: a list of the removed rows in data frames (because of NA). NULL if no row removed
+ # $plot.data
+ # $panel: the variable names used for the panels (NULL if no panels). WARNING: NA can be present according to ggplot2 upgrade to v3.3.0
+ # $axes: the x-axis and y-axis info
+ # $warn: the warning messages. Use cat() for proper display. NULL if no warning. WARNING: warning messages delivered by the internal ggplot2 functions are not apparent when using the argument plot = FALSE
+ # $ggplot: ggplot object that can be used for reprint (use print($ggplot) or update (use $ggplot + ggplot2::...). NULL if return.ggplot argument is FALSE. Warning: the legend is not in $ggplot as it is in a separated grob (use $gtable to get it). Of note, a non-null $ggplot in the output list is sometimes annoying as the manipulation of this list prints the plot
+ # $gtable: gtable object that can be used for reprint (use gridExtra::grid.arrange(...$ggplot) or with additionnal grobs (see the grob decomposition in the examples). Contrary to $ggplot, a non-NULL $gtable in the output list is not annoying as the manipulation of this list does not print the plot
+ # REQUIRED PACKAGES
+ # ggplot2
+ # gridExtra
+ # grid
+ # lemon (in case of use in the add argument)
+ # ggrepel
+ # REQUIRED FUNCTIONS FROM THE cute PACKAGE
+ # fun_gg_palette()
+ # fun_gg_get_legend()
+ # fun_pack()
+ # fun_check()
+ # EXAMPLES
+ # obs1 <- data.frame(Km = c(20, 10, 1, 5), Car = c("TUUT", "WIIM", "BIP", "WROUM"), Color1 = 1:4, color2 = c("red", "blue", "green", "black"), Country = c("FR", "UK", "US", NA), stringsAsFactors = TRUE) ; fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car", annotation = "Country")
+ # DEBUGGING
+ # obs1 <- data.frame(Km = c(20, 10, 1, 5), Car = c("TUUT", "WIIM", "BIP", "WROUM"), Color1 = 1:4, color2 = c("red", "blue", "green", "black"), Country = c("FR", "UK", "US", NA), stringsAsFactors = TRUE) ; data1 = obs1 ; freq = "Km" ; categ = "Car" ; fill.palette = NULL ; fill.color = NULL ; hole.size = 0.5 ; hole.text = TRUE ; hole.text.size = 12 ; border.color = "gray50" ; border.size = 0.1 ; title = "" ; title.text.size = 12 ; annotation = "Country" ; annotation.distance = 0.5 ; annotation.size = 3 ; annotation.force = 1 ; annotation.force.pull = 100 ; legend.show = TRUE ; legend.width = 0.5 ; legend.name = NULL ; legend.text.size = 10 ; legend.box.size = 5 ; legend.box.space = 2 ; legend.limit = NULL ; legend.add.prop = FALSE ; add = NULL ; return = TRUE ; return.ggplot = FALSE ; return.gtable = TRUE ; plot = TRUE ; warn.print = FALSE ; lib.path = NULL
+ # function name
+ function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
+ arg.names <- names(formals(fun = sys.function(sys.parent(n = 2)))) # names of all the arguments
+ arg.user.setting <- as.list(match.call(expand.dots=FALSE))[-1] # list of the argument settings (excluding default values not provided by the user)
+ # end function name
+ # required 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 miami.R\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() to be able to add several messages between ==
+ }
+ # end required function checking
+
+ ################ end import functions from cute little functions toolbox
+
+ ################ local function: package import
+
+ # R Packages required
+ req.package.list <- c(
+ "lubridate",
+ "ggplot2",
+ "scales",
+ "grid",
+ "qqman"
+ )
+ for(i in 1:length(req.package.list)){suppressMessages(library(req.package.list[i], 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 local function: package import
+
+ ################ other functions
+
+ ################ end other functions
+
+ ################################ End Functions
+
+
+ ################################ 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))
+ tempo <- fun_check(data = fisher, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ tempo <- fun_check(data = chr.path, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ # tempo <- fun_check(data = cute, class = "vector", typeof = "character", length = 1) ; eval(ee) # check above
+ if(all(x.lim != "NULL")){
+ tempo <- fun_check(data = x.lim, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ }else{
+ x.lim <- NULL
+ }
+ tempo <- fun_check(data = vgrid, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ if(all(top.y.column != "NULL")){
+ tempo <- fun_check(data = top.y.column, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ }else{
+ top.y.column <- NULL
+ }
+ if(all(bottom.y.column != "NULL")){
+ tempo <- fun_check(data = bottom.y.column, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ }else{
+ bottom.y.column <- NULL
+ }
+ if(all(color.column != "NULL")){
+ tempo <- fun_check(data = color.column, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ }else{
+ color.column <- NULL
+ }
+ if(all(dot.border.color != "NULL")){
+ tempo <- fun_check(data = dot.border.color, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ }else{
+ dot.border.color <- NULL
+ }
+ if(all(y.lim1 != "NULL")){
+ tempo <- fun_check(data = y.lim1, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ }else{
+ y.lim1 <- NULL
+ }
+ if(all(y.lim2 != "NULL")){
+ tempo <- fun_check(data = y.lim2, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ }else{
+ y.lim2 <- NULL
+ }
+ tempo <- fun_check(data = reverse1, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ tempo <- fun_check(data = reverse2, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ if(all(y.threshold1 != "NULL")){
+ tempo <- fun_check(data = y.threshold1, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ }else{
+ y.threshold1 <- NULL
+ }
+ if(all(y.threshold2 != "NULL")){
+ tempo <- fun_check(data = y.threshold2, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ }else{
+ y.threshold2 <- NULL
+ }
+ tempo <- fun_check(data = y.log1, class = "vector", typeof = "character", length = 1) ; eval(ee)
+ tempo <- fun_check(data = log, class = "vector", typeof = "character", length = 1) ; 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() 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
+ tempo.arg <-c(
+ "fisher",
+ "chr.path",
+ "vgrid",
+ "reverse1",
+ "reverse2",
+ "y.log1",
+ "y.log2",
+ "log"
+ )
+ tempo.log <- sapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = is.null)
+ if(any(tempo.log) == TRUE){# normally no NA with is.null()
+ tempo.cat <- paste0("ERROR IN miami.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")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ # end management of NULL arguments
+ # management of ""
+ tempo.arg <-c(
+ "fisher",
+ "chr.path",
+ "x.lim",
+ "vgrid",
+ "top.y.column",
+ "bottom.y.column",
+ "color.column",
+ "dot.border.color",
+ "y.lim1",
+ "y.lim2",
+ "reverse1",
+ "reverse2",
+ "y.threshold1",
+ "y.threshold2",
+ "y.log1",
+ "y.log2",
+ "cute",
+ "log"
+ )
+ tempo.log <- sapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = function(x){any(x == "")})
+ if(any(tempo.log) == TRUE){# normally no NA with is.null()
+ tempo.cat <- paste0("ERROR IN miami.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 \"\"")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ # end management of ""
+ # code that protects set.seed() in the global environment
+ # end code that protects set.seed() in the global environment
+ # warning initiation
+ ini.warning.length <- options()$warning.length
+ options(warning.length = 8170)
+ warn <- NULL
+ # warn.count <- 0 # not required
+ # end warning initiation
+ # other checkings
+ for(i0 in c("vgrid", "reverse1", "reverse2", "y.log1", "y.log2")){
+ if(get(i0) == "TRUE"){
+ assign(i0, TRUE)
+ }else if(get(i0) == "FALSE"){
+ assign(i0, FALSE)
+ }else{
+ tempo.cat <- paste0("ERROR IN miami.R\n", i0, " PARAMETER CAN ONLY BE \"TRUE\" OR \"FALSE\": ", get(i0))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ }
+ # end other checkings
+ # reserved word checking
+ # end reserved word checking
+ # end second round of checking and data preparation
+ # package checking
+ # end package checking
+
+
+ ################################ End pre-ignition checking
+
+
+ ################################ Main code
+
+
+ ################ Ignition
+
+
+ fun_report(data = paste0("\n\n################################################################ miami PROCESS\n\n"), output = log, path = "./", overwrite = TRUE)
+ ini.date <- Sys.time()
+ ini.time <- as.numeric(ini.date) # time of process begin, converted into seconds
+ fun_report(data = paste0("\n\n################################ RUNNING DATE AND STARTING TIME\n\n"), output = log, path = "./", overwrite = FALSE)
+ fun_report(data = paste0(ini.date, "\n\n"), output = log, path = "./", overwrite = FALSE)
+ fun_report(data = paste0("\n\n################################ RUNNING\n\n"), output = log, path = "./", overwrite = FALSE)
+
+
+ ################ End ignition
+
+
+ ################ Graphical parameter initialization
+
+
+ pdf(file = NULL)
+ 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.warn <- paste0("GRAPHICS HAVE NOT BEEN ERASED. GRAPHICAL PARAMETERS MAY HAVE NOT BEEN REINITIALIZED")
+ fun_report(data = paste0("WARNING\n", tempo.warn), output = log, path = "./", overwrite = FALSE)
+ warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ }
+
+
+ ################ End graphical parameter initialization
+
+
+ ################ Data import
+
+
+ if( ! file.exists(fisher)){
+ stop(paste0("\n\n============\n\nERROR IN miami.R\nFILE INDICATED IN THE fisher PARAMETER DOES NOT EXISTS: ", fisher, "\n\n============\n\n"), call. = FALSE)
+ }else{
+ obs <- read.table(fisher, sep = "\t", stringsAsFactors = FALSE, header = TRUE, comment.char = "")
+ if(length(obs) > 0 & nrow(obs) > 0){
+ empty.obs <- FALSE
+ }else{
+ empty.obs <- TRUE
+ }
+ }
+ if( ! file.exists(chr.path)){
+ stop(paste0("\n\n============\n\nERROR IN miami.R\nFILE INDICATED IN THE chr.path PARAMETER DOES NOT EXISTS: ", chr.path, "\n\n============\n\n"), call. = FALSE)
+ }else{
+ chr <- read.table(chr.path, sep = "\t", stringsAsFactors = FALSE, header = TRUE, comment.char = "")
+ }
+
+
+ ################ end Data import
+
+
+ ############ modifications of imported tables
+
+ xmin_plot <- 0 # coordinates for plotting
+ if(length(obs) > 0 & nrow(obs) > 0){
+ # names(obs)[names(obs) == "NEG_LOG10_P_VALUE"] <- "neg.log10.p"
+ # names(obs)[names(obs) == "PATIENT_NB"] <- "Nb_of_indiv"
+ if(any(grepl(x = obs$CHROM, pattern = "chr"))){
+ obs$CHROM <- sub(x = obs$CHROM, pattern = "chr", replacement = "")
+ }
+ if(any(grepl(x = obs$CHROM, pattern = "^X$"))){
+ obs$CHROM[grepl(x = obs$CHROM, pattern = "^X$")] <- "23"
+ }
+ if(any(grepl(x = obs$CHROM, pattern = "^Y$"))){
+ obs$CHROM[grepl(x = obs$CHROM, pattern = "^Y$")] <- "24"
+ }
+ if(any(grepl(x = obs$CHROM, pattern = "^MT$|^M$"))){
+ obs$CHROM[grepl(x = obs$CHROM, pattern = "^MT$|^M$")] <- "25"
+ }
+ if(any( ! grepl(x = obs$CHROM, pattern = "\\d"))){
+ tempo.cat <- paste0("ERROR IN miami.R:\nTHE chr COLUMN of the fisher.tsv FILE HAS LETTERS IN IT, OTHER THAN X, Y and MT:\n", paste0(obs$CHROM[grepl(x = obs$CHROM, pattern = "^\\d")], collapse = "\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ obs$CHROM <- as.integer(obs$CHROM)
+ }
+ # add the chr info to obs
+ obs <- data.frame(obs, coord = vector(mode = "numeric", length = nrow(obs)))
+ for(i1 in chr$CHR_NB){
+ obs$coord[obs$CHROM == i1] <- obs$POS[obs$CHROM == i1] + chr$LENGTH_CUMUL_TO_ADD[i1]
+ }
+ # preparation of the x coordinates: three solutions: 1) whole object (see above), 2) single chromo "chr7" or "chr7:0-15", 3) several chromo chr7, chr8" or "chr7:0-15, chr8" or "chr7:0-15, chr8:0-20"
+ # The idea is to select rows of chr and potentially restrict some chr limits
+ if( ! is.null(x.lim)){
+ is.whole <- FALSE
+ if(x.lim == whole){ #at that stage, x.lim is a single character
+ is.whole <- TRUE
+ }
+ tempo <- strsplit(x = x.lim, split = ",")[[1]]
+ tempo <- gsub(x = tempo, pattern = " ", replacement = "")
+ if( ! all(grepl(x = tempo, pattern = "^chr.+"))){
+ tempo.cat <- paste0("ERROR IN miami.R:\nTHE x_lim PARAMETER MUST START WITH \"chr\" IF NOT \"none\":\n", paste0(x.lim, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ if(any(grepl(x = tempo, pattern = ":"))){
+ # means that there are coordinates
+ if( ! all(grepl(tempo, pattern = "-"))){# normally no NA with is.null()
+ tempo.cat <- paste0("ERROR IN miami.R:\nTHE x_lim PARAMETER MUST BE WRITTEN LIKE THIS \"chr7:0-147000000, chr10:1000000-2000000\" IF COORDINATES ARE SPECIFIED: \n", paste0(x.lim, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ tempo2 <- strsplit(x = tempo, split = ":")
+ chr_x_lim <- sapply(X = tempo2, FUN = function(x){x[1]})
+ chr_x_lim <- gsub(x = chr_x_lim, pattern = " ", replacement = "")
+ coord_x_lim <- sapply(X = tempo2, FUN = function(x){x[2]})
+ tempo3 <- strsplit(x = coord_x_lim, split = "-")
+ xmin_x_lim <- sapply(X = tempo3, FUN = function(x){x[1]})
+ xmin_x_lim <- gsub(x = xmin_x_lim, pattern = " ", replacement = "")
+ xmax_x_lim <- sapply(X = tempo3, FUN = function(x){x[2]})
+ xmax_x_lim <- gsub(x = xmax_x_lim, pattern = " ", replacement = "")
+ if(any(grepl(xmin_x_lim, pattern = "\\D")) | any(grepl(xmax_x_lim, pattern = "\\D"))){# normally no NA with is.null()
+ tempo.cat <- paste0("ERROR IN miami.R:\nTHE x_lim PARAMETER MUST BE WRITTEN LIKE THIS \"chr7:0-147000000, chr10:1000000-2000000\" IF COORDINATES ARE SPECIFIED: \n", paste0(x.lim, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ xmin_x_lim <- as.integer(xmin_x_lim)
+ xmax_x_lim <- as.integer(xmax_x_lim)
+ if(any(xmax_x_lim - xmin_x_lim < 0)){
+ tempo.cat <- paste0("ERROR IN miami.R:\nTHE x_lim PARAMETER MUST BE WRITTEN WITH ORDERED COORDINATES, LIKE THIS \"chr7:0-147000000, chr10:1000000-2000000\", IF COORDINATES ARE SPECIFIED: \n", paste0(x.lim, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ }
+ }else{
+ chr_x_lim <- tempo
+ coord_x_lim <- NULL
+ xmin_x_lim <- NULL
+ xmax_x_lim <- NULL
+ }
+ # modification of the chr object for restricted plotting
+ tempo.coord <- which(chr$CHR %in% chr_x_lim) # which rows of chr to take for plotting
+ if(any(chr$BP_LENGTH[tempo.coord] - xmax_x_lim < 0)){
+ tempo.cat <- paste0("ERROR IN miami.R:\nTHE x_lim PARAMETER HAS AT LEAST ONE COORDINATE THAT IS ABOVE THE MAX LENGTH OF THE CHROMO.\nCHROMO LENGTH: ", paste0(chr$BP_LENGTH[tempo.coord], collapse = " "), "\nMAX COORDINATE: ", paste0(xmax_x_lim, collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ if(tempo.coord[1] > 1){
+ xmin_plot <- chr$LENGTH_CUMUL[tempo.coord[1] - 1]
+ }
+ chr <- chr[tempo.coord[1]:tempo.coord[length(tempo.coord)], ]
+ if( ! is.null(coord_x_lim)){
+ xmin_plot <- xmin_plot + xmin_x_lim[1] # the left boundary of the plot is corrected
+ chr$LENGTH_CUMUL[nrow(chr)] <- chr$LENGTH_CUMUL[nrow(chr)] - chr$BP_LENGTH[nrow(chr)] + xmax_x_lim[length(xmax_x_lim)] # the right boundary of the plot is corrected
+ chr$CHR_NAME_POS <- (c(xmin_plot, chr$LENGTH_CUMUL[-nrow(chr)]) + chr$LENGTH_CUMUL) / 2 # the positions of names in the x-axis of the plot are corrected
+ }
+ # restriction of obs
+ obs <- obs[obs$coord >= xmin_plot & obs$coord <= chr$LENGTH_CUMUL[nrow(chr)], ]
+ }else{
+ tempo.warn <- paste0("x.lim is NULL: NO PLOT DRAWN")
+ fun_report(data = paste0("WARNING\n", tempo.warn), output = log, path = "./", overwrite = FALSE)
+ warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ }
+ }
+
+ for(i0 in c("y.lim1", "y.lim2")){
+ if( ! is.null(get(i0))){
+ tempo <- unlist(strsplit(x = get(i0), split = " "))
+ if(length(tempo) != 2 | ! all(grepl(tempo, pattern = "^[0123456789.\\-\\+eE]*$"))){
+ tempo.cat <- paste0("ERROR IN miami.R:\nTHE ", i0, " PARAMETER MUST BE TWO NUMERIC VALUES SEPARATED BY A SINGLE SPACE\nHERE IT IS: \n", paste0(get(i0), collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ assign(i0, as.numeric(tempo))
+ }
+ }
+ }
+ for(i0 in c("y.threshold1", "y.threshold2")){
+ if( ! is.null(get(i0))){
+ tempo <- unlist(strsplit(x = get(i0), split = " "))
+ if(length(tempo) != 1 | ! all(grepl(tempo, pattern = "^[0123456789.\\-\\+eE]*$"))){
+ tempo.cat <- paste0("ERROR IN miami.R:\nTHE ", i0, " PARAMETER MUST BE TWO NUMERIC VALUES SEPARATED BY A SINGLE SPACE\nHERE IT IS: \n", paste0(get(i0), collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ assign(i0, as.numeric(tempo))
+ }
+ }
+ }
+
+ if( ! top.y.column %in% names(obs)){
+ tempo.cat <- paste0("ERROR IN miami.R:\nTHE top.y.column PARAMETER MUST BE A COLUMN NAME OF THE FISHER TABLE.\n\ntop.y.column PARAMETER:\n", paste0(top.y.column, collapse = " "), "\n\nCOLUMN NAMES:\n", paste0(names(obs), collapse = "\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ if( ! bottom.y.column %in% names(obs)){
+ tempo.cat <- paste0("ERROR IN miami.R:\nTHE bottom.y.column PARAMETER MUST BE A COLUMN NAME OF THE FISHER TABLE.\n\nbottom.y.column PARAMETER:\n", paste0(bottom.y.column, collapse = " "), "\n\nCOLUMN NAMES:\n", paste0(names(obs), collapse = "\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+
+
+
+ ############ end modifications of imported tables
+
+
+ ############ plotting
+
+
+ #fun_open(width = 12, height = 4, pdf.name = paste0("plot_read_length_", kind)) # must be systematically opened for main.nf
+ png.size <- 1800 # px
+ png(filename = paste0("miami.png"), width = png.size * 2, height = png.size, units = "px", res = 300)
+
+ if(empty.obs == TRUE){
+ fun_gg_empty_graph(text = paste0("NO PLOT DRAWN\nTHE region PARAMETER\nMIGHT BE OUTSIDE\nOF THE RANGE OF THE VCF FILE"))
+ }else if(length(obs) > 0 & nrow(obs) > 0 & ! is.null(x.lim)){
+ marging <- (chr$LENGTH_CUMUL[nrow(chr)] - xmin_plot) * 0.005 # chr$LENGTH_CUMUL and xmin_plot have been corrected depending on x.lim boundaries
+ y.min.pos <- ifelse(is.null(y.lim1), min(obs[ , top.y.column]), min(y.lim1))
+ y.max.pos <- ifelse(is.null(y.lim1), max(obs[ , top.y.column]), max(y.lim1))
+ tempo.gg.name <- "gg.indiv.plot."
+ tempo.gg.count <- 0
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot(obs, aes_string(x = "coord", y = top.y.column)))
+ if(vgrid){
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), geom_vline(
+ xintercept = c(xmin_plot, chr$LENGTH_CUMUL),
+ size = 0.25,
+ color = "grey80"
+ ))
+ }
+ if( ! is.null(y.threshold1)){
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), geom_hline(
+ yintercept = y.threshold1,
+ linetype = "22",
+ size = 0.25,
+ color = "red"
+ ))
+ }
+ if(is.null(color.column)){
+ if(is.null(dot.border.color)){
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), geom_point(
+ aes(color = as.factor(CHROM)),
+ alpha = 1,
+ pch = 16,
+ size = 1
+ ))
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), scale_color_manual(values = rep(c("grey20", "skyblue"), 25)))
+ }else{
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), geom_point(
+ aes(fill = as.factor(CHROM)),
+ alpha = 1,
+ color = dot.border.color,
+ pch = 21,
+ size = 1
+ ))
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), scale_fill_manual(values = rep(c("grey20", "skyblue"), 25)))
+ }
+ }else{
+ if(is.null(dot.border.color)){
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), geom_point(
+ aes(color = color.column),
+ alpha = 1,
+ pch = 16,
+ size = 1
+ ))
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), scale_color_gradient2())
+ }else{
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), geom_point(
+ aes(fill = as.factor(CHROM)),
+ alpha = 1,
+ color = dot.border.color,
+ pch = 21,
+ size = 1
+ ))
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), scale_fill_gradient2())
+ }
+ }
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggtitle(
+ paste0("x.lim: ", ifelse(is.whole, "whole genome", x.lim),
+ ifelse( ! is.null(y.threshold1), paste0(", top threshold: ", y.threshold1), ""),
+ ifelse( ! (is.null(y.threshold2) & is.null(bottom.y.column)), paste0(", bottom threshold: ", y.threshold2), ""),
+ ifelse(y.log1, ", top y-axis: log10", ""), ifelse(y.log2, ", bottom y-axis: log10", ""))
+ ))
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), scale_x_continuous(
+ name = "CHR",
+ expand = c(0, 0), # remove space after after axis limits
+ oob = scales::rescale_none,
+ label = chr$CHR_NAME,
+ breaks= chr$CHR_NAME_POS,
+ limits = c(xmin_plot - marging, max(chr$LENGTH_CUMUL) + marging)
+ ))
+ if(y.log1){
+ if(any(obs[ , top.y.column] <= 0)){
+ tempo.cat <- paste0("ERROR IN miami.R:\nTHE y_log1 PARAMETER CANNOT BE SET TO \"TRUE\" IF 0 OR NEG VALUES IN THE ", top.y.column, " FIELD OF THE TSV OR VCF")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), scale_y_continuous(
+ expand = c(0, 0), # remove space after after axis limits
+ limits = if(reverse1){c(y.max.pos, y.min.pos)}else{c(y.min.pos, y.max.pos)}, # NA indicate that limits must correspond to data limits but ylim() already used
+ oob = scales::rescale_none,
+ trans = "log10",
+ breaks = scales::trans_breaks("log10", function(x){10^x}),
+ labels = scales::trans_format("log10", scales::math_format(10^.x))
+ ))
+ # assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), annotation_logticks(outside = TRUE))
+ }
+ }else{
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), scale_y_continuous(
+ expand = c(0, 0), # remove space after after axis limits
+ limits = if(reverse1){c(y.max.pos, y.min.pos)}else{c(y.min.pos, y.max.pos)}, # NA indicate that limits must correspond to data limits but ylim() already used
+ oob = scales::rescale_none,
+ trans = "identity"
+ ))
+ }
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), theme_bw())
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), theme(
+ plot.title = ggplot2::element_text(size = 8),
+ legend.position=if(is.null(color.column)){"none"},
+ panel.border = element_blank(),
+ panel.grid = element_blank(),
+ axis.ticks.x = element_blank(),
+ axis.ticks.y.left = element_line(size = 0.25),
+ # axis.line.x.bottom = element_line(size = 0.25), # ugly, thus i added geom_hline below
+ axis.line.y.left = element_line(size = 0.25)
+ ))
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), geom_hline(
+ yintercept = ifelse(
+ is.null(y.lim1),
+ ifelse(reverse1, max(obs[ , top.y.column]), min(obs[ , top.y.column])),
+ ifelse(reverse1, max(y.lim1), min(y.lim1))
+ ),
+ size = 0.25
+ ))
+ # add tick lines if vgrid is FALSE
+ if( ! vgrid){
+ gline = linesGrob(y = c(-0.02, 0), gp = gpar(col = "black", lwd = 0.5))
+ for(i2 in c(xmin_plot, chr$LENGTH_CUMUL)){
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotation_custom(gline, xmin = i2, xmax = i2, ymin = -Inf, ymax = Inf))
+ }
+ }
+
+
+ fin.plot1 <- suppressMessages(suppressWarnings(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))))
+ # tempo.output <- ggplot2::ggplot_build(fin.plot1)
+
+ if(is.null(bottom.y.column)){
+ suppressMessages(suppressWarnings(gridExtra::grid.arrange(fin.plot1, ncol=1, nrow = 1)))
+ }else{
+ y.min.pos2 <- ifelse(is.null(y.lim2), min(obs[ , bottom.y.column]), min(y.lim2))
+ y.max.pos2 <- ifelse(is.null(y.lim2), max(obs[ , bottom.y.column]), max(y.lim2))
+ tempo.gg.name2 <- "gg.indiv.plot."
+ tempo.gg.count2 <- 0
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), ggplot(obs, aes_string(x = "coord", y = bottom.y.column)))
+ if(vgrid){
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), geom_vline(
+ xintercept = c(xmin_plot, chr$LENGTH_CUMUL),
+ size = 0.25,
+ color = "grey80"
+ ))
+ }
+ if( ! is.null(y.threshold2)){
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), geom_hline(
+ yintercept = y.threshold2,
+ linetype = "22",
+ size = 0.25,
+ color = "red"
+ ))
+ }
+ if(is.null(color.column)){
+ if(is.null(dot.border.color)){
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), geom_point(
+ aes(color = as.factor(CHROM)),
+ alpha = 1,
+ pch = 16,
+ size = 1
+ ))
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), scale_color_manual(values = rep(c("grey20", "skyblue"), 25)))
+ }else{
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), geom_point(
+ aes(fill = as.factor(CHROM)),
+ alpha = 1,
+ color = dot.border.color,
+ pch = 21,
+ size = 1
+ ))
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), scale_fill_manual(values = rep(c("grey20", "skyblue"), 25)))
+ }
+ }else{
+ if(is.null(dot.border.color)){
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), geom_point(
+ aes(color = color.column),
+ alpha = 1,
+ pch = 16,
+ size = 1
+ ))
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), scale_color_gradient2())
+ }else{
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), geom_point(
+ aes(fill = as.factor(CHROM)),
+ alpha = 1,
+ color = dot.border.color,
+ pch = 21,
+ size = 1
+ ))
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), scale_fill_gradient2())
+ }
+ }
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), scale_x_continuous(
+ expand = c(0, 0), # remove space after after axis limits
+ oob = scales::rescale_none,
+ label = chr$CHR_NAME,
+ breaks= chr$CHR_NAME_POS,
+ limits = c(xmin_plot - marging, max(chr$LENGTH_CUMUL) + marging)
+ ))
+ if(y.log2){
+ if(any(obs[ , bottom.y.column] <= 0)){
+ tempo.cat <- paste0("ERROR IN miami.R:\nTHE y_log2 PARAMETER CANNOT BE SET TO \"TRUE\" IF 0 OR NEG VALUES IN THE ", bottom.y.column, " FIELD OF THE TSV OR VCF")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), scale_y_continuous(
+ expand = c(0, 0), # remove space after after axis limits
+ limits = if(reverse2){c(y.min.pos2, y.max.pos2)}else{c(y.max.pos2, y.min.pos2)}, # NA indicate that limits must correspond to data limits but ylim() already used
+ oob = scales::rescale_none,
+ trans = "log10",
+ breaks = scales::trans_breaks("log10", function(x){10^x}),
+ labels = scales::trans_format("log10", scales::math_format(10^.x))
+ ))
+ # assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), annotation_logticks(outside = TRUE)) #
+ }
+ }else{
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), scale_y_continuous(
+ expand = c(0, 0), # remove space after after axis limits
+ limits = if(reverse2){c(y.min.pos2, y.max.pos2)}else{c(y.max.pos2, y.min.pos2)}, # NA indicate that limits must correspond to data limits but ylim() already used
+ oob = scales::rescale_none,
+ trans = "identity" # equivalent to ggplot2::scale_y_reverse() but create the problem of y-axis label disappearance with y.lim decreasing. Thus, do not use. Use ylim() below and after this
+ ))
+ }
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), theme_bw())
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), theme(
+ legend.position=if(is.null(color.column)){"none"},
+ panel.border = element_blank(),
+ panel.grid = element_blank(),
+ axis.ticks.y.left = element_line(size = 0.25),
+ # axis.line.x.top = element_line(size = 0.25), # is not displayed. Thus, I add a geom_hline below
+ axis.line.y.left = element_line(size = 0.25),
+ axis.title.x = element_blank(),
+ axis.text.x = element_blank(),
+ axis.ticks.x = element_blank(),
+ ))
+ # add x-axis line
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), geom_hline(
+ yintercept = ifelse(
+ is.null(y.lim2),
+ ifelse(reverse2, max(obs[ , bottom.y.column]), min(obs[ , bottom.y.column])),
+ ifelse(reverse2, max(y.lim2), min(y.lim2))
+ ),
+ size = 0.25
+ ))
+ # add tick lines if vgrid is FALSE
+ if( ! vgrid){
+ gline = linesGrob(y = c(1, 1.02), gp = gpar(col = "black", lwd = 0.5))
+ for(i2 in c(xmin_plot, chr$LENGTH_CUMUL)){
+ assign(paste0(tempo.gg.name2, tempo.gg.count2 <- tempo.gg.count2 + 1), ggplot2::annotation_custom(gline, xmin = i2, xmax = i2, ymin = -Inf, ymax = Inf))
+ }
+ }
+
+ fin.plot2 <- suppressMessages(suppressWarnings(eval(parse(text = paste(paste0(tempo.gg.name2, 1:tempo.gg.count2), collapse = " + ")))))
+ gl <- lapply(list(fin.plot1, fin.plot2), ggplotGrob)
+ wd <- do.call(unit.pmax, lapply(gl, "[[", 'widths'))
+ gl <- lapply(gl, function(x){x[['widths']] = wd ; x})
+ if( ! vgrid){
+ gl[[1]]$layout$clip[gl[[1]]$layout$name=="panel"] <- "off"
+ gl[[2]]$layout$clip[gl[[2]]$layout$name=="panel"] <- "off"
+ }
+ suppressMessages(suppressWarnings(gridExtra::grid.arrange(gl[[1]], gl[[2]], ncol=1, nrow = 2)))
+ }
+ }else{
+ fun_gg_empty_graph(text = paste0("NO PLOT DRAWN\nTHE x_lim PARAMETER\nMIGHT BE OUTSIDE\nOF THE RANGE OF THE VCF FILE\nOR THE RANGE OF THE region PARAMETER\nOR NULL"))
+ } #else already dealt above
+
+
+ # end main code
+}
+
+
+
diff --git a/fun_gg_scatter.docx b/fun_gg_scatter.docx
index 2b66af9dea3a6dce8b685194967a6fca2b90d2e6..5023bbe03eeb0cdb74a2127ea59f08a65539ddf0 100755
Binary files a/fun_gg_scatter.docx and b/fun_gg_scatter.docx differ
diff --git a/fun_secu.R b/fun_secu.R
new file mode 100644
index 0000000000000000000000000000000000000000..ed93411d26ac35976b49acbcdbbd9af352a975f3
--- /dev/null
+++ b/fun_secu.R
@@ -0,0 +1,120 @@
+fun_secu <- function(pos = 1, name = NULL){
+ # AIM
+ # Verify that object names in the environment defined by the pos parameter are identical or not to object names in the above environment (following R Scope). This can be used to verify that names used for objects inside a function or in the working environment do not override names of objects already present in the above R environments, following the R scope.
+ # ARGUMENTS
+ # pos: single non nul positive integer indicating the position of the environment checked (argument n of the parent.frame() function). Value 1 means one step above the fun_secu() local environment (by default). This means that when fun_secu(pos = 1) is used inside a function A, it checks if the name of any object in the local environment of this function A is also present in above environments, following R Scope, starting by the just above environment. When fun_secu(pos = 1) is used in the working (Global) environment (named .GlobalEnv), it checks the object names of this .GlobalEnv environment, in the above environments. See the examples below.
+ # name: single character string indicating a string that will be added in the output string, for instance the name of a function inside which fun_secu() is used.
+ # RETURN
+ # A character string indicating the object names of the tested environment that match object names in the above environments, following the R scope, or NULL if no match.
+ # REQUIRED PACKAGES
+ # None
+ # REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
+ # fun_check()
+ # EXAMPLES
+ # Example in the working environment
+ # mean <- 1 # creation of the object mean with value 1 in the .GlobalEnv environment, knowing that the mean() function also exists in the environment base, above .GlobalEnv.
+ # t.test <- 1 # creation of the object t.test with value 1 in the .GlobalEnv environment, knowing that the t.test() function also exists in the environment stats, above .GlobalEnv.
+ # search() # current R scope (order of the successive R environments).
+ # find("mean") # where the objects with the name "mean" are present.
+ # find("t.test") # where the objects with the name "mean" are present.
+ # a <- fun_secu(pos = 1) # test if any object name of the global environment are above environments (or fun_secu(), as pos = 1 is the default value).
+ # a # the output string of fun_sec().
+ # cat(a) # the evaluated output.
+ # fun_secu(pos = 2) # test if any object of the stats environment (one step above .GlobalEnv) are above environments. Returns NULL since no object names of stats are in above environments
+ # Example inside a function
+ # fun1 <- function(){t.test <- 0 ; mean <- 5 ; fun_secu(pos = 1)} # fun_secu() will check if the object names inside the fun1 function exist in the .GlobalEnv environment and above.
+ # fun1()
+ # fun2 <- function(){t.test <- 0 ; mean <- 5 ; fun_secu(pos = 2)} # fun_secu() will check if the object names inside the fun2 function exist in the stats environment and above.
+ # fun2()
+ # fun3 <- function(){t.test <- 0 ; mean <- 5 ; fun_secu(pos = 2, name = "fun3")} # idem fun2() but with the name of the function fun2 indicated. Instead of writting name = "fun3", we can also use name = as.character(sys.calls()[[length(sys.calls())]]), as sys.calls() gives the function name at top stack of the imbricated functions, sys.calls()[[length(sys.calls())]] the name of the just above function. This can also been used for the above function: as.character(sys.call(1))
+ # fun3()
+ # test.pos <- 1
+ # fun_secu(pos = test.pos, name = if(length(sys.calls()) >= test.pos){as.character(sys.calls()[[length(sys.calls()) + 1 - test.pos]])}else{search()[ (1:length(search()))[test.pos - length(sys.calls())]]}) # here is a way to have the name of the tested environment according to test.pos value
+ # DEBUGGING
+ # pos = 1 ; name = "mean" # for function debugging
+ # function name
+ function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
+ arg.user.setting <- as.list(match.call(expand.dots = FALSE))[-1] # list of the argument settings (excluding default values not provided by the user)
+ # end function name
+ # required function checking
+ if(length(utils::find("fun_check", mode = "function")) == 0L){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nREQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ # end required function checking
+ # argument primary checking
+ # arg with no default values
+ # end arg with no default values
+ # using fun_check()
+ 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))
+ tempo <- fun_check(data = pos, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, length = 1, fun.name = function.name) ; eval(ee)
+ if( ! is.null(name)){
+ tempo <- fun_check(data = name, class = "vector", typeof = "character", fun.name = function.name) ; eval(ee)
+ }
+ if( ! is.null(arg.check)){
+ if(any(arg.check) == TRUE){
+ stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
+ }
+ }
+ # end using fun_check()
+ # source("C:/Users/gmillot/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.7/r_debugging_tools-v1.7.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
+ # end argument primary checking
+ # second round of checking and data preparation
+ # management of NA arguments
+ if( ! (all(class(arg.user.setting) == "list") & length(arg.user.setting) == 0)){
+ tempo.arg <- names(arg.user.setting) # values provided by the user
+ tempo.log <- suppressWarnings(sapply(lapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = is.na), FUN = any)) & lapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = length) == 1L # no argument provided by the user can be just NA
+ if(any(tempo.log) == TRUE){ # normally no NA because is.na() used here
+ tempo.cat <- paste0("ERROR IN ", function.name, "\n", ifelse(sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT JUST BE NA:", paste0(tempo.arg[tempo.log], collapse = "\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ }
+ # end management of NA arguments
+ # management of NULL arguments
+ tempo.arg <- c(
+ "pos"
+ )
+ tempo.log <- sapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = is.null)
+ if(any(tempo.log) == TRUE){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\n", ifelse(sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT BE NULL:", paste0(tempo.arg[tempo.log], collapse = "\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ # end management of NULL arguments
+ # end second round of checking and data preparation
+ # main code
+ # match.list <- vector("list", length = (length(sys.calls()) - 1 + length(search()) + ifelse(length(sys.calls()) == 1L, -1, 0))) # match.list is a list of all the environment tested (local of functions and R envs), length(sys.calls()) - 1 to remove the level of the fun_secu() function, sys.calls() giving all the names of the imbricated functions, including fun_secu, ifelse(length(sys.calls()) == 1L, -1, 0) to remove Global env if this one is tested
+ tempo.name <- rev(as.character(unlist(sys.calls()))) # get names of frames (i.e., enclosed env)
+ tempo.frame <- rev(sys.frames()) # get frames (i.e., enclosed env)
+ # dealing with source()
+ # source() used in the Global env creates three frames above the Global env, which should be removed because not very interesting for variable duplications. Add a <<-(sys.frames()) in this code and source anova_contrasts code to see this. With ls(a[[4]]), we can see the content of each env, which are probably elements of source()
+ if(any(sapply(tempo.frame, FUN = environmentName) %in% "R_GlobalEnv")){
+ global.pos <- which(sapply(tempo.frame, FUN = environmentName) %in% "R_GlobalEnv")
+ # remove the global env (because already in search(), and all the oabove env
+ tempo.name <- tempo.name[-c(global.pos:length(tempo.frame))]
+ tempo.frame <- tempo.frame[-c(global.pos:length(tempo.frame))]
+ }
+ # end dealing with source()
+ # might have a problem if(length(tempo.name) == 0L){
+ match.list <- vector("list", length = length(tempo.name) + length(search())) # match.list is a list of all the environment tested (local of functions and R envs), length(sys.calls()) - 1 to remove the level of the fun_secu() function, sys.calls() giving all the names of the imbricated functions, including fun_secu, ifelse(length(sys.calls()) == 1L, -1, 0) to remove Global env if this one is tested
+ ls.names <- c(tempo.name, search()) # names of the functions + names of the search() environments
+ ls.input <- c(tempo.frame, as.list(search())) # environements of the functions + names of the search() environments
+ names(match.list) <- ls.names #
+ match.list <- match.list[-c(1:(pos + 1))] # because we check only above pos
+ ls.tested <- ls.input[[pos + 1]]
+ ls.input <- ls.input[-c(1:(pos + 1))]
+ for(i1 in 1:length(match.list)){
+ if(any(ls(name = ls.input[[i1]], all.names = TRUE) %in% ls(name = ls.tested, all.names = TRUE))){
+ match.list[i1] <- list(ls(name = ls.input[[i1]], all.names = TRUE)[ls(name = ls.input[[i1]], all.names = TRUE) %in% ls(name = ls.tested, all.names = TRUE)])
+ }
+ }
+ if( ! all(sapply(match.list, FUN = is.null))){
+ output <- paste0("SOME VARIABLES ", ifelse(is.null(name), "OF THE CHECKED ENVIRONMENT", paste0("OF ", name)), " ARE ALSO PRESENT IN :\n", paste0(names(match.list[ ! sapply(match.list, FUN = is.null)]), ": ", sapply(match.list[ ! sapply(match.list, FUN = is.null)], FUN = paste0, collapse = " "), collapse = "\n"), "\n")
+ }else{
+ output <- NULL
+ }
+ return(output)
+}
+
diff --git a/fun_test.R b/fun_test.R
new file mode 100644
index 0000000000000000000000000000000000000000..dbebe71e209c10b820b684b0a758d5a1ce49b4db
--- /dev/null
+++ b/fun_test.R
@@ -0,0 +1,797 @@
+# add traceback https://stackoverflow.com/questions/47414119/how-to-read-a-traceback-in-r
+#
+# remove cute.path argument everywhere in this function. But check that cuteDev packages are accessible in the environment of parallelization
+# in if(exists(env.name, where = -1)){ # verify if still ok when fun_test() is inside a function
+# was in red : assign("val", val, envir = get(env.name, env = sys.nframe(), inherit = FALSE)) # var replaced by val
+# was in red : # after return() ? # can we put this after return ? I do not think so
+
+fun_test <- function(
+ fun,
+ arg,
+ val,
+ expect.error = NULL,
+ parall = FALSE,
+ thread.nb = NULL,
+ print.count = 10,
+ plot.fun = FALSE,
+ export = FALSE,
+ res.path = NULL,
+ lib.path = NULL,
+ cute.path = "C:\\Users\\gmillot\\Documents\\Git_projects\\cute_little_R_functions\\cute_little_R_functions.R"
+){
+ # AIM
+ # test combinations of argument values of a function
+ # WARNINGS
+ # Limited to 43 arguments with at least 2 values each. The total number of arguments tested can be more if the additional arguments have a single value. The limit is due to nested "for" loops (https://stat.ethz.ch/pipermail/r-help/2008-March/157341.html), but this limitation is away from the number of tests performed that would be 2^43
+ # ARGUMENTS
+ # fun: character string indicating the name of the function tested (without brackets)
+ # arg: vector of character strings of arguments of fun. At least arguments that do not have default values must be present in this vector
+ # val: list with number of compartments equal to the length of arg, each compartment containing values of the corresponding argument in arg. Each different value must be in a list or in a vector. For instance, argument 3 in arg is a logical argument (values accepted TRUE, FALSE, NA). Thus, compartment 3 of val can be either list(TRUE, FALSE, NA), or c(TRUE, FALSE, NA). NULL value alone must be written list(NULL)
+ # expect.error: list of exactly the same structure as val argument, but containing FALSE or TRUE, depending on whether error is expected (TRUE) or not (FALSE) for each corresponding value of val. A message is returned depending on discrepancies between the expected and observed errors. See the examples below. BEWARE: not always possible to write the expected errors for all the combination of argument values. Ignored if NULL
+ # parall: Single logical value. Force parallelization ?
+ # thread.nb: single numeric integer indicating the number of threads to use if ever parallelization is required. If NULL, all the available threads will be used. Ignored if parall is FALSE
+ # print.count: single interger value. Print a working progress message every print.count during loops. BEWARE: can increase substentially the time to complete the process if using a small integer value, like 10 for instance. Use Inf if no loop message desired
+ # plot.fun: single logical value. Plot the plotting function tested for each test? Ignored if the tested function is not a graphic function
+ # export: single logical value. Export the results into a .RData file and into a .tsv file? If FALSE, return a list into the console (see below). BEWARE: will be automatically set to TRUE if parall is TRUE. This means that when using parallelization, the results are systematically exported, not returned into the console
+ # res.path: single character string indicating the absolute pathway of the folder where the txt results and pdfs, containing all the plots, will be saved. Several txt and pdf, one per thread, if parallelization. Ignored if export is FALSE. Must be specified if parall is TRUE or if export is TRUE
+ # lib.path: vector of characters specifying the absolute pathways of the directories containing the required packages if not in the default directories. Ignored if NULL
+ # cute.path: character string indicating the absolute path of the cute.R file. Will be remove when cute will be a package. Ignored if parall is FALSE
+ # REQUIRED PACKAGES
+ # lubridate
+ # parallel if parall argument is TRUE (included in the R installation packages but not automatically loaded)
+ # pdftools if parall argument is TRUE (included in the R installation packages but not automatically loaded)
+ # If the tested function is in a package, this package must be imported first (no parallelization) or must be in the classical R package folder indicated by the lib.path argument (parallelization)
+ # RETURN
+ # if export is FALSE a list containing:
+ # $fun: the tested function
+ # $ini: the initial input values
+ # $data: a data frame of all the combination tested, containing the following columns:
+ # the different values tested, named by arguments
+ # $kind: a vector of character strings indicating the kind of test result: either "ERROR", or "WARNING", or "OK"
+ # $problem: a logical vector indicating if error or not
+ # $expected.error: optional logical vector indicating the expected error specified in the expect.error argument
+ # $message: either NULL if $kind is always "OK", or the messages
+ # $sys.info: system and packages info
+ # if export is TRUE 1) the same list object into a .RData file, 2) also the $data data frame into a .tsv file, and 3) if expect.error is non NULL and if any discrepancy, the $data data frame into a .tsv file but containing only the rows with discrepancies between expected and observed errors
+ # one or several pdf if a plotting function is tested and if the plot.fun argument is TRUE
+ # REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
+ # fun_check()
+ # fun_get_message()
+ # fun_pack()
+ # EXAMPLES
+ # fun_test(fun = "unique", arg = c("x", "incomparables"), val = list(x = list(1:10, c(1,1,2,8), NA), incomparable = c(TRUE, FALSE, NA)))
+ # fun_test(fun = "unique", arg = c("x", "incomparables"), val = list(x = list(1:10, c(1,1,2,8), NA), incomparable = c(TRUE, FALSE, NA)), expect.error = list(x = list(FALSE, FALSE, TRUE), incomparable = c(FALSE, FALSE, TRUE)))
+ # fun_test(fun = "unique", arg = c("x", "incomparables"), val = list(x = list(1:10, c(1,1,2,8), NA), incomparable = c(TRUE, FALSE, NA)), expect.error = list(x = list(FALSE, FALSE, TRUE), incomparable = c(FALSE, FALSE, TRUE)), export = TRUE, res.path = getwd())
+ # fun_test(fun = "fun_round", arg = c("data", "dec.nb", "after.lead.zero"), val = list(L1 = list(c(1, 1.0002256, 1.23568), "a", NA), L2 = list(2, c(1,3), NA), L3 = c(TRUE, FALSE, NA)))
+ # fun_test(fun = "plot", arg = c("x", "y"), val = list(x = list(1:10, 12:13, NA, (1:10)^2), y = list(1:10, NA, NA)), expect.error = list(x = list(FALSE, TRUE, TRUE, FALSE), y = list(FALSE, TRUE, TRUE)), parall = FALSE, thread.nb = NULL, plot.fun = TRUE, res.path = "C:\\Users\\gmillot\\Desktop\\", lib.path = NULL)
+ # fun_test(fun = "plot", arg = c("x", "y"), val = list(x = list(1:10, 12:13, NA, (1:10)^2), y = list(1:10, NA, NA)), parall = FALSE, thread.nb = 4, plot.fun = TRUE, res.path = "C:\\Users\\gmillot\\Desktop\\", lib.path = "C:\\Program Files\\R\\R-4.3.1\\library\\")
+ # set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10), stringsAsFactors = TRUE) ; fun_test(fun = "fun_gg_boxplot", arg = c("data1", "y", "categ"), val = list(L1 = list(L1 = obs1), L2 = list(L1 = "Time"), L3 = list(L1 = "Group1")))
+ # set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10), stringsAsFactors = TRUE) ; fun_test(fun = "fun_gg_boxplot", arg = c("data1", "y", "categ"), val = list(L1 = list(obs1), L2 = "Time", L3 = "Group1"), parall = FALSE, thread.nb = NULL, plot.fun = TRUE, res.path = "C:\\Users\\gmillot\\Desktop\\", lib.path = "C:\\Program Files\\R\\R-4.3.1\\library\\")
+ # library(ggplot2) ; fun_test(fun = "geom_histogram", arg = c("data", "mapping"), val = list(x = list(data.frame(X = "a", stringsAsFactors = TRUE)), y = list(ggplot2::aes(x = X))), parall = FALSE, thread.nb = NULL, plot.fun = TRUE, res.path = "C:\\Users\\gmillot\\Desktop\\", lib.path = "C:\\Program Files\\R\\R-4.3.1\\library\\") # BEWARE: ggplot2::geom_histogram does not work
+ # DEBUGGING
+ # fun = "unique" ; arg = "x" ; val = list(x = list(1:10, c(1,1,2,8), NA)) ; expect.error = list(x = list(FALSE, FALSE, TRUE)) ; parall = FALSE ; thread.nb = NULL ; plot.fun = FALSE ; export = FALSE ; res.path = "C:\\Users\\gmillot\\Desktop\\" ; lib.path = NULL ; print.count = 1 ; cute.path = "C:\\Users\\gmillot\\Documents\\Git_projects\\cute_little_R_functions\\cute_little_R_functions.R" # for function debugging
+ # fun = "unique" ; arg = c("x", "incomparables") ; val = list(x = list(1:10, c(1,1,2,8), NA), incomparable = c(TRUE, FALSE, NA)) ; expect.error = NULL ; parall = FALSE ; thread.nb = 2 ; plot.fun = FALSE ; export = TRUE ; res.path = "C:\\Users\\gmillot\\Desktop\\" ; lib.path = NULL ; print.count = 10 ; cute.path = "C:\\Users\\gmillot\\Documents\\Git_projects\\cute_little_R_functions\\cute_little_R_functions.R" # for function debugging
+ # fun = "plot" ; arg = c("x", "y") ; val = list(x = list(1:10, 12:13, NA), y = list(1:10, NA, NA)) ; expect.error = list(x = list(FALSE, FALSE, TRUE, FALSE), y = list(FALSE, TRUE, TRUE)) ; print.count = 10 ; parall = FALSE ; thread.nb = NULL ; plot.fun = TRUE ; export = TRUE ; res.path = "C:\\Users\\gmillot\\Desktop\\" ; lib.path = NULL # for function debugging
+ # set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10), stringsAsFactors = TRUE) ; fun = "fun_gg_boxplot" ; arg = c("data1", "y", "categ") ; val = list(L1 = list(L1 = obs1), L2 = list(L1 = "Time"), L3 = list(L1 = "Group1")) ; expect.error = NULL ; print.count = 10 ; parall = FALSE ; thread.nb = NULL ; plot.fun = TRUE ; export = TRUE ; res.path = "C:\\Users\\gmillot\\Desktop\\" ; lib.path = NULL # for function debugging
+ # fun = "unique" ; arg = "x" ; val = list(x = list(1:3, mean)) ; expect.error = list(x = list(TRUE, TRUE)) ; parall = FALSE ; thread.nb = NULL ; plot.fun = FALSE ; export = FALSE ; res.path = "C:\\Users\\gmillot\\Desktop\\" ; lib.path = NULL ; print.count = 1 ; cute.path = "C:\\Users\\gmillot\\Documents\\Git_projects\\cute_little_R_functions\\cute_little_R_functions.R" # for function debugging
+ # function name
+ ini <- match.call(expand.dots = FALSE) # initial parameters
+ function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
+ arg.names <- names(formals(fun = sys.function(sys.parent(n = 2)))) # names of all the arguments
+ arg.user.setting <- as.list(match.call(expand.dots = FALSE))[-1] # list of the argument settings (excluding default values not provided by the user)
+ # end function name
+ # required function checking
+ req.function <- c(
+ "fun_check",
+ "fun_get_message",
+ "fun_pack"
+ )
+ 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 ", function.name, "\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() to be able to add several messages between ==
+ }
+ # end required function checking
+ # reserved words
+ # end reserved words
+ # arg with no default values
+ mandat.args <- c(
+ "fun",
+ "arg",
+ "val"
+ )
+ tempo <- eval(parse(text = paste0("missing(", paste0(mandat.args, collapse = ") | missing("), ")")))
+ if(any(tempo)){ # normally no NA for missing() output
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", ifelse(sum(tempo, na.rm = TRUE) > 1, "S HAVE", " HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", paste0(mandat.args[tempo], collapse = "\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ # end arg with no default values
+ # 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))
+ tempo <- fun_check(data = fun, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = arg, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = val, class = "list", fun.name = function.name) ; eval(ee)
+ if( ! is.null(expect.error)){
+ tempo <- fun_check(data = expect.error, class = "list", fun.name = function.name) ; eval(ee)
+ }
+ tempo <- fun_check(data = parall, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
+ if(parall == TRUE){
+ 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 = function.name) ; eval(ee)
+ if(tempo$problem == FALSE & thread.nb < 1){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": thread.nb PARAMETER MUST EQUAL OR GREATER THAN 1: ", thread.nb)
+ text.check <- c(text.check, tempo.cat)
+ arg.check <- c(arg.check, TRUE)
+ }
+ }
+ }
+ tempo <- fun_check(data = print.count, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, neg.values = FALSE, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = plot.fun, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = export, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
+ if( ! is.null(res.path)){
+ tempo <- fun_check(data = res.path, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
+ }
+ if( ! is.null(lib.path)){
+ tempo <- fun_check(data = lib.path, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
+ }
+ tempo <- fun_check(data = cute.path, class = "vector", typeof = "character", length = 1, fun.name = function.name) ; eval(ee)
+ if( ! is.null(arg.check)){
+ if(any(arg.check) == TRUE){
+ stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
+ }
+ }
+ # end using fun_check()
+ # source("C:/Users/gmillot/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.7/r_debugging_tools-v1.7.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
+ # end argument primary checking
+ # second round of checking and data preparation
+ # new environment
+ env.name <- paste0("env", as.numeric(Sys.time()))
+ if(exists(env.name, where = -1)){ # verify if still ok when fun_info() is inside a function
+ tempo.cat <- paste0("ERROR IN ", function.name, ": ENVIRONMENT env.name ALREADY EXISTS. PLEASE RERUN ONCE")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ assign(env.name, new.env())
+ assign("data", data, envir = get(env.name, env = sys.nframe(), inherit = FALSE)) # data assigned in a new envir for test
+ }
+ # end new environment
+ # management of NA arguments
+ if( ! (all(class(arg.user.setting) == "list") & length(arg.user.setting) == 0)){
+ tempo.arg <- names(arg.user.setting) # values provided by the user
+ tempo.log <- suppressWarnings(sapply(lapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = is.na), FUN = any)) & lapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = length) == 1L # no argument provided by the user can be just NA
+ if(any(tempo.log) == TRUE){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\n", ifelse(sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT JUST BE NA:", paste0(tempo.arg[tempo.log], collapse = "\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ }
+ # end management of NA arguments
+ # management of NULL arguments
+ tempo.arg <-c(
+ "fun",
+ "arg",
+ "val",
+ # "expect.erro", # because can be NULL
+ "parall",
+ # "thread.nb", # because can be NULL
+ "print.count",
+ "plot.fun",
+ "export",
+ # "res.path", # because can be NULL
+ # "lib.path", # because can be NULL
+ "cute.path"
+ )
+ tempo.log <- sapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = is.null)
+ if(any(tempo.log) == TRUE){# normally no NA with is.null()
+ tempo.cat <- paste0("ERROR IN ", function.name, ":\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")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ # end management of NULL arguments
+ # code that protects set.seed() in the global environment
+ # end code that protects set.seed() in the global environment
+ # warning initiation
+ # end warning initiation
+ # other checkings
+ if(grepl(x = fun, pattern = "()$")){ # remove ()
+ fun <- sub(x = fun, pattern = "()$", replacement = "")
+ }
+ if( ! exists(fun)){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": CHARACTER STRING IN fun ARGUMENT DOES NOT EXIST IN THE R WORKING ENVIRONMENT: ", paste(fun, collapse = "\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }else if( ! all(base::class(get(fun)) == "function")){ # here no env = sys.nframe(), inherit = FALSE for get() because fun is a function in the classical scope
+ tempo.cat <- paste0("ERROR IN ", function.name, ": fun ARGUMENT IS NOT CLASS \"function\" BUT: ", paste(base::class(get(fun)), collapse = "\n"), "\nCHECK IF ANY CREATED OBJECT WOULD HAVE THE NAME OF THE TESTED FUNCTION")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }
+ if(tempo$problem == FALSE & base::length(arg) == 0L){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": arg ARGUMENT CANNOT BE LENGTH 0")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }
+ for(i2 in 1:base::length(val)){ # length(val) must be aequal to nb of arguments
+ tempo1 <- fun_check(data = val[[i2]], class = "vector", na.contain = TRUE, fun.name = function.name)
+ tempo2 <- fun_check(data = val[[i2]], class = "list", na.contain = TRUE, fun.name = function.name)
+ if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": COMPARTMENT ", i2, " OF val ARGUMENT MUST BE A VECTOR OR A LIST")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }else if(tempo1$problem == FALSE){ # vector split into list compartments
+ val[[i2]] <- split(x = val[[i2]], f = 1:base::length(val[[i2]]))
+ }
+ }
+ if(base::length(arg) != base::length(val)){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": LENGTH OF arg ARGUMENT MUST BE IDENTICAL TO LENGTH OF val ARGUMENT:\nHERE IT IS: ", base::length(arg), " VERSUS ", base::length(val))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }
+ args <- names(formals(get(fun))) # here no env = sys.nframe(), inherit = FALSE for get() because fun is a function in the classical scope
+ if( ! all(arg %in% args)){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": SOME OF THE STRINGS IN arg ARE NOT ARGUMENTS OF fun\nfun ARGUMENTS: ", paste(args, collapse = " "),"\nPROBLEMATIC STRINGS IN arg: ", paste(arg[ ! arg %in% args], collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }
+ if(sum(sapply(val, FUN = length) > 1) > 43){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": CANNOT TEST MORE THAN 43 ARGUMENTS IF THEY ALL HAVE AT LEAST 2 VALUES EACH\nHERE THE NUMBER IS: ", sum(sapply(val, FUN = length) > 1))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }
+ if( ! is.null(expect.error)){
+ if(base::length(val) != base::length(expect.error)){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": LENGTH OF val ARGUMENT MUST BE IDENTICAL TO LENGTH OF expect.error ARGUMENT:\nHERE IT IS: ", base::length(val), " VERSUS ", base::length(expect.error))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }
+ for(i3 in 1:base::length(expect.error)){
+ tempo1 <- fun_check(data = expect.error[[i3]], class = "vector", mode = "logical", fun.name = function.name)
+ tempo2 <- fun_check(data = expect.error[[i3]], class = "list", fun.name = function.name)
+ if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": COMPARTMENT ", i3, " OF expect.error ARGUMENT MUST BE TRUE OR FALSE")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }else if(tempo1$problem == FALSE){ # vector split into list compartments
+ expect.error[[i3]] <- split(x = expect.error[[i3]], f = 1:base::length(expect.error[[i3]]))
+ }
+ }
+ }
+ if( ! is.null(res.path)){
+ if( ! all(dir.exists(res.path))){ # separation to avoid the problem of tempo$problem == FALSE and res.path == NA
+ tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE res.path ARGUMENT DOES NOT EXISTS:\n", paste(res.path, collapse = "\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }
+ }
+ if(parall == TRUE & is.null(res.path)){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": res.path ARGUMENT MUST BE SPECIFIED IF parall ARGUMENT IS TRUE")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }
+ if(is.null(res.path) & export == TRUE){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": res.path ARGUMENT MUST BE SPECIFIED IF export ARGUMENT TRUE")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }
+ if(parall == TRUE & export == FALSE){
+ export <- TRUE
+ tempo.cat <- paste0("WARNING FROM ", function.name, ": export ARGUMENT CONVERTED TO TRUE BECAUSE thread.nb ARGUMENT IS NOT NULL")
+ warning(paste0("\n", tempo.cat, "\n"), call. = FALSE)
+ }
+ if( ! is.null(lib.path)){
+ if( ! all(dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
+ tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", paste(lib.path, collapse = "\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }
+ }
+ if(parall == TRUE){
+ if(grepl(x = cute.path, pattern = "^http")){
+ tempo.error1 <- any(grepl(x = fun_get_message(data = "source(cute.path)", kind = "error", header = FALSE, env = get(env.name, env = sys.nframe(), inherit = FALSE)), pattern = "^[Ee]rror"))
+ tempo.error2 <- FALSE
+ }else{
+ tempo.error1 <- FALSE
+ tempo.error2 <- ! file.exists(cute.path)
+ }
+ if(tempo.error1 | tempo.error2){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(grepl(x = cute.path, pattern = "^http"), "URL", "FILE"), " PATH INDICATED IN THE cute.path PARAMETER DOES NOT EXISTS:\n", cute.path)
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
+ }
+ }
+ # end other checkings
+ # reserved word checking
+ # end reserved word checking
+ # end second round of checking and data preparation
+ # package checking
+ fun_pack(req.package = c("lubridate"), lib.path = lib.path)
+ if(parall == TRUE){
+ fun_pack(req.package = c("parallel", "pdftools"), lib.path = lib.path)
+ }
+ # end package checking
+ # declaration of special plot functions
+ sp.plot.fun <- c("fun_gg_scatter", "fun_gg_bar", "fun_gg_boxplot")
+ # end declaration of special plot functions
+ # main code
+ ini.warning.length <- base::options()$warning.length
+ options(warning.length = 8170)
+ warn <- NULL
+ warn.count <- 0
+ cat("\nfun_test JOB IGNITION\n")
+ ini.date <- Sys.time()
+ ini.time <- as.numeric(ini.date) # time of process begin, converted into seconds
+ if(export == TRUE){
+ res.path <- paste0(res.path, "/fun_test_res_", trunc(ini.time))
+ if(dir.exists(res.path)){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": FOLDER ALREADY EXISTS\n", res.path, "\nPLEASE RERUN ONCE")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ dir.create(res.path)
+ }
+ }
+ total.comp.nb <- prod(sapply(val, FUN = "length"))
+ cat(paste0("\nTHE TOTAL NUMBER OF TESTS IS: ", total.comp.nb, "\n"))
+ # creation of the txt instruction that includes several loops
+ loop.string <- NULL
+ end.loop.string <- NULL
+ fun.args <- NULL
+ fun.args2 <- NULL
+ error.values <- NULL
+ arg.values <- "list("
+ for(i1 in 1:base::length(arg)){
+ if(parall == FALSE){
+ if(base::length(val[[i1]]) > 1){ # loop only if more than one value in base::length(val[[i1]])
+ loop.string <- paste0(loop.string, "for(i", i1, " in 1:", base::length(val[[i1]]), "){")
+ end.loop.string <- paste0(end.loop.string, "}")
+ }
+ }else{
+ loop.string <- "for(i in x){"
+ end.loop.string <- "}"
+ }
+ fun.args <- paste0(
+ fun.args,
+ ifelse(i1 == 1L, "", ", "),
+ arg[i1],
+ " = val[[",
+ i1,
+ "]][[",
+ if(parall == FALSE){
+ if(base::length(val[[i1]]) > 1){
+ paste0("i", i1)
+ }else{
+ "1" # a unique element in val[[i1]]
+ }
+ }else{
+ paste0("i.list[[", i1, "]][i]")
+ },
+ "]]"
+ )
+ fun.args2 <- paste0(
+ fun.args2,
+ ifelse(i1 == 1L, "", ", "),
+ arg[i1],
+ " = val[[",
+ i1,
+ "]][[', ",
+ if(parall == FALSE){
+ if(base::length(val[[i1]]) > 1){
+ paste0("i", i1)
+ }else{
+ "1" # a unique element in val[[i1]]
+ }
+ }else{
+ paste0("i.list[[", i1, "]][i]")
+ },
+ ", ']]"
+ )
+ arg.values <- paste0(
+ arg.values,
+ "val[[", i1, "]][[",
+ if(parall == FALSE){
+ if(base::length(val[[i1]]) > 1){
+ paste0("i", i1)
+ }else{
+ "1" # a unique element in val[[i1]]
+ }
+ }else{
+ paste0("i.list[[", i1, "]][i]")
+ },
+ "]]",
+ ifelse(i1 == base::length(arg), "", ", ")
+ )
+ error.values <- paste0(
+ error.values,
+ ifelse(i1 == 1L, "", " | "),
+ "expect.error[[", i1, "]][[",
+ if(parall == FALSE){
+ if(base::length(expect.error[[i1]]) > 1){
+ paste0("i", i1)
+ }else{
+ "1" # a unique element in expect.error[[i1]]
+ }
+ }else{
+ paste0("i.list[[", i1, "]][i]")
+ },
+ "]]"
+ )
+ }
+ arg.values <- paste0(arg.values, ")")
+ fun.test <- paste0(fun, "(", fun.args, ")")
+ fun.test2 <- paste0("paste0('", fun, "(", fun.args2, ")')")
+ # plot title for special plot functions
+ if(plot.fun == TRUE){
+ plot.kind <- "classic"
+ if(fun %in% sp.plot.fun){
+ plot.kind <- "special"
+ if(any(arg %in% "title")){ # this is for the special functions
+ tempo.match <- regmatches(x = fun.test, m = regexpr(text = fun.test, pattern = "title = .+[,)]"))
+ tempo.match <- substring(tempo.match , 1, nchar(tempo.match) - 1)
+ fun.test <- sub(x = fun.test, pattern = tempo.match, replacement = paste0(tempo.match, "\ntempo.title"))
+ }else{
+ fun.test <- sub(x = fun.test, pattern = ")$", replacement = ", title = tempo.title)")
+ }
+ }
+ }
+ # end plot title for special plot functions
+ kind <- character()
+ problem <- logical()
+ expected.error <- logical()
+ res <- character()
+ count <- 0
+ print.count.loop <- 0
+ plot.count <- 0
+ if(base::length(arg) == 1L){
+ data <- data.frame()
+ }else{ # base::length(arg) == 0L already tested above
+ data <- data.frame(t(vector("character", base::length(arg))), stringsAsFactors = FALSE)[-1, ] # -1 to remove the single row created and to have an empty data frame with base::length(arg) columns
+ }
+ code <- paste(
+ loop.string, '
+count <- count + 1
+print.count.loop <- print.count.loop + 1
+arg.values.print <- eval(parse(text = arg.values)) # recover the list of the i1 compartment
+for(j3 in 1:base::length(arg.values.print)){ # WARNING: do not use i1, i2 etc., here because already in loop.string
+tempo.capt <- capture.output(tempo.error <- fun_get_message(data = paste0("paste(arg.values.print[[", j3, "]])"), kind = "error", header = FALSE, print.no = FALSE, env = get(env.name, env = sys.nframe(), inherit = FALSE))) # collapsing arg.values sometimes does not work (with function for instance)
+if( ! is.null(tempo.error)){
+arg.values.print[[j3]] <- paste0("SPECIAL VALUE OF CLASS ", base::class(arg.values.print[[j3]]), " AND TYPE ", base::typeof(arg.values.print[[j3]]))
+}
+}
+data <- rbind(data, as.character(sapply(arg.values.print, FUN = "paste", collapse = " ")), stringsAsFactors = FALSE) # each colum is a test
+tempo.capt <- capture.output(tempo.try.error <- fun_get_message(data = eval(parse(text = fun.test2)), kind = "error", header = FALSE, print.no = FALSE, env = get(env.name, env = sys.nframe(), inherit = FALSE))) # data argument needs a character string but eval(parse(text = fun.test2)) provides it (eval parse replace the i1, i2, etc., by the correct values, meaning that only val is required in the env.name environment)
+tempo.capt <- capture.output(tempo.try.warning <- fun_get_message(data = eval(parse(text = fun.test2)), kind = "warning", header = FALSE, env = get(env.name, env = sys.nframe(), inherit = FALSE), print.no = FALSE)) # data argument needs a character string but eval(parse(text = fun.test2)) provides it (eval parse replace the i1, i2, etc., by the correct values, meaning that only val is required in the env.name environment)
+if( ! is.null(expect.error)){
+expected.error <- c(expected.error, eval(parse(text = error.values)))
+}
+if( ! is.null(tempo.try.error)){
+kind <- c(kind, "ERROR")
+problem <- c(problem, TRUE)
+res <- c(res, tempo.try.error)
+}else{
+if( ! is.null(tempo.try.warning)){
+kind <- c(kind, "WARNING")
+problem <- c(problem, FALSE)
+res <- c(res, tempo.try.warning)
+}else{
+kind <- c(kind, "OK")
+problem <- c(problem, FALSE)
+res <- c(res, "")
+}
+if(plot.fun == TRUE){
+invisible(dev.set(window.nb))
+plot.count <- plot.count + 1
+tempo.title <- paste0("test_", sprintf(paste0("%0", nchar(total.comp.nb), "d"), ifelse(parall == FALSE, count, x[count])))
+if(plot.kind == "classic"){
+eval(parse(text = fun.test))
+tempo <- fun_post_plot(corner.text = tempo.title)
+}else if(plot.kind == "special"){
+eval(parse(text = fun.test))
+}else{
+tempo.cat <- paste0("INTERNAL CODE ERROR 1 IN ", function.name, ": CODE HAS TO BE MODIFIED")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+}
+}
+}
+if(print.count.loop == print.count){
+print.count.loop <- 0
+tempo.time <- as.numeric(Sys.time())
+tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - ini.time))
+final.loop <- (tempo.time - ini.time) / count * ifelse(parall == FALSE, total.comp.nb, base::length(x)) # expected duration in seconds # intra nb.compar loop lapse: time lapse / cycles done * cycles remaining
+final.exp <- as.POSIXct(final.loop, origin = ini.date)
+cat(paste0(ifelse(parall == FALSE, "\n", paste0("\nIN PROCESS ", process.id, " | ")), "LOOP ", format(count, big.mark=","), " / ", format(ifelse(parall == FALSE, total.comp.nb, base::length(x)), big.mark=","), " | TIME SPENT: ", tempo.lapse, " | EXPECTED END: ", final.exp))
+}
+if(count == ifelse(parall == FALSE, total.comp.nb, base::length(x))){
+tempo.time <- as.numeric(Sys.time())
+tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - ini.time))
+cat(paste0(ifelse(parall == FALSE, "\nLOOP PROCESS ENDED | ", paste0("\nPROCESS ", process.id, " ENDED | ")), "LOOP ", format(count, big.mark=","), " / ", format(ifelse(parall == FALSE, total.comp.nb, base::length(x)), big.mark=","), " | TIME SPENT: ", tempo.lapse, "\n\n"))
+}
+',
+end.loop.string
+ )
+ # end creation of the txt instruction that includes several loops
+ if(parall == TRUE){
+ # list of i numbers that will be split
+ i.list <- vector("list", base::length(val)) # positions to split in parallel jobs
+ for(i2 in 1:base::length(arg)){
+ if(i2 == 1L){
+ tempo.divisor <- total.comp.nb / base::length(val[[i2]])
+ i.list[[i2]] <- rep(1:base::length(val[[i2]]), each = as.integer(tempo.divisor))
+ tempo.multi <- base::length(val[[i2]])
+ }else{
+ tempo.divisor <- tempo.divisor / base::length(val[[i2]])
+ i.list[[i2]] <- rep(rep(1:base::length(val[[i2]]), each = as.integer(tempo.divisor)), time = as.integer(tempo.multi))
+ tempo.multi <- tempo.multi * base::length(val[[i2]])
+ }
+ }
+ # end list of i numbers that will be split
+ tempo.cat <- paste0("PARALLELIZATION INITIATED AT: ", ini.date)
+ cat(paste0("\n", tempo.cat, "\n"))
+ tempo.thread.nb = parallel::detectCores(all.tests = FALSE, logical = TRUE) # detect the number of threads
+ 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"))
+ Clust <- parallel::makeCluster(thread.nb, outfile = paste0(res.path, "/fun_test_parall_log.txt")) # outfile to print or cat during parallelization (only possible in a file, outfile = "" do not work on windows)
+ tempo.cat <- paste0("SPLIT OF TEST NUMBERS IN PARALLELISATION:")
+ cat(paste0("\n ", tempo.cat, "\n"))
+ cluster.list <- parallel::clusterSplit(Clust, 1:total.comp.nb) # split according to the number of cluster
+ str(cluster.list) # using print(str()) add a NULL below the result
+ cat("\n")
+ 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 = cluster.list,
+ function.name = function.name,
+ ini = ini,
+ thread.nb = thread.nb,
+ print.count = print.count,
+ total.comp.nb = total.comp.nb,
+ sp.plot.fun = sp.plot.fun,
+ i.list = i.list,
+ fun.tested = fun,
+ arg.values = arg.values,
+ fun.test = fun.test,
+ fun.test2 = fun.test2,
+ kind = kind,
+ problem = problem,
+ res = res,
+ count = count,
+ plot.count = plot.count,
+ data = data,
+ code = code,
+ plot.fun = plot.fun,
+ res.path = res.path,
+ lib.path = lib.path,
+ cute.path = cute.path,
+ fun = function(
+ x,
+ function.name,
+ ini,
+ thread.nb,
+ print.count,
+ total.comp.nb,
+ sp.plot.fun,
+ i.list,
+ fun.tested,
+ arg.values,
+ fun.test,
+ fun.test2,
+ kind,
+ problem,
+ res,
+ count,
+ plot.count,
+ data,
+ code,
+ plot.fun,
+ res.path,
+ lib.path,
+ cute.path
+ ){
+ # check again: very important because another R
+ process.id <- Sys.getpid()
+ cat(paste0("\nPROCESS ID ", process.id, " -> TESTS ", x[1], " TO ", x[base::length(x)], "\n"))
+ source(cute.path, local = .GlobalEnv)
+ fun_pack(req.package = "lubridate", 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
+ # plot management
+ if(plot.fun == TRUE){
+ pdf(file = paste0(res.path, "/plots_from_fun_test_", x[1], ifelse(base::length(x) == 1L, ".pdf", paste0("-", x[base::length(x)], ".pdf"))))
+ }else{
+ pdf(file = NULL) # send plots into a NULL file, no pdf file created
+ }
+ window.nb <- dev.cur()
+ invisible(dev.set(window.nb))
+ # end plot management
+ # new environment
+ ini.date <- Sys.time()
+ ini.time <- as.numeric(ini.date) # time of process begin, converted into
+ env.name <- paste0("env", ini.time)
+ if(exists(env.name, where = -1)){ # verify if still ok when fun_test() is inside a function
+ tempo.cat <- paste0("ERROR IN ", function.name, ": ENVIRONMENT env.name ALREADY EXISTS. PLEASE RERUN ONCE")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ assign(env.name, new.env())
+ assign("val", val, envir = get(env.name, env = sys.nframe(), inherit = FALSE)) # var replaced by val
+ }
+ # end new environment
+ print.count.loop <- 0
+ suppressMessages(suppressWarnings(eval(parse(text = code))))
+ colnames(data) <- arg
+ if( ! is.null(expect.error)){
+ data <- data.frame(data, kind = kind, problem = problem, expected.error = expected.error, message = res, stringsAsFactors = FALSE)
+ }else{
+ data <- data.frame(data, kind = kind, problem = problem, message = res, stringsAsFactors = FALSE)
+ }
+ row.names(data) <- paste0("test_", sprintf(paste0("%0", nchar(total.comp.nb), "d"), x))
+ sys.info <- sessionInfo()
+ sys.info$loadedOnly <- sys.info$loadedOnly[order(names(sys.info$loadedOnly))] # sort the packages
+ invisible(dev.off(window.nb))
+ rm(env.name) # optional, because should disappear at the end of the function execution
+ # output
+ output <- list(fun = fun, ini = ini, data = data, sys.info = sys.info)
+ save(output, file = paste0(res.path, "/fun_test_", x[1], ifelse(base::length(x) == 1L, ".RData", paste0("-", x[base::length(x)], ".RData"))))
+ if(plot.fun == TRUE & plot.count == 0L){
+ warn.count <- warn.count + 1
+ tempo.warn <- paste0("(", warn.count,") IN PROCESS ", process.id, ": NO PDF PLOT BECAUSE ONLY ERRORS REPORTED")
+ warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ file.remove(paste0(res.path, "/plots_from_fun_test_", x[1], ifelse(base::length(x) == 1L, ".pdf", paste0("-", x[base::length(x)], ".pdf"))))
+ }
+ table.out <- as.matrix(data)
+ # table.out[table.out == ""] <- " " # does not work # because otherwise read.table() converts "" into NA
+ table.out <- gsub(table.out, pattern = "\n", replacement = " ")
+ write.table(table.out, file = paste0(res.path, "/table_from_fun_test_", x[1], ifelse(base::length(x) == 1L, ".tsv", paste0("-", x[base::length(x)], ".tsv"))), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n", na = "")
+ }
+ )
+ parallel::stopCluster(Clust)
+ # files assembly
+ if(base::length(cluster.list) > 1){
+ for(i2 in 1:base::length(cluster.list)){
+ tempo.file <- paste0(res.path, "/table_from_fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".tsv", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".tsv"))) # txt file
+ tempo <- read.table(file = tempo.file, header = TRUE, stringsAsFactors = FALSE, sep = "\t", row.names = 1, comment.char = "", colClasses = "character") # row.names = 1 (1st column) because now read.table() adds a NA in the header if the header starts by a tabulation, comment.char = "" because colors with #, colClasses = "character" otherwise convert "" (from NULL) into NA
+ if(file.exists(paste0(res.path, "/plots_from_fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".pdf", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".pdf"))))){
+ tempo.pdf <- paste0(res.path, "/plots_from_fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".pdf", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".pdf"))) # pdf file
+ }else{
+ tempo.pdf <- NULL
+ }
+ tempo.rdata <- paste0(res.path, "/fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".RData", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".RData"))) # RData file
+ if(i2 == 1L){
+ final.file <- tempo
+ final.pdf <- tempo.pdf
+ # new env for RData combining
+ env.name <- paste0("env", ini.time)
+ if(exists(env.name, where = -1)){ # verify if still ok when fun_test() is inside a function
+ tempo.cat <- paste0("ERROR IN ", function.name, ": ENVIRONMENT env.name ALREADY EXISTS. PLEASE RERUN ONCE")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ # end new env for RData combining
+ }else{
+ assign(env.name, new.env())
+ load(tempo.rdata, envir = get(env.name))
+ tempo.rdata1 <- tempo.rdata
+ assign("final.output", get("output", envir = get(env.name)), envir = get(env.name))
+ }
+ }else{
+ final.file <- rbind(final.file, tempo, stringsAsFactors = TRUE)
+ final.pdf <- c(final.pdf, tempo.pdf)
+ load(tempo.rdata, envir = get(env.name))
+ if( ! identical(get("final.output", envir = get(env.name))[c("R.version", "locale", "platform")], get("output", envir = get(env.name))[c("R.version", "locale", "platform")])){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": DIFFERENCE BETWEEN OUTPUTS WHILE THEY SHOULD BE IDENTICAL\nPLEASE CHECK\n", tempo.rdata1, "\n", tempo.rdata)
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ # add the differences in RData $sysinfo into final.output
+ tempo.base1 <- sort(get("final.output", envir = get(env.name))$sys.info$basePkgs)
+ tempo.base2 <- sort(get("output", envir = get(env.name))$sys.info$basePkgs)
+ tempo.other1 <- names(get("final.output", envir = get(env.name))$sys.info$otherPkgs)
+ tempo.other2 <- names(get("output", envir = get(env.name))$sys.info$otherPkgs)
+ tempo.loaded1 <- names(get("final.output", envir = get(env.name))$sys.info$loadedOnly)
+ tempo.loaded2 <- names(get("output", envir = get(env.name))$sys.info$loadedOnly)
+ assign("final.output", {
+ x <- get("final.output", envir = get(env.name))
+ y <- get("output", envir = get(env.name))
+ x$sys.info$basePkgs <- sort(unique(tempo.base1, tempo.base2))
+ if( ! all(tempo.other2 %in% tempo.other1)){
+ x$sys.info$otherPkgs <- c(x$sys.info$otherPkgs, y$sys.info$otherPkgs[ ! (tempo.other2 %in% tempo.other1)])
+ x$sys.info$otherPkgs <- x$sys.info$otherPkgs[order(names(x$sys.info$otherPkgs))]
+ }
+ if( ! all(tempo.loaded2 %in% tempo.loaded1)){
+ x$sys.info$loadedOnly <- c(x$sys.info$loadedOnly, y$sys.info$loadedOnly[ ! (tempo.loaded2 %in% tempo.loaded1)])
+ x$sys.info$loadedOnly <- x$sys.info$loadedOnly[order(names(x$sys.info$loadedOnly))]
+ }
+ x
+ }, envir = get(env.name))
+ # add the differences in RData $sysinfo into final.output
+ }
+ }
+ file.remove(c(tempo.file, tempo.rdata))
+ }
+ # combine pdf and save
+ if( ! is.null(final.pdf)){
+ pdftools::pdf_combine(
+ input = final.pdf,
+ output = paste0(res.path, "/plots_from_fun_test_1-", total.comp.nb, ".pdf")
+ )
+ file.remove(final.pdf)
+ }
+ # end combine pdf and save
+ # save RData
+ assign("output", c(get("final.output", envir = get(env.name)), data = list(final.file)), envir = get(env.name))
+ save(output, file = paste0(res.path, "/fun_test__1-", total.comp.nb, ".RData"), envir = get(env.name))
+ rm(env.name) # optional, because should disappear at the end of the function execution
+ # end save RData
+ # save txt
+ write.table(final.file, file = paste0(res.path, "/table_from_fun_test_1-", total.comp.nb, ".tsv"), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n", na = "")
+ # end save txt
+ if( ! is.null(expect.error)){
+ final.file <- final.file[ ! final.file$problem == final.file$expected.error, ]
+ if(nrow(final.file) == 0L){
+ cat(paste0("NO DISCREPANCY BETWEEN EXPECTED AND OBSERVED ERRORS\n\n"))
+ }else{
+ cat(paste0("DISCREPANCIES BETWEEN EXPECTED AND OBSERVED ERRORS (SEE THE discrepancy_table_from_fun_test_1-", total.comp.nb, ".tsv FILE)\n\n"))
+ write.table(final.file, file = paste0(res.path, "/discrepancy_table_from_fun_test_1-", total.comp.nb, ".tsv"), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n", na = "")
+ }
+ }
+ }
+ # end files assembly
+ }else{
+ # plot management
+ if(plot.fun == TRUE){
+ pdf(file = paste0(res.path, "/plots_from_fun_test_1", ifelse(total.comp.nb == 1L, ".pdf", paste0("-", total.comp.nb, ".pdf"))))
+ }else{
+ pdf(file = NULL) # send plots into a NULL file, no pdf file created
+ }
+ window.nb <- dev.cur()
+ invisible(dev.set(window.nb))
+ # end plot management
+ # new environment
+ env.name <- paste0("env", ini.time)
+ if(exists(env.name, where = -1)){
+ tempo.cat <- paste0("ERROR IN ", function.name, ": ENVIRONMENT env.name ALREADY EXISTS. PLEASE RERUN ONCE")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ assign(env.name, new.env())
+ assign("val", val, envir = get(env.name, env = sys.nframe(), inherit = FALSE)) # var replaced by val
+ }
+ # end new environment
+ suppressMessages(suppressWarnings(eval(parse(text = code))))
+ colnames(data) <- arg
+ expect.data <- data.frame()
+ if( ! is.null(expect.error)){
+ data <- data.frame(data, kind = kind, problem = problem, expected.error = expected.error, message = res, stringsAsFactors = FALSE)
+ }else{
+ data <- data.frame(data, kind = kind, problem = problem, message = res, stringsAsFactors = FALSE)
+ }
+ row.names(data) <- paste0("test_", sprintf(paste0("%0", nchar(total.comp.nb), "d"), 1:total.comp.nb))
+ sys.info <- sessionInfo()
+ sys.info$loadedOnly <- sys.info$loadedOnly[order(names(sys.info$loadedOnly))] # sort the packages
+ invisible(dev.off(window.nb))
+ rm(env.name) # optional, because should disappear at the end of the function execution
+ # output
+ output <- list(fun = fun, ini = ini, data = data, sys.info = sys.info)
+ if(plot.fun == TRUE & plot.count == 0L){
+ warn.count <- warn.count + 1
+ tempo.warn <- paste0("(", warn.count,") NO PDF PLOT BECAUSE ONLY ERRORS REPORTED")
+ warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ file.remove(paste0(res.path, "/plots_from_fun_test_1", ifelse(total.comp.nb == 1L, ".pdf", paste0("-", total.comp.nb, ".pdf"))))
+ }
+ if( ! is.null(expect.error)){
+ expect.data <- output$data[ ! output$data$problem == output$data$expected.error, ]
+ if(nrow(expect.data) == 0L){
+ cat(paste0("NO DISCREPANCY BETWEEN EXPECTED AND OBSERVED ERRORS\n\n"))
+ }else{
+ cat(paste0("DISCREPANCIES BETWEEN EXPECTED AND OBSERVED ERRORS (SEE THE ", if(export == TRUE){paste0("discrepancy_table_from_fun_test_1", ifelse(total.comp.nb == 1L, "", paste0("-", total.comp.nb)), ".tsv FILE")}else{"$data RESULT"}, ")\n\n"))
+ if(export == TRUE){
+ expect.data <- as.matrix(expect.data)
+ expect.data <- gsub(expect.data, pattern = "\n", replacement = " ")
+ write.table(expect.data, file = paste0(res.path, "/discrepancy_table_from_fun_test_1", ifelse(total.comp.nb == 1L, ".tsv", paste0("-", total.comp.nb, ".tsv"))), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n", na = "")
+ }
+ }
+ }
+ if( ! is.null(warn)){
+ base::options(warning.length = 8170)
+ on.exit(warning(paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE))
+ }
+ on.exit(exp = base::options(warning.length = ini.warning.length), add = TRUE)
+ if(export == TRUE){
+ save(output, file = paste0(res.path, "/fun_test_1", ifelse(total.comp.nb == 1L, ".RData", paste0("-", total.comp.nb, ".RData"))))
+ table.out <- as.matrix(output$data)
+ table.out <- gsub(table.out, pattern = "\n", replacement = " ")
+ write.table(table.out, file = paste0(res.path, "/table_from_fun_test_1", ifelse(total.comp.nb == 1L, ".tsv", paste0("-", total.comp.nb, ".tsv"))), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n", na = "")
+ }else{
+ return(output)
+ }
+ }
+ # after return() ?
+ end.date <- Sys.time()
+ end.time <- as.numeric(end.date)
+ total.lapse <- round(lubridate::seconds_to_period(end.time - ini.time))
+ cat(paste0("fun_test JOB END\n\nTIME: ", end.date, "\n\nTOTAL TIME LAPSE: ", total.lapse, "\n\n\n"))
+}