diff --git a/dev/cute_little_R_functions.R b/cute_little_R_functions.R
similarity index 95%
rename from dev/cute_little_R_functions.R
rename to cute_little_R_functions.R
index 418246805ae94a965af508e1d4889f49cc4a35d0..39dcd72531305b2d93a5246b3e8891604ac46a8d 100644
--- a/dev/cute_little_R_functions.R
+++ b/cute_little_R_functions.R
@@ -6150,6 +6150,195 @@ hcl(h = hues, l = if(kind == "std"){65}else if(kind == "dark"){35}else if(kind =
+fun_gg_just <- function(angle, pos, kind = "axis"){
+# AIM
+# provide correct justification for text labeling, depending on the chosen angle
+# WARNINGS
+# justification behave differently on plot, depending whether it is used for annotayed text or for axis labelling. Indeed the latter has labelling constrained
+# Of note, a bug in ggplot2: vjust sometimes does not work, i.e., the same justification result is obtained whatever the value used. This is the case with angle = 90, pos = "top", kind = "axis". While everything is fine with angle = 90, pos = "bottom", kind = "axis". At least, everything seems fine for kind = "axis" and pos = c("left", "bottom")
+# ARGUMENTS
+# angle: integer value of the text angle, using the same rules as in ggplot2. Positive values for counterclockwise rotation: 0 for horizontal, 90 for vertical, 180 for upside down etc. Negative values for clockwise rotation: 0 for horizontal, -90 for vertical, -180 for upside down etc.
+# pos: where text is? Either "top", "right", "bottom" or "left" of the elements to justify from
+# kind: kind of text? Either "axis" or "text". In the first case, the pos argument refers to the axis position, and in the second to annotated text (using ggplot2::annotate() or ggplot2::geom_text())
+# RETURN
+# a list containing:
+# $angle: the submitted angle (value potentially reduced to fit the [-360 ; 360] interval, e.g., 460 -> 100, without impact on the final angle displayed)
+# $pos: the selected position (argument pos)
+# $kind: the selected kind of text (argument kind)
+# $hjust: the horizontal justification
+# $vjust: the vertical justification
+# REQUIRED PACKAGES
+# none
+# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
+# fun_check()
+# EXAMPLES
+# fun_gg_just(angle = 45, pos = "bottom")
+# fun_gg_just(angle = (360*2 + 45), pos = "left")
+# output <- fun_gg_just(angle = 45, pos = "bottom") ; obs1 <- data.frame(time = 1:20, group = rep(c("CLASS_1", "CLASS_2"), times = 10), stringsAsFactors = TRUE) ; ggplot2::ggplot() + ggplot2::geom_bar(data = obs1, mapping = ggplot2::aes(x = group, y = time), stat = "identity") + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = output$angle, hjust = output$hjust, vjust = output$vjust))
+# output <- fun_gg_just(angle = -45, pos = "left") ; obs1 <- data.frame(time = 1:20, group = rep(c("CLASS_1", "CLASS_2"), times = 10), stringsAsFactors = TRUE) ; ggplot2::ggplot() + ggplot2::geom_bar(data = obs1, mapping = ggplot2::aes(x = group, y = time), stat = "identity") + ggplot2::theme(axis.text.y = ggplot2::element_text(angle = output$angle, hjust = output$hjust, vjust = output$vjust)) + ggplot2::coord_flip()
+# output1 <- fun_gg_just(angle = 90, pos = "bottom") ; output2 <- fun_gg_just(angle = -45, pos = "left") ; obs1 <- data.frame(time = 1:20, group = rep(c("CLASS_1", "CLASS_2"), times = 10), stringsAsFactors = TRUE) ; ggplot2::ggplot() + ggplot2::geom_bar(data = obs1, mapping = ggplot2::aes(x = group, y = time), stat = "identity") + ggplot2::theme(axis.text.x = ggplot2::element_text(angle = output1$angle, hjust = output1$hjust, vjust = output1$vjust), axis.text.y = ggplot2::element_text(angle = output2$angle, hjust = output2$hjust, vjust = output2$vjust))
+# output <- fun_gg_just(angle = -45, pos = "left") ; obs1 <- data.frame(time = 1, km = 1, bird = "pigeon", stringsAsFactors = FALSE) ; ggplot2::ggplot(data = obs1, mapping = ggplot2::aes(x = time, y = km)) + ggplot2::geom_point() + ggplot2::geom_text(mapping = ggplot2::aes(label = bird), angle = output$angle, hjust = output$hjust, vjust = output$vjust)
+# obs1 <- data.frame(time = 1:10, km = 1:10, bird = c(NA, NA, NA, "pigeon", NA, "cat", NA, NA, NA, NA), stringsAsFactors = FALSE) ; fun_open(width = 4, height = 4) ; for(i0 in c("text", "axis")){for(i1 in c("top", "right", "bottom", "left")){for(i2 in c(0, 45, 90, 135, 180, 225, 270, 315, 360)){output <- fun_gg_just(angle = i2, pos = i1, kind = i0) ; title <- paste0("kind: ", i0, " | pos: ", i1, " | angle = ", i2, " | hjust: ", output$hjust, " | vjust: ", output$vjust) ; if(i0 == "text"){print(ggplot2::ggplot(data = obs1, mapping = ggplot2::aes(x = time, y = km)) + ggplot2::geom_point(color = fun_gg_palette(1), alpha = 0.5) + ggplot2::ggtitle(title) + ggplot2::geom_text(mapping = ggplot2::aes(label = bird), angle = output$angle, hjust = output$hjust, vjust = output$vjust) + ggplot2::theme(title = ggplot2::element_text(size = 5)))}else{print(ggplot2::ggplot(data = obs1, mapping = ggplot2::aes(x = time, y = km)) + ggplot2::geom_point(color = fun_gg_palette(1), alpha = 0.5) + ggplot2::ggtitle(title) + ggplot2::geom_text(mapping = ggplot2::aes(label = bird)) + ggplot2::scale_x_continuous(position = ifelse(i1 == "top", "top", "bottom")) + ggplot2::scale_y_continuous(position = ifelse(i1 == "right", "right", "left")) + ggplot2::theme(title = ggplot2::element_text(size = 5), axis.text.x = if(i1 %in% c("top", "bottom")){ggplot2::element_text(angle = output$angle, hjust = output$hjust, vjust = output$vjust)}, axis.text.y = if(i1 %in% c("right", "left")){ggplot2::element_text(angle = output$angle, hjust = output$hjust, vjust = output$vjust)}))}}}} ; dev.off()
+# DEBUGGING
+# angle = 45 ; pos = "left" ; kind = "axis"
+# 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, ": REQUIRED 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
+mandat.args <- c(
+"angle",
+"pos"
+)
+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[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
+# 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 = angle, class = "integer", length = 1, double.as.integer.allowed = TRUE, neg.values = TRUE, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = pos, options = c("left", "top", "right", "bottom"), length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = kind, options = c("axis", "text"), 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
+# 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(
+"angle",
+"pos",
+"kind"
+)
+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\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
+# end second round of checking and data preparation
+# main code
+# to get angle between -360 and 360
+while(angle > 360){
+angle <- angle - 360
+}
+while(angle < -360){
+angle <- angle + 360
+}
+# end to get angle between -360 and 360
+# justifications
+if(pos %in% c("bottom", "top")){
+# code below is for if(pos == "bottom"){
+if(any(sapply(FUN = all.equal, c(-360, -180, 0, 180, 360), angle) == TRUE)){ # equivalent of angle == -360 | angle == -180 | angle == 0 | angle == 180 | angle == 360 but deals with floats
+hjust <- 0.5
+if(kind == "text"){
+if(any(sapply(FUN = all.equal, c(-360, 0, 360), angle) == TRUE)){
+vjust <- 1
+}else if(any(sapply(FUN = all.equal, c(-180, 180), angle) == TRUE)){
+vjust <- 0
+}
+}else{
+vjust <- 0.5
+}
+}else if(any(sapply(FUN = all.equal, c(-270, 90), angle) == TRUE)){
+hjust <- 1
+vjust <- 0.5
+}else if(any(sapply(FUN = all.equal, c(-90, 270), angle) == TRUE)){
+hjust <- 0
+vjust <- 0.5
+}else if((angle > -360 & angle < -270) | (angle > 0 & angle < 90)){
+hjust <- 1
+vjust <- 1
+}else if((angle > -270 & angle < -180) | (angle > 90 & angle < 180)){
+hjust <- 1
+vjust <- 0
+}else if((angle > -180 & angle < -90) | (angle > 180 & angle < 270)){
+hjust <- 0
+vjust <- 0
+if(kind == "text" & pos == "top"){
+hjust <- 1
+}
+}else if((angle > -90 & angle < 0) | (angle > 270 & angle < 360)){
+hjust <- 0
+vjust <- 1
+}
+if(pos == "top"){
+if( ! ((angle > -180 & angle < -90) | (angle > 180 & angle < 270))){
+hjust <- 1 - hjust
+}
+vjust <- 1 - vjust
+}
+}else if(pos %in% c("left", "right")){
+# code below is for if(pos == "left"){
+if(any(sapply(FUN = all.equal, c(-270, -90, 90, 270), angle) == TRUE)){ # equivalent of angle == -270 | angle == -90 | angle == 90 | angle == 270 but deals with floats
+hjust <- 0.5
+if(kind == "text"){
+if(any(sapply(FUN = all.equal, c(-90, 90), angle) == TRUE)){
+vjust <- 0
+}else if(any(sapply(FUN = all.equal, c(-270, 270), angle) == TRUE)){
+vjust <- 1
+}
+}else{
+vjust <- 0.5
+}
+}else if(any(sapply(FUN = all.equal, c(-360, 0, 360), angle) == TRUE)){
+hjust <- 1
+vjust <- 0.5
+}else if(any(sapply(FUN = all.equal, c(-180, 180), angle) == TRUE)){
+hjust <- 0
+vjust <- 0.5
+}else if((angle > -360 & angle < -270) | (angle > 0 & angle < 90)){
+hjust <- 1
+vjust <- 0
+}else if((angle > -270 & angle < -180) | (angle > 90 & angle < 180)){
+hjust <- 0
+vjust <- 0
+}else if((angle > -180 & angle < -90) | (angle > 180 & angle < 270)){
+hjust <- 0
+vjust <- 1
+}else if((angle > -90 & angle < 0) | (angle > 270 & angle < 360)){
+hjust <- 1
+vjust <- 1
+}
+if(pos == "right"){
+hjust <- 1 - hjust
+if( ! (((angle > -270 & angle < -180) | (angle > 90 & angle < 180)) | ((angle > -180 & angle < -90) | (angle > 180 & angle < 270)))){
+vjust <- 1 - vjust
+}
+}
+}
+# end justifications
+output <- list(angle = angle, pos = pos, kind = kind, hjust = hjust, vjust = vjust)
+return(output)
+}
+
+
######## fun_gg_get_legend() #### get the legend of ggplot objects
@@ -6272,6 +6461,156 @@ return(legend)
+fun_gg_point_rast <- function(
+data = NULL,
+mapping = NULL,
+stat = "identity",
+position = "identity",
+...,
+na.rm = FALSE,
+show.legend = NA,
+inherit.aes = TRUE,
+raster.width = NULL,
+raster.height = NULL,
+raster.dpi = 300,
+inactivate = TRUE,
+lib.path = NULL
+){
+# AIM
+# equivalent to ggplot2::geom_point() but in raster mode
+# use it like ggplot2::geom_point() with the main raster.dpi additional argument
+# WARNINGS
+# can be long to generate the plot
+# use a square plot region. Otherwise, the dots will have ellipsoid shape
+# solve the transparency problems with some GUI
+# this function is derived from the geom_point_rast() function, created by Viktor Petukhov , and present in the ggrastr package (https://rdrr.io/github/VPetukhov/ggrastr/src/R/geom-point-rast.R, MIT License, Copyright (c) 2017 Viktor Petukhov). Has been placed here to minimize package dependencies
+# ARGUMENTS
+# classical arguments of geom_point(), shown here https://rdrr.io/github/VPetukhov/ggrastr/man/geom_point_rast.html
+# raster.width : width of the result image (in inches). Default: deterined by the current device parameters
+# raster.height: height of the result image (in inches). Default: deterined by the current device parameters
+# raster.dpi: resolution of the result image
+# inactivate: logical. Inactivate the fun.name argument of the fun_check() function? If TRUE, the name of the fun_check() function in error messages coming from this function. Use TRUE if fun_gg_point_rast() is used like this: eval(parse(text = "fun_gg_point_rast"))
+# lib.path: character vector specifying the absolute pathways of the directories containing the required packages if not in the default directories. Ignored if NULL
+# RETURN
+# a raster scatter plot
+# REQUIRED PACKAGES
+# ggplot2
+# grid (included in the R installation packages but not automatically loaded)
+# Cairo
+# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
+# fun_check()
+# fun_pack()
+# EXAMPLES
+# Two pdf in the current directory
+# set.seed(1) ; data1 = data.frame(x = rnorm(100000), y = rnorm(10000), stringsAsFactors = TRUE) ; fun_open(pdf.name = "Raster") ; ggplot2::ggplot() + fun_gg_point_rast(data = data1, mapping = ggplot2::aes(x = x, y = y)) ; fun_open(pdf.name = "Vectorial") ; ggplot2::ggplot() + ggplot2::geom_point(data = data1, mapping = ggplot2::aes(x = x, y = y)) ; dev.off() ; dev.off()
+# DEBUGGING
+#
+# function name
+if(all(inactivate == FALSE)){ # inactivate has to be used here but will be fully checked below
+function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
+}else if(all(inactivate == TRUE)){
+function.name <- NULL
+}else{
+tempo.cat <- paste0("ERROR IN fun_gg_point_rast(): CODE INCONSISTENCY 1")
+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 function name
+# required function checking
+if(length(utils::find("fun_check", mode = "function")) == 0L){
+tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED 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 ==
+}
+if(length(utils::find("fun_pack", mode = "function")) == 0L){
+tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_pack() 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 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))
+if( ! is.null(data)){
+tempo <- fun_check(data = data, class = "data.frame", na.contain = TRUE, fun.name = function.name) ; eval(ee)
+}
+if( ! is.null(mapping)){
+tempo <- fun_check(data = mapping, class = "uneval", typeof = "list", fun.name = function.name) ; eval(ee) # aes() is tested
+}
+# stat and position not tested because too complicate
+tempo <- fun_check(data = na.rm, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = show.legend, class = "vector", mode = "logical", length = 1, na.contain = TRUE, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = inherit.aes, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
+if( ! is.null(raster.width)){
+tempo <- fun_check(data = raster.width, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
+}
+if( ! is.null(raster.height)){
+tempo <- fun_check(data = raster.height, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
+}
+tempo <- fun_check(data = raster.dpi, class = "integer", length = 1, double.as.integer.allowed = TRUE, neg.values = FALSE, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = inactivate, class = "vector", mode = "logical", length = 1, 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)
+if(tempo$problem == FALSE){
+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"))
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}
+}
+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) #
+}
+}
+# 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 checking
+# package checking
+fun_pack(req.package = c("ggplot2"), lib.path = lib.path)
+fun_pack(req.package = c("grid"), lib.path = lib.path)
+fun_pack(req.package = c("Cairo"), lib.path = lib.path)
+# end package checking
+# additional functions
+DrawGeomPointRast <- function(data, panel_params, coord, na.rm = FALSE, raster.width = NULL, raster.height= NULL, raster.dpi = raster.dpi){
+if (is.null(raster.width)){
+raster.width <- par('fin')[1]
+}
+if (is.null(raster.height)){
+ raster.height <- par('fin')[2]
+}
+prev_dev_id <- dev.cur()
+p <- ggplot2::GeomPoint$draw_panel(data, panel_params, coord)
+dev_id <- Cairo::Cairo(type='raster', width = raster.width*raster.dpi, height = raster.height*raster.dpi, dpi = raster.dpi, units = 'px', bg = "transparent")[1]
+grid::pushViewport(grid::viewport(width = 1, height = 1))
+grid::grid.points(x = p$x, y = p$y, pch = p$pch, size = p$size,
+name = p$name, gp = p$gp, vp = p$vp, draw = T)
+grid::popViewport()
+cap <- grid::grid.cap()
+invisible(dev.off(dev_id))
+invisible(dev.set(prev_dev_id))
+grid::rasterGrob(cap, x = 0, y = 0, width = 1, height = 1, default.units = "native", just = c("left","bottom"))
+}
+# end additional functions
+# main code
+GeomPointRast <- ggplot2::ggproto("GeomPointRast", ggplot2::GeomPoint, draw_panel = DrawGeomPointRast)
+ggplot2::layer(
+data = data,
+mapping = mapping,
+stat = stat,
+geom = GeomPointRast,
+position = position,
+show.legend = show.legend,
+inherit.aes = inherit.aes,
+params = list(
+na.rm = na.rm,
+raster.width = raster.width,
+raster.height = raster.height,
+raster.dpi = raster.dpi,
+...
+)
+)
+# end main code
+}
######## fun_gg_boxplot() #### ggplot2 boxplot + background dots if required
@@ -6287,6 +6626,358 @@ return(legend)
######## fun_gg_heatmap() #### ggplot2 heatmap + overlaid mask if required
+# test plot.margin = margin(up.space.mds, right.space.mds, down.space.mds, left.space.mds, "inches") to set the dim of the region plot ?
+# if matrix is full of zero (or same value I guess), heatmap is complicate. Test it and error message
+fun_gg_heatmap <- function(
+data1,
+legend.name1 = "",
+low.color1 = "blue",
+mid.color1 = "white",
+high.color1 = "red",
+limit1 = NULL,
+midpoint1 = NULL,
+data2 = NULL,
+color2 = "black",
+alpha2 = 0.5,
+invert2 = FALSE,
+text.size = 12,
+title = "",
+title.text.size = 12,
+show.scale = TRUE,
+rotate = FALSE,
+return = FALSE,
+plot = TRUE,
+add = NULL,
+warn.print = FALSE,
+lib.path = NULL
+){
+# AIM
+# ggplot2 heatmap with the possibility to overlay a mask
+# see also:
+# draw : http://www.sthda.com/english/wiki/ggplot2-quick-correlation-matrix-heatmap-r-software-and-data-visualization
+# same range scale : https://stackoverflow.com/questions/44655723/r-ggplot2-heatmap-fixed-scale-color-between-graphs
+# for ggplot2 specifications, see: https://ggplot2.tidyverse.org/articles/ggplot2-specs.html
+# WARNINGS
+# NA and Inf values are displayed as grey.
+# when using limit1 all values out of the range of limit1 are also displayed as grey.
+# ARGUMENTS
+# data1: numeric matrix or data frame resulting from the conversion of the numeric matrix by reshape2::melt()
+# legend.name1: character string of the data1 heatmap scale legend
+# low.color1: character string of the color (i.e., "blue" or "#0000FF") of the lowest scale value
+# mid.color1: same as low.color1 but for the middle scale value. If NULL, the middle color is the default color between low.color1 and high.color1. BEWARE: argument midpoint1 is not ignored, even if mid.color1 is NULL, meaning that the default mid color can still be controled
+# high.color1: same as low.color1 but for the highest scale value
+# limit1: 2 numeric values defining the lowest and higest color scale values. If NULL, take the range of data1 values. Warning values are sorted by the function. Thus, use the low.color1 and high.color1 to reverse the scale color if necessary
+# midpoint1: single numeric value defining the value corresponding to the mid.color1 argument. A warning message is returned if midpoint1 does not correspond to the mean of limit1 values, because the color scale is not linear anymore. If NULL, takes the mean of limit1 values. Mean of data1, instead of mean of limit1, can be used here if required
+# data2: binary mask matrix (made of 0 and 1) of same dimension as data1 or a data frame resulting from the conversion of the binary mask matrix by reshape2::melt(). Value 1 of data2 will correspond to color2 argument (value 0 will be NA color), and the opposite if invert2 argument is TRUE (inverted mask)
+# color2: color of the 1 values of the binary mask matrix. The 0 values will be color NA
+# alpha2: numeric value (from 0 to 1) of the mask transparency
+# invert2: logical. Invert the mask (1 -> 0 and 0 -> 1)?
+# text.size: numeric value of the size of the texts in scale
+# title: character string of the graph title
+# title.text.size: numeric value of the title size (in points)
+# show.scale: logical. Show color scale?
+# rotate: logical. Rotate the heatmap 90° clockwise?
+# return: logical. Return the graph parameters?
+# plot: logical. Plot the graphic? If FALSE and return argument is TRUE, graphical parameters and associated warnings are provided without plotting
+# add: character string allowing to add more ggplot2 features (dots, lines, themes, etc.). BEWARE: (1) must start with "+" just after the simple or double opening quote (no space, end of line, carriage return, etc., allowed), (2) must finish with ")" just before the simple or double closing quote (no space, end of line, carriage return, etc., allowed) and (3) each function must be preceded by "ggplot2::" (for instance: "ggplot2::coord_flip()). If the character string contains the "ggplot2::theme" string, then internal ggplot2 theme() and theme_classic() functions will be inactivated to be reused by add. BEWARE: handle this argument with caution since added functions can create conflicts with the preexisting internal ggplot2 functions
+# warn.print: logical. Print warnings at the end of the execution? No print if no warning messages
+# lib.path: absolute path of the required packages, if not in the default folders
+# RETURN
+# a heatmap if plot argument is TRUE
+# a list of the graph info if return argument is TRUE:
+# $data: a list of the graphic info
+# $axes: a list of the axes info
+# $scale: the scale info (lowest, mid and highest values)
+# $warn: the warning messages. Use cat() for proper display. NULL if no warning
+# REQUIRED PACKAGES
+# ggplot2
+# reshape2
+# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
+# fun_check()
+# fun_pack()
+# fun_round()
+# EXAMPLES
+# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), title = "GRAPH 1")
+# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), return = TRUE)
+# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), legend.name1 = "VALUE", title = "GRAPH 1", text.size = 5, data2 = matrix(rep(c(1,0,0,0), 4), ncol = 4), invert2 = FALSE, return = TRUE)
+# diagonal matrix
+# fun_gg_heatmap(data1 = matrix(c(1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1), ncol = 4))
+# fun_gg_heatmap(data1 = reshape2::melt(matrix(c(1,0,0,0,0,1,0,0,0,0,1,0,0,0,0,1), ncol = 4)))
+# error message
+# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), data2 = matrix(rep(c(1,0,0,0), 5), ncol = 5))
+# fun_gg_heatmap(data1 = matrix(1:16, ncol = 4), data2 = reshape2::melt(matrix(rep(c(1,0,0,0), 4), ncol = 4)))
+# fun_gg_heatmap(data1 = reshape2::melt(matrix(1:16, ncol = 4)), data2 = reshape2::melt(matrix(rep(c(1,0,0,0), 4), ncol = 4)))
+# DEBUGGING
+# data1 = matrix(1:16, ncol = 4) ; legend.name1 = "" ; low.color1 = "blue" ; mid.color1 = "white" ; high.color1 = "red" ; limit1 = NULL ; midpoint1 = NULL ; data2 = matrix(rep(c(1,0,0,0), 4), ncol = 4) ; color2 = "black" ; alpha2 = 0.5 ; invert2 = FALSE ; text.size = 12 ; title = "" ; title.text.size = 12 ; show.scale = TRUE ; rotate = FALSE ; return = FALSE ; plot = TRUE ; add = NULL ; warn.print = TRUE ; lib.path = NULL
+# function name
+function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
+# end function name
+# required function checking
+if(length(utils::find("fun_check", mode = "function")) == 0L){
+tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED 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 ==
+}
+if(length(utils::find("fun_pack", mode = "function")) == 0L){
+tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_pack() 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 ==
+}
+if(length(utils::find("fun_round", mode = "function")) == 0L){
+tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_round() 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
+# no reserved words required for this function
+# argument 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))
+if(all(is.matrix(data1))){
+tempo <- fun_check(data = data1, class = "matrix", mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee)
+}else if(all(is.data.frame(data1))){
+tempo <- fun_check(data = data1, class = "data.frame", length = 3, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE){
+# structure of reshape2::melt() data frame
+tempo <- fun_check(data = data1[, 1], data.name = "COLUMN 1 OF data1 (reshape2::melt() DATA FRAME)", typeof = "integer", fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = data1[, 2], data.name = "COLUMN 2 OF data1 (reshape2::melt() DATA FRAME)", typeof = "integer", fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = data1[, 3], data.name = "COLUMN 3 OF data1 (reshape2::melt() DATA FRAME)", mode = "numeric", na.contain = TRUE, fun.name = function.name) ; eval(ee)
+}
+}else{
+tempo.cat <- paste0("ERROR IN ", function.name, ": THE data1 ARGUMENT MUST BE A NUMERIC MATRIX OR A DATA FRAME OUTPUT OF THE reshape::melt() FUNCTION")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+tempo <- fun_check(data = legend.name1, class = "character", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = low.color1, class = "character", length = 1, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & ! (all(low.color1 %in% colors() | grepl(pattern = "^#", low.color1)))){ # check that all strings of low.color1 start by #
+tempo.cat <- paste0("ERROR IN ", function.name, ": low.color1 ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+if( ! is.null(mid.color1)){
+tempo <- fun_check(data = mid.color1, class = "character", length = 1, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & ! (all(mid.color1 %in% colors() | grepl(pattern = "^#", mid.color1)))){ # check that all strings of mid.color1 start by #
+tempo.cat <- paste0("ERROR IN ", function.name, ": mid.color1 ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}
+tempo <- fun_check(data = high.color1, class = "character", length = 1, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & ! (all(high.color1 %in% colors() | grepl(pattern = "^#", high.color1)))){ # check that all strings of high.color1 start by #
+tempo.cat <- paste0("ERROR IN ", function.name, ": high.color1 ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+if( ! is.null(limit1)){
+tempo <- fun_check(data = limit1, class = "vector", mode = "numeric", length = 2, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & any(limit1 %in% c(Inf, -Inf))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": limit1 ARGUMENT CANNOT CONTAIN -Inf OR Inf VALUES")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}
+if( ! is.null(midpoint1)){
+tempo <- fun_check(data = midpoint1, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
+}
+if( ! is.null(data2)){
+if(all(is.matrix(data2))){
+tempo <- fun_check(data = data2, class = "matrix", mode = "numeric", fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & ! all(unique(data2) %in% c(0,1))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": MATRIX IN data2 MUST BE MADE OF 0 AND 1 ONLY (MASK MATRIX)")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}else if(tempo$problem == FALSE & all(is.matrix(data1)) & ! identical(dim(data1), dim(data2))){ # matrix and matrix
+tempo.cat <- paste0("ERROR IN ", function.name, ": MATRIX DIMENSION IN data2 MUST BE IDENTICAL AS MATRIX DIMENSION IN data1. HERE IT IS RESPECTIVELY:\n", paste(dim(data2), collapse = " "), "\n", paste(dim(data1), collapse = " "))
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}else if(tempo$problem == FALSE & all(is.data.frame(data1)) & nrow(data1) != prod(dim(data2))){ # reshape2 and matrix
+tempo.cat <- paste0("ERROR IN ", function.name, ": DATA FRAME IN data2 MUST HAVE ROW NUMBER EQUAL TO PRODUCT OF DIMENSIONS OF data1 MATRIX. HERE IT IS RESPECTIVELY:\n", paste(nrow(data1), collapse = " "), "\n", paste(prod(dim(data2)), collapse = " "))
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else if(all(is.data.frame(data2))){
+tempo <- fun_check(data = data2, class = "data.frame", length = 3, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE){
+# structure of reshape2::melt() data frame
+tempo <- fun_check(data = data2[, 1], data.name = "COLUMN 1 OF data2 (reshape2::melt() DATA FRAME)", typeof = "integer", fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = data2[, 2], data.name = "COLUMN 2 OF data2 (reshape2::melt() DATA FRAME)", typeof = "integer", fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = data2[, 3], data.name = "COLUMN 3 OF data2 (reshape2::melt() DATA FRAME)", mode = "numeric", fun.name = function.name) ; eval(ee)
+}
+if(tempo$problem == FALSE & ! all(unique(data2[, 3]) %in% c(0,1))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": THIRD COLUMN OF DATA FRAME IN data2 MUST BE MADE OF 0 AND 1 ONLY (MASK DATA FRAME)")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}else if(tempo$problem == FALSE & all(is.data.frame(data1)) & ! identical(dim(data1), dim(data2))){ # data frame and data frame
+tempo.cat <- paste0("ERROR IN ", function.name, ": DATA FRAME DIMENSION IN data2 MUST BE IDENTICAL TO DATA FRAME DIMENSION IN data1. HERE IT IS RESPECTIVELY:\n", paste(dim(data2), collapse = " "), "\n", paste(dim(data1), collapse = " "))
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}else if(tempo$problem == FALSE & all(is.matrix(data1)) & nrow(data2) != prod(dim(data1))){ # reshape2 and matrix
+tempo.cat <- paste0("ERROR IN ", function.name, ": DATA FRAME IN data2 MUST HAVE ROW NUMBER EQUAL TO PRODUCT OF DIMENSION OF data1 MATRIX. HERE IT IS RESPECTIVELY:\n", paste(nrow(data2), collapse = " "), "\n", paste(prod(dim(data1)), collapse = " "))
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+tempo.cat <- paste0("ERROR IN ", function.name, ": THE data2 ARGUMENT MUST BE A NUMERIC MATRIX OR A DATA FRAME OUTPUT OF THE reshape::melt() FUNCTION")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}
+tempo <- fun_check(data = color2, class = "character", length = 1, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & ! (all(color2 %in% colors() | grepl(pattern = "^#", color2)))){ # check that all strings of color2 start by #
+tempo.cat <- paste0("ERROR IN ", function.name, ": color2 ARGUMENT MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors()")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+tempo <- fun_check(data = alpha2, class = "vector", mode = "numeric", length = 1, prop = TRUE, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = invert2, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = text.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = title, class = "character", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = title.text.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = show.scale, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = return, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = plot, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+if( ! is.null(add)){
+tempo <- fun_check(data = add, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & ! grepl(pattern = "^\\+", add)){ # check that the add string start by +
+tempo.cat <- paste0("ERROR IN ", function.name, ": add ARGUMENT MUST START WITH \"+\": ", paste(unique(add), collapse = " "))
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}else if(tempo$problem == FALSE & ! grepl(pattern = "ggplot2::", add)){ #
+tempo.cat <- paste0("ERROR IN ", function.name, ": add ARGUMENT MUST CONTAIN \"ggplot2::\" IN FRONT OF EACH GGPLOT2 FUNCTION: ", paste(unique(add), collapse = " "))
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}else if(tempo$problem == FALSE & ! grepl(pattern = ")$", add)){ # check that the add string finished by )
+tempo.cat <- paste0("ERROR IN ", function.name, ": add ARGUMENT MUST FINISH BY \")\": ", paste(unique(add), collapse = " "))
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}
+tempo <- fun_check(data = warn.print, class = "logical", length = 1, 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)
+if(tempo$problem == FALSE){
+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"))
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}
+}
+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) #
+}
+}
+# 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 checking
+# package checking
+fun_pack(req.package = c("reshape2", "ggplot2"), lib.path = lib.path)
+# end package checking
+# main code
+ini.warning.length <- options()$warning.length
+options(warning.length = 8170)
+warn <- NULL
+warn.count <- 0
+if(all(is.matrix(data1))){
+data1 <- reshape2::melt(data1) # transform a matrix into a data frame with 2 coordinates columns and the third intensity column
+}
+if(rotate == TRUE){
+data1[, 1] <- rev(data1[, 1])
+}
+if(is.null(limit1)){
+if(any( ! is.finite(data1[, 3]))){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") THE data1 ARGUMENT CONTAINS -Inf OR Inf VALUES IN THE THIRD COLUMN, THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+limit1 <- range(data1[, 3], na.rm = TRUE, finite = TRUE) # finite = TRUE removes all the -Inf and Inf except if only this. In that case, whatever the -Inf and/or Inf present, output -Inf;Inf range. Idem with NA only
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") THE limit1 ARGUMENT IS NULL -> RANGE OF data1 ARGUMENT HAS BEEN TAKEN: ", paste(fun_round(limit1), collapse = " "))
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+if(suppressWarnings(any(limit1 %in% c(Inf, -Inf)))){
+tempo.cat <- paste0("ERROR IN ", function.name, " COMPUTED LIMIT CONTAINS Inf VALUES, BECAUSE VALUES FROM data1 ARGUMENTS ARE NA OR Inf ONLY")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+}
+}else{
+limit1 <- sort(limit1)
+}
+if(is.null(midpoint1)){
+midpoint1 <- mean(limit1, na.rm = TRUE)
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") THE midpoint1 ARGUMENT IS NULL -> MEAN OF limit1 ARGUMENT HAS BEEN TAKEN: ", paste(fun_round(midpoint1), collapse = " "))
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}else if(fun_round(midpoint1, 9) != fun_round(mean(limit1), 9)){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") THE midpoint1 ARGUMENT (", fun_round(mean(midpoint1), 9), ") DOES NOT CORRESPOND TO THE MEAN OF THE limit1 ARGUMENT (", fun_round(mean(limit1), 9), "). COLOR SCALE IS NOT LINEAR")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+if( ! is.null(data2)){
+if(all(is.matrix(data2))){
+data2 <- reshape2::melt(data2) # transform a matrix into a data frame with 2 coordinates columns and the third intensity column
+}
+if(rotate == TRUE){
+data2[, 1] <- rev(data2[, 1])
+}
+data2[, 3] <- factor(data2[, 3]) # to converte continuous scale into discrete scale
+}
+tempo.gg.name <- "gg.indiv.plot."
+tempo.gg.count <- 0 # to facilitate debugging
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggplot())
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_raster(data = data1, mapping = ggplot2::aes_string(x = names(data1)[ifelse(rotate == FALSE, 2, 1)], y = names(data1)[ifelse(rotate == FALSE, 1, 2)], fill = names(data1)[3]), show.legend = show.scale)) # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.)
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_fill_gradient2(low = low.color1, high = high.color1, mid = mid.color1, midpoint = midpoint1, limit = limit1, breaks = c(limit1[1], midpoint1, limit1[2]), labels = fun_round(c(limit1[1], midpoint1, limit1[2])), name = legend.name1))
+if( ! is.null(data2)){
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_raster(data = data2, mapping = ggplot2::aes_string(x = names(data2)[ifelse(rotate == FALSE, 2, 1)], y = names(data2)[ifelse(rotate == FALSE, 1, 2)], alpha = names(data2)[3]), fill = color2, show.legend = FALSE))
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "alpha", values = if(invert2 == FALSE){c(0, alpha2)}else{c(alpha2, 0)}, guide = FALSE))
+# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_raster(data = data2, mapping = ggplot2::aes_string(x = names(data2)[ifelse(rotate == FALSE, 2, 1)], y = names(data2)[ifelse(rotate == FALSE, 1, 2)], group = names(data2)[3]), fill = data2[, 3], alpha = alpha2, show.legend = FALSE)) # BEWARE: this does not work if NA present, because geom_raster() has a tendency to complete empty spaces, and thus, behave differently than geom_tile(). See https://github.com/tidyverse/ggplot2/issues/3025
+}
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_fixed()) # x = y
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_y_reverse())
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggtitle(title))
+add.check <- TRUE
+if( ! is.null(add)){ # if add is NULL, then = 0
+if(grepl(pattern = "ggplot2::theme", add) == TRUE){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") \"ggplot2::theme\" STRING DETECTED IN THE add ARGUMENT -> INTERNAL GGPLOT2 THEME FUNCTIONS theme() AND theme_classic() HAVE BEEN INACTIVATED, TO BE USED BY THE USER")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+add.check <- FALSE
+}
+}
+if(add.check == TRUE){
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_classic(base_size = text.size))
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme(
+text = ggplot2::element_text(size = text.size),
+plot.title = ggplot2::element_text(size = title.text.size), # stronger than text
+line = ggplot2::element_blank(),
+axis.title = ggplot2::element_blank(),
+axis.text = ggplot2::element_blank(),
+axis.ticks = ggplot2::element_blank(),
+panel.background = ggplot2::element_blank()
+))
+}
+if(plot == TRUE){
+# suppressWarnings(
+print(eval(parse(text = paste(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), if(is.null(add)){NULL}else{add}))))
+# )
+}else{
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") PLOT NOT SHOWN AS REQUESTED")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+if(warn.print == TRUE & ! is.null(warn)){
+on.exit(warning(paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE))
+}
+on.exit(exp = options(warning.length = ini.warning.length), add = TRUE)
+if(return == TRUE){
+output <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))
+output <- output$data
+names(output)[1] <- "heatmap"
+if( ! is.null(data2)){
+names(output)[2] <- "mask"
+}
+return(list(data = output, axes = output$layout$panel_params[[1]], scale = c(limit1[1], midpoint1, limit1[2]), warn = warn))
+}
+}
+
######## fun_gg_empty_graph() #### text to display for empty graphs
@@ -6294,6 +6985,92 @@ return(legend)
+fun_gg_empty_graph <- function(
+text = NULL,
+text.size = 12,
+title = NULL,
+title.size = 8,
+lib.path = NULL
+){
+# AIM
+# display an empty ggplot2 plot with a text in the middle of the window (for instance to specify that no plot can be drawn)
+# ARGUMENTS
+# text: character string of the message to display
+# text.size: numeric value of the text size (in points)
+# title: character string of the graph title
+# title.size: numeric value of the title size (in points)
+# lib.path: character vector specifying the absolute pathways of the directories containing the required packages if not in the default directories. Ignored if NULL
+# RETURN
+# an empty plot
+# REQUIRED PACKAGES
+# ggplot2
+# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
+# fun_check()
+# fun_pack()
+# EXAMPLES
+### simple example
+# fun_gg_empty_graph(text = "NO GRAPH")
+### white page
+# fun_gg_empty_graph()
+### all the arguments
+# fun_gg_empty_graph(text = "NO GRAPH", text.size = 8, title = "GRAPH1", title.size = 10, lib.path = NULL)
+# DEBUGGING
+# text = "NO GRAPH" ; text.size = 12 ; title = "GRAPH1" ; title.size = 8 ; lib.path = NULL
+# function name
+function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
+# end function name
+# required function checking
+if(length(utils::find("fun_check", mode = "function")) == 0L){
+tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED 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 ==
+}
+if(length(utils::find("fun_pack", mode = "function")) == 0L){
+tempo.cat <- paste0("ERROR IN ", function.name, ": REQUIRED fun_pack() 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 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))
+if( ! is.null(text)){
+tempo <- fun_check(data = text, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
+}
+tempo <- fun_check(data = text.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; eval(ee)
+if( ! is.null(title)){
+tempo <- fun_check(data = title, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
+}
+tempo <- fun_check(data = title.size, class = "vector", mode = "numeric", 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) #
+}
+}
+# 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 checking
+# package checking
+fun_pack(req.package = c("ggplot2"), lib.path = lib.path)
+# end package checking
+# main code
+tempo.gg.name <- "gg.indiv.plot."
+tempo.gg.count <- 0
+# no need loop part
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggplot())
+if( ! is.null(text)){
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_text(data = data.frame(x = 1, y = 1, stringsAsFactors = TRUE), ggplot2::aes(x = x, y = y, label = text), size = text.size))
+}
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggtitle(title))
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_void())
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme(
+panel.background = ggplot2::element_rect(fill = "white", color = NA),
+plot.title = ggplot2::element_text(size = title.size) # stronger than text
+))
+final <- suppressWarnings(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))
+return(final)
+}
+
+
################ Graphic extraction
diff --git a/dev/cute_little_R_functions.docx b/cute_little_R_functions.docx
similarity index 100%
rename from dev/cute_little_R_functions.docx
rename to cute_little_R_functions.docx
diff --git a/examples_fun_gg_boxplot.R b/examples_fun_gg_boxplot.R
new file mode 100644
index 0000000000000000000000000000000000000000..f2213a905d7ab50da88803c46a54b6b90112cdaa
--- /dev/null
+++ b/examples_fun_gg_boxplot.R
@@ -0,0 +1,338 @@
+# EXAMPLES
+
+### Data set
+set.seed(1)
+obs1 <- data.frame(
+ Time = c(rnorm(20, 100, 10), rnorm(20, 200, 50), rnorm(20, 500, 60), rnorm(20, 100, 50)),
+ Categ1 = rep(c("CAT", "DOG"), times = 40),
+ Categ2 = rep(c("A", "B", "C", "D"), each = 20),
+ Color1 = rep(c("coral", "lightblue"), times = 40),
+ Color2 = rep(c("#9F2108", "#306100", "#007479", "#8500C0"), each = 20),
+ stringsAsFactors = TRUE
+)
+set.seed(NULL)
+fun_info(obs1)
+
+## Mandatory arguments
+### separate boxes
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1")
+### grouped boxes
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Categ1", "Categ2"))
+# Order matters
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Categ2", "Categ1"))
+### single class
+fun_gg_boxplot(data1 = obs1[1:20, ], y = "Time", categ = "Categ2")
+fun_gg_boxplot(data1 = obs1[1:20, ], y = "Time", categ = c("Categ1", "Categ2"))
+
+### Changing the order of the boxes
+# separate boxes
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ categ.class.order = list(c("DOG", "CAT"))
+)
+# grouped boxes
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Categ1", "Categ2"),
+ categ.class.order = list(c("DOG", "CAT"), c("D", "C", "B", "A"))
+)
+
+### Box color
+# Using a single color value
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ categ.color = "coral"
+)
+# Using one color value par class of Categ1
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ categ.color = c("coral", "lightblue")
+)
+# Using a vector of color values (e.g., data frame column), with respect of the correspondence between Categ1 and box.color columns
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ categ.color = obs1$Color1
+)
+# Using integers instead of color strings
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ categ.color = 1
+)
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ categ.color = 1:2
+)
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ categ.color = as.numeric(obs1$Color1)
+)
+# With grouped boxes, we generate the same effects but for the second category
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Categ1", "Categ2"),
+ categ.color = "coral"
+)
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Categ1", "Categ2"),
+ categ.color = 1:4
+)
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Categ1", "Categ2"),
+ categ.color = obs1$Color2
+)
+
+### Other parameters of boxes
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ box.legend.name = "ANIMALS",
+ box.fill = TRUE,
+ box.width = 0.6, # separate boxes: between 0 (no box width <-> max boxes separation) and 1 (max box width <-> no boxes separation). Grouped boxes: between 0 (no group width <-> max group separation) and 1 (max group width <-> no group separation)
+ box.space = 0, # between 0 (no separation) and 1 (max separation) but only to separate boxes inside groups of boxes
+ box.line.size = 0.75,
+ box.notch = TRUE,
+ box.alpha = 1,
+ box.mean = FALSE,
+ box.whisker.kind = "max",
+ box.whisker.width = 0.5 # between 0 (no whisker extremities) and 1 (whisker extremities the width of the boxes)
+)
+
+### Box removal
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ box.alpha = 0
+)
+
+
+### Dot colors
+# Dot removal
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ dot.color = NULL
+)
+# Same color as the boxes
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ dot.color = "same"
+)
+# Single color sting
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ dot.color = "green" # a single integer also works
+)
+# Same number of Categ1 classes
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ dot.color = c("green", "brown") # test also 1:2 (result is idem as "same")
+)
+# Using a vector of color values of the same length as the number of rows in data1 (e.g., data frame column). No correspondence with Categ1 classes is required
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ dot.color = 1:nrow(obs1)
+)
+# With grouped boxes, we generate the same effects but for the second category
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Categ1", "Categ2"),
+ dot.color = NULL
+)
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Categ1", "Categ2"),
+ dot.color = "same"
+)
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Categ1", "Categ2"),
+ dot.color = "green" # a single integer also works
+)
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Categ1", "Categ2"),
+ dot.color = c("green", "brown", "red", "blue") # test also 1:2 (result is idem as "same")
+)
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = c("Categ1", "Categ2"),
+ dot.color = 1:nrow(obs1)
+)
+
+### Legend for dots
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ dot.color = c("green", "brown", "red", "blue"), # single color or same number of dot.categ classes in that case ("same" authorized if dot.categ is the last element of categ)
+ dot.categ = "Categ2",
+ dot.categ.class.order = c("D", "A", "C", "B"),
+ dot.legend.name = "ANIMAL GROUP"
+)
+
+### Tidy or random dot spreading
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ dot.tidy = TRUE,
+ dot.tidy.bin.nb = 50, # from 0 to Inf. Only if dot.tidy = TRUE
+ dot.jitter = 0.5, # from 0 to 1. Only if dot.tidy = FALSE
+ dot.seed = 55 # if the dot shuffling is not satisfying, test another integer.Ssee below an example with dot.seed = NULL
+)
+
+### Other parameters of dots
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ dot.color = c("green", "brown", "red", "blue"),
+ dot.categ = "Categ2", # to see the dot legend
+ dot.size = 5, # ignored if dot.tidy = TRUE
+ dot.alpha = 0.3,
+ dot.border.size = 2,
+ dot.border.color = "green"
+)
+
+### Reshuffling of dots
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ dot.seed = NULL # rerun several times, and test the same with dot.seed = 1 for instance
+)
+
+
+### X-axis parameters
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ x.lab = "ANIMALS",
+ x.angle = 90
+)
+
+### Y-axis parameters
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ y.lab = "SIZE",
+ y.lim = c(1000, 0.1), # order matters
+ y.log = "log10", # try "no"
+ y.tick.nb = 10, # approximate number
+ y.second.tick.nb = 2,
+ y.include.zero = FALSE,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0,
+)
+
+### Stat numbers above boxes
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ stat.pos = "above", # try "top"
+ stat.mean = FALSE,
+ stat.size = 4,
+ stat.dist = 2,
+ stat.angle = 90
+)
+
+### Plot orientation
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ vertical = FALSE # with log2 and log10 scales, horizontal orientation is blocked because of a bug in ggplot2 (https://github.com/tidyverse/ggplot2/issues/881)
+)
+
+
+### Text management
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ text.size = 20
+)
+
+### Title
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ title = "FIRST EXPERIMENT",
+ title.text.size = 20
+)
+
+### Management of the legend area
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ legend.show = FALSE, # FALSE remove the legend, not the area of the legend
+ legend.width = 1 # between 0 (no area for the legend) to 1 (half the device width for the legend area). Use NULL for default management
+)
+
+### Appearance
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ article = FALSE,
+ grid = TRUE
+)
+
+### the add argument
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ add = "+ggplot2::theme_classic()"
+)
+fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ add = "+ggplot2::facet_wrap(facets = 'Categ2', labeller = 'label_both') + ggplot2::theme(strip.background = ggplot2::element_rect(color = 'grey', size = 0.5), strip.text = ggplot2::element_text(size = 10, face = 'bold'), panel.spacing = ggplot2::unit(0.5, 'lines'))" # or ggplot2::vars(Categ2) instead of 'Categ2'. See https://ggplot2.tidyverse.org/reference/labeller.html
+) # use legend.show = FALSE, legend.width = 0 to remove the legend area
+
+
+### Other parameters
+res <- fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ return = TRUE, # output returned (and assigned into res)
+ return.ggplot = TRUE,
+ return.gtable = FALSE,
+ plot = FALSE, # no plot displayed
+ warn.print = FALSE,
+ lib.path = NULL
+)
+# plot the result
+fun_open(pdf = FALSE)
+res$ggplot
+
+# The advantage of $ggplot is that it is easy to update the plot
+res$ggplot + ggplot2::annotate(geom = "text", x = 1.5, y = 400, label = "NOT GOOD", size = 20, angle = 45)
+
+# However, manipulation of res triggers plotting because of the presence of non NULL $ggplot, which is annoying, as explain in the function description. Thus, it is preferable to use return.ggplot = FALSE
+fun_open(pdf = FALSE)
+res
+
+
+
+
+### Notes about the gtable output
+res2 <- fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Categ1",
+ return = TRUE,
+ return.ggplot = FALSE,
+ return.gtable = TRUE, # return.gtable must be TRUE to have a non NULL $gtable output into res2
+ plot = TRUE, # plot must be TRUE to have a non NULL $gtable output into res2
+ warn.print = FALSE,
+ lib.path = NULL
+)
+
+# display the results (does not plot the graph, contrary to $ggplot)
+fun_open(pdf = FALSE)
+res2
+
+# replot
+fun_open(pdf = FALSE)
+gridExtra::grid.arrange(res2$gtable) # Contrary to $ggplot, $gtable cannot be easily updated (see https://stackoverflow.com/questions/26499608/inverse-of-ggplotgrob)
+# plot the first grob
+fun_open(pdf = FALSE)
+gridExtra::grid.arrange(res2$gtable[1,1])
+# plot the second grob
+fun_open(pdf = FALSE)
+gridExtra::grid.arrange(res2$gtable[1,2])
+
+
+### All the arguments
+fun_gg_boxplot(
+ data1 = obs1,
+ y = "Time",
+ categ = "Categ1",
+ categ.class.order = NULL,
+ categ.color = NULL,
+ box.legend.name = NULL,
+ box.fill = FALSE,
+ box.width = 0.5,
+ box.space = 0.1,
+ box.line.size = 0.75,
+ box.notch = FALSE,
+ box.alpha = 1,
+ box.mean = TRUE,
+ box.whisker.kind = "std",
+ box.whisker.width = 0,
+ dot.color = grey(0.25),
+ dot.categ = NULL,
+ dot.categ.class.order = NULL,
+ dot.legend.name = NULL,
+ dot.tidy = FALSE,
+ dot.tidy.bin.nb = 50,
+ dot.jitter = 0.5,
+ dot.seed = 2,
+ dot.size = 3,
+ dot.alpha = 0.5,
+ dot.border.size = 0.5,
+ dot.border.color = NULL,
+ x.lab = NULL,
+ x.angle = 0,
+ y.lab = NULL,
+ y.lim = NULL,
+ y.log = "no",
+ y.tick.nb = NULL,
+ y.second.tick.nb = 1,
+ y.include.zero = FALSE,
+ y.top.extra.margin = 0.05,
+ y.bottom.extra.margin = 0.05,
+ stat.pos = "top",
+ stat.mean = FALSE,
+ stat.size = 4,
+ stat.dist = 5,
+ stat.angle = 0,
+ vertical = TRUE,
+ text.size = 12,
+ title = "",
+ title.text.size = 8,
+ legend.show = TRUE,
+ legend.width = 0.5,
+ article = TRUE,
+ grid = FALSE,
+ add = NULL,
+ return = FALSE,
+ return.ggplot = FALSE,
+ return.gtable = TRUE,
+ plot = TRUE,
+ warn.print = FALSE,
+ lib.path = NULL
+)
+
+
+
+
+
diff --git a/examples_fun_gg_donut.R b/examples_fun_gg_donut.R
new file mode 100644
index 0000000000000000000000000000000000000000..39f7221728cac454a93d9ffa4c791e8707fef5ff
--- /dev/null
+++ b/examples_fun_gg_donut.R
@@ -0,0 +1,212 @@
+# EXAMPLES
+
+## Data set
+obs1 <- data.frame(
+ Km = c(20, 10, 1, 5),
+ Car = c("TUUT", "WIIM", "BIP", "WROUM"),
+ Color1 = c(1:3, NA),
+ Color2 = c("burlywood1", "cadetblue1", "coral", "darkmagenta"),
+ Color3 = c("#F8766D", "#00BA38", NA, "#619CFF"),
+ Country = c("FR", "UK", "US", NA),
+ stringsAsFactors = TRUE)
+obs1
+fun_open(pdf = FALSE, width = 5, height = 5)
+
+## Mandatory arguments
+# Note that the order is systematically in the decreasing order of frequencies, starting at the top and turning clockwise
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car")
+
+## Color modification
+# Default colors
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ fill.palette = NULL,
+ fill.color = NULL
+)
+# Using the fill.palette argument
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ fill.palette = "BrBG",
+ fill.color = NULL
+)
+# Using the fill.color argument (as positive integers). NA are white
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ fill.palette = NULL,
+ fill.color = obs1$Color1
+)
+
+# The fill.color argument overrides the fill.palette argument
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ fill.palette = "Spectral",
+ fill.color = obs1$Color1
+)
+# Using the fill.color argument (as elements from colors())
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ fill.palette = NULL,
+ fill.color = obs1$Color2
+)
+# Warning: the colors order in fill.color is the one according to the decreasing values of the freq argument. Thus, to have the correct association between obs1$Car and obs1$Color2, obs1 must be sorted
+obs1 <- obs1[order(obs1$Km, decreasing = TRUE), ]
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ fill.palette = NULL,
+ fill.color = obs1$Color2
+)
+# Using the fill.color argument, as hexadecimal values
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ fill.palette = NULL,
+ fill.color = obs1$Color3
+)
+
+## hole of the donut
+# hole being 25% of the radius of the donut
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ hole.size = 0.25,
+ hole.text.size = 8 # size in mm
+)
+
+## border of slices
+# positive integer
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ border.color = 2,
+ border.size = 2 # in mm
+)
+# element of colors()
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ border.color = "green",
+ border.size = 2 # in mm
+)
+# hexadecimal value
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ border.color = "#619CFF",
+ border.size = 2 # in mm
+)
+
+## title of the plot
+# hole being 25% of the radius of the donut
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ title = "DONUT",
+ title.text.size = 20,
+)
+
+## Annotation of the slices
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ annotation = "Country",
+ annotation.distance = 1, # annotation.distance = 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
+ annotation.size = 5, # size of the texte in mm
+ annotation.force = 0, # force of repulsion between overlapping text labels
+ annotation.force.pull = 0, # force of attraction between a text label and its corresponding data point
+)
+
+## Management of the legend area
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ border.size = 2,
+ legend.show = TRUE, # FALSE remove the legend, not the area of the legend
+ legend.width = 0.5, # between 0 (no area for the legend) to 1 (half the device width for the legend area)
+ legend.name = "Noise", # legend title added
+ legend.text.size = 10, # font size in mm of the legend labels
+ legend.box.size = 5, # size of the legend squares in mm
+ legend.box.space = 1, # space between the legend boxes in mm
+ legend.limit = NULL, # all the slices lower that 0.2 in proportion are not displayed in the legend
+ legend.add.prop = TRUE # proportion after the class names added
+)
+
+## the add argument
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ add = "+ggplot2::theme_gray()"
+)
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ add = "+ggplot2::facet_wrap(facets = 'Country', labeller = 'label_both') + ggplot2::theme(strip.background = ggplot2::element_rect(color = 'grey', size = 0.5), strip.text = ggplot2::element_text(size = 10, face = 'bold'), panel.spacing = ggplot2::unit(0.5, 'lines'))" # or ggplot2::vars(Country) instead of 'Country'. See https://ggplot2.tidyverse.org/reference/labeller.html
+)
+
+## The return and plot arguments
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ return = FALSE,
+ plot = FALSE,
+)
+# nothing is returned and nothing is plotted
+res <- fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ return = TRUE, # output returned and assigned into res. If FALSE, res is NULL
+ plot = TRUE, # plot displayed during assignation into res
+)
+res # info of the plot are stored in the res object. The plot is also displayed during the assignation into res (plot = TRUE)
+
+## The return.ggplot argument (return argument must be TRUE)
+res2 <- fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ return = TRUE,
+ return.ggplot = TRUE,
+ plot = FALSE
+)
+# Nothing plotted during the assignation into res2
+res2 # the pain with return.ggplot = TRUE is that each time res2 is called, a plot appears (because res2$ggplot is not NULL, as when return.ggplot = FALSE is used)
+res2$panel # however, calling a element of res2 does not plot the graph
+res2$ggplot #except when using $ggplot
+# The advantage of $ggplot is that it is easy to update the plot
+res$ggplot + ggplot2::annotate(geom = "text", x = -0.5, y = 0, label = "NOT GOOD", size = 20, angle = 45)
+
+## The return.gtable argument (return argument must be TRUE)
+res3 <- fun_gg_donut(data1 = obs1, freq = "Km", categ = "Car",
+ title = "DONUT",
+ return = TRUE,
+ return.gtable = TRUE, # gtable of the full graph
+ plot = FALSE
+)
+# Nothing plotted during the assignation into res3
+res3 # no plotting, contrary to with return.ggplot = TRUE
+# replotting
+gridExtra::grid.arrange(res3$gtable) # full graph
+# But contrary to $ggplot, $gtable cannot be easily updated (see https://stackoverflow.com/questions/26499608/inverse-of-ggplotgrob)
+# plot the first grob
+gridExtra::grid.arrange(res3$gtable[ ,1]) # made of the main plot + title
+# plot the second grob
+gridExtra::grid.arrange(res3$gtable[ ,2]) # legend
+# plot the main plot without the title
+gridExtra::grid.arrange(res3$gtable[,1]$grob[[1]][2])
+#plot the title
+gridExtra::grid.arrange(res3$gtable[,1]$grob[[1]][1])
+
+## The warn.print argument
+fun_gg_donut(data1 = obs1, freq = "Km", categ = "Country",
+ warn.print = TRUE
+)
+# Warning messages shown
+res4 <- fun_gg_donut(data1 = obs1, freq = "Km", categ = "Country",
+ return = TRUE,
+ warn.print = FALSE
+)
+# Warning messages not shown
+cat(res4$warn) # but can be recover this way using return = TRUE
+
+## All the arguments
+fun_gg_donut(
+ data1 = obs1,
+ freq = "Km",
+ categ = "Car",
+ fill.palette = NULL,
+ fill.color = NULL,
+ hole.size = 0.5,
+ hole.text.size = 14,
+ border.color = "gray50",
+ border.size = 0.2,
+ title = "",
+ title.text.size = 12,
+ annotation = NULL,
+ annotation.distance = 0,
+ annotation.size = 3,
+ annotation.force = 1,
+ annotation.force.pull = 100,
+ legend.show = TRUE,
+ legend.width = 0.25,
+ legend.name = NULL,
+ legend.limit = NULL,
+ legend.add.prop = FALSE,
+ add = NULL,
+ return = FALSE,
+ return.ggplot = FALSE,
+ return.gtable = TRUE,
+ plot = TRUE,
+ warn.print = FALSE,
+ lib.path = NULL
+)
+
+
+
+
+
diff --git a/examples_fun_gg_scatter.R b/examples_fun_gg_scatter.R
new file mode 100644
index 0000000000000000000000000000000000000000..663cb5fa2ccf418e72815d6335d1c95fc752950a
--- /dev/null
+++ b/examples_fun_gg_scatter.R
@@ -0,0 +1,490 @@
+# EXAMPLES
+
+### Data set
+set.seed(1)
+# Line
+obs1 <- data.frame(
+ Km = c(2, 1, 6, 5, 4, 7),
+ Time = c(2, 1, 6, 5, 4, 7)^2,
+ Car = c("TUUT", "TUUT", "TUUT", "WIIM", "WIIM", "WIIM"),
+ Color1 = rep(c("coral", "lightblue"), each = 3),
+ stringsAsFactors = TRUE
+)
+# First scattering
+obs2 <- data.frame(
+ Km = rnorm(1000, 20, 3),
+ Time = rnorm(1000, 20, 3),
+ Animal = rep(c("CAT", "DOG"), 500),
+ Color2 = rep(c("darkblue", "darkred"), times = 500),
+ stringsAsFactors = TRUE
+)
+# Second scattering
+obs3 <- data.frame(
+ Distance = rnorm(1000, 30, 3),
+ Time_lapse = rnorm(1000, 30, 3),
+ Beast = rep(c("LION", "ZEBRA"), 500),
+ Color3 = rep(3:4, times = 500),
+ stringsAsFactors = TRUE
+)
+# obs4 assembles ob2 and obs3
+obs4 <- data.frame(
+ Km = c(obs2$Km, obs3$Distance),
+ Time = c(obs2$Time, obs3$Time_lapse),
+ Type = c(as.character(obs2$Animal), as.character(obs3$Beast)),
+ stringsAsFactors = TRUE
+)
+fun_info(obs4)
+set.seed(NULL)
+fun_info(obs1)
+fun_info(obs2)
+fun_info(obs3)
+fun_open(pdf = FALSE, width = 5, height = 5)
+
+
+
+
+
+
+
+
+
+## Mandatory arguments
+### single dataset
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time")
+### single dataset submitted as list
+fun_gg_scatter(
+ data1 = list(obs1),
+ x = list("Km"),
+ y = list("Time")
+)
+### multiple dataset
+# Elements in list are named L1, L2, etc., just to show the correspondence between the arguments data1, x, y, categ, etc.
+# Of note, no legend is displayed. For a legend, please merge the two data frames, or create a new categ column in each data frame (see below)
+fun_gg_scatter(
+ data1 = list(
+ L1 = obs2,
+ L2 = obs3
+ ),
+ x = list(
+ L1 = "Km",
+ L2 = "Distance"
+ ),
+ y = list(
+ L1 = "Time",
+ L2 = "Time_lapse"
+ )
+)
+
+### The categ argument to generate legends. Create a categ column in data frames if a legend is required
+### single dataset
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time",
+ categ = "Car"
+)
+### multiple datasets
+fun_gg_scatter(data1 = list(obs2, obs3), x = list("Km", "Distance"), y = list("Time", "Time_lapse"),
+ categ = list(
+ L1 = "Animal",
+ L2 = "Beast"
+ )
+)
+# Another way for multiple datasets representation, depending on legend required
+fun_gg_scatter(data1 = obs4, x = "Km", y = "Time",
+ categ = "Type"
+)
+
+
+### Order of layers in the legend (multiple datasets)
+# order of layer depends on the data1 order (obs3 before obs2, and then all the associated parameters in the same order in the arguments)
+fun_gg_scatter(
+ data1 = list(
+ L1 = obs3,
+ L2 = obs2
+ ),
+ x = list(
+ L1 = "Distance",
+ L2 = "Km"
+ ),
+ y = list(
+ L1 = "Time_lapse",
+ L2 = "Time"
+ ),
+ categ = list(
+ L1 = "Beast",
+ L2 = "Animal"
+ )
+)
+
+### Order of classes in each layer
+### single dataset
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+ categ.class.order = c("WIIM", "TUUT")
+)
+### multiple datasets
+fun_gg_scatter(data1 = list(obs2, obs3), x = list("Km", "Distance"), y = list("Time", "Time_lapse"), categ = list("Animal", "Beast"),
+ categ.class.order = list(
+ L1 = c("DOG", "CAT"),
+ L2 = c("ZEBRA", "LION")
+ )
+)
+
+
+
+### Colors
+### single dataset
+# Using a single color value
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+ color = "black"
+) # replace "black" by 2 to test integer values
+# Using one color value par class of Categ1
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car", # mandatory categ argument when several color required
+ color = c("darkblue", "darkgreen") # replace c("darkblue", "darkgreen") by 2:3 to test integer values
+)
+# Using a vector of color values (e.g., data frame column), with respect of the correspondence between Car and Color1 columns
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car", # replace "black" by 2 to test integer values
+ color = obs1$Color1 # # replace obs1$Color1 by as.numeric(obs1$Color1) to test integer values
+)
+### multiple datasets
+# single color -> same color for all the datasets and all the classes of categ if non NULL
+fun_gg_scatter(data1 = list(obs2, obs3), x = list("Km", "Distance"), y = list("Time", "Time_lapse"), categ = list("Animal", "Beast"),
+ color = "darkblue" # replace "darkblue" by 2 to test integer values
+)
+
+# list of single colors -> each dataset with the same color
+fun_gg_scatter(data1 = list(obs2, obs3), x = list("Km", "Distance"), y = list("Time", "Time_lapse"), categ = list("Animal", "Beast"),
+ color = list(
+ L1 = "darkblue", # replace "darkblue" by 2 to test integer values
+ L2 = "darkgreen" # replace "darkgreen" by 3 to test integer values
+ )
+)
+# list of single colors for each class of the categ argument
+fun_gg_scatter(data1 = list(obs2, obs3), x = list("Km", "Distance"), y = list("Time", "Time_lapse"), categ = list("Animal", "Beast"),
+ color = list(
+ L1 = c("darkblue", "darkred"), # replace c("darkblue", "darkred") by 2:3 to test integer values
+ L2 = c("darkgreen", "darkorange") # replace c("darkgreen", "darkviolet") by 4:5 to test integer values
+ )
+)
+# list of vectors of color values (e.g., data frame column), with respect of the correspondence between the categorical and the color columns
+fun_gg_scatter(data1 = list(obs2, obs3), x = list("Km", "Distance"), y = list("Time", "Time_lapse"), categ = list("Animal", "Beast"),
+ color = list(
+ L1 = obs2$Color2, # Replace by NULL to see that different levels of grey is used per dataset (not per class of the categ argument)
+ L2 = obs3$Color3 # color of integer value can be used. Replace by NULL to see that different levels of grey is used per dataset (not per class of the categ argument)
+ )
+)
+
+
+### geometry
+### single dataset
+# scatterplot
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+ geom = "geom_point"
+)
+# line: coordinates plotted then line connection, from the lowest to highest x coordinates first and from the lowest to highest y coordinates thenafter
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+ geom = "geom_line"
+)
+# line: coordinates plotted then line connection respecting the row order in data1
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+ geom = "geom_path"
+)
+# step: coordinates plotted then line connection respecting the row order in data1 but drawn in steps
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+ geom = "geom_step",
+ geom.step.dir = "vh" # test "vh" (vertical then horizontal), "hv" (horizontal then vertical) and "mid" (step half-way between adjacent x-values)
+)
+# horizontal line
+fun_gg_scatter(data1 = obs1[c(1, 4), ], y = "Time", categ = "Car", # c(1, 4) because a single value of y per class of categ. Otherwise use data1 = obs1, x = "Km", categ = NULL
+ x = NULL, # must be NULL for geom_hline
+ geom = "geom_hline",
+ x.lim = c(0, 1) # mandatory because no x-axis limits in the dataset
+)
+# vertical line
+fun_gg_scatter(data1 = obs1[c(1, 4), ], x = "Km", categ = "Car", # c(1, 4) because a single value of x per class of categ. Otherwise use data1 = obs1, x = "Km", categ = NULL
+ y = NULL, # must be NULL for geom_hline
+ geom = "geom_vline",
+ y.lim = c(0, 1) # mandatory because no y-axis limits in the dataset
+)
+# stick: dots as vertical bars
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+ geom = "geom_stick",
+ geom.stick.base = 20 # set the base of the sticks when using "geom_stick" of the geom argument. if NULL, use the bottom of the y-axis
+)
+### multiple dataset
+fun_gg_scatter(data1 = list(obs2, obs3), x = list("Km", "Distance"), y = list("Time", "Time_lapse"), categ = list("Animal", "Beast"),
+ geom = list(
+ L1 = "geom_point",
+ L2 = "geom_line"
+ )
+)
+### multiple dataset: complex example
+fun_gg_scatter(
+ data1 = list(
+ L1 = obs1,
+ L2 = obs2,
+ L3 = obs3,
+ L4 = obs1[c(1, 4), ]
+ ),
+ x = list(
+ L1 = "Km",
+ L2 = "Km",
+ L3 = "Distance",
+ L4 = NULL # because of L4 = "geom_hline" below
+ ),
+ y = list(
+ L1 = "Time",
+ L2 = "Time",
+ L3 = "Time_lapse",
+ L4 = "Time"
+ ),
+ categ = list(
+ L1 = "Car",
+ L2 = "Animal",
+ L3 = "Beast",
+ L4 = "Car"
+ ),
+ geom = list( # no more than 3 "geom_point", and no more than 3 kind of lines
+ L1 = "geom_point",
+ L2 = "geom_line",
+ L3 = "geom_step",
+ L4 = "geom_hline"
+ ),
+ geom.step.dir = "hv" # or geom.step.dir = list(L1 = NULL, L2 = NULL, L3 = "hv", L4 = NULL) # NULL or anything else, since only the 3rd compartment will be used, because only the 3rd compartment of geom is "geom_step"
+)
+
+
+
+
+### arguments of dots
+### single dataset
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+ alpha = 0.7,
+ dot.size = 5, # shape radius (?) in mm
+ dot.shape = 22, # shape of the dots (see https://ggplot2.tidyverse.org/articles/ggplot2-specs.html)
+ dot.border.size = 3, # border dot width in mm, use 0 for no border
+ dot.border.color = "grey"
+)
+### multiple dataset
+# single value. If one geom argument is not "geom_point" (default geom value), these arguments are ignored, except alpha (see below)
+fun_gg_scatter(data1 = list(obs2, obs3), x = list("Km", "Distance"), y = list("Time", "Time_lapse"), categ = list("Animal", "Beast"),
+ alpha = 0.2,
+ dot.size = 5, # shape radius (?) in mm
+ dot.shape = 22, # shape of the dots (see https://ggplot2.tidyverse.org/articles/ggplot2-specs.html)
+ dot.border.size = 3, # border dot width in mm, use 0 for no border
+ dot.border.color = 7 # Integer is allowed
+)
+# list of values. If one geom argument is not "geom_point" (default geom value), the corresponding compartments of these arguments are ignored, except alpha (see below)
+fun_gg_scatter(data1 = list(obs2, obs3), x = list("Km", "Distance"), y = list("Time", "Time_lapse"), categ = list("Animal", "Beast"),
+ alpha = list(0.2, 0.7),
+ dot.size = list(4, 5), # shape radius (?) in mm
+ dot.shape = list(21, 22), # shape of the dots (see https://ggplot2.tidyverse.org/articles/ggplot2-specs.html)
+ dot.border.size = list(4, 3), # border dot width in mm, use 0 for no border
+ dot.border.color = "grey" # no list here -> same border color whatever the shapes
+)
+
+
+
+### arguments of lines
+### single dataset
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car", geom = "geom_line",
+ alpha = 0.7,
+ line.size = 2, # line width in mm
+ line.type = "dashed" # kind of lines (see https://ggplot2.tidyverse.org/articles/ggplot2-specs.html)
+)
+### multiple dataset
+# single value. If one geom argument is not "geom_point" (default geom value), these arguments are ignored, except alpha (see below)
+fun_gg_scatter(data1 = list(obs2, obs3), x = list("Km", "Distance"), y = list("Time", "Time_lapse"), categ = list("Animal", "Beast"), geom = list("geom_line", "geom_stick"),
+ alpha = 0.2,
+ line.size = 1, # line width in mm
+ line.type = "solid" # kind of lines (see https://ggplot2.tidyverse.org/articles/ggplot2-specs.html)
+)
+# list of values. If one geom argument is not "geom_point" (default geom value), the corresponding compartments of these arguments are ignored, except alpha (see below)
+fun_gg_scatter(data1 = list(obs2, obs3), x = list("Km", "Distance"), y = list("Time", "Time_lapse"), categ = list("Animal", "Beast"), geom = list("geom_line", "geom_stick"),
+ alpha = list(0.5, 0.05),
+ line.size = list(1, 3), # line width in mm
+ line.type = list("81", "solid") # kind of lines (see https://ggplot2.tidyverse.org/articles/ggplot2-specs.html)
+)
+
+### arguments of x-axis
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+ x.lim = c(1000, 0.1), # order matters
+ x.lab = "SIZE",
+ x.log = "log10", # try "no"
+ x.tick.nb = 10, # approximate number
+ x.second.tick.nb = 2,
+ x.include.zero = FALSE,
+ x.left.extra.margin = 0,
+ x.right.extra.margin = 0,
+ x.text.angle = 45
+)
+
+
+### arguments of y-axis
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+ y.lim = c(1000, 0.1), # order matters
+ y.lab = "SIZE",
+ y.log = "log10", # try "no"
+ y.tick.nb = 10, # approximate number
+ y.second.tick.nb = 2,
+ y.include.zero = FALSE,
+ y.top.extra.margin = 0,
+ y.bottom.extra.margin = 0,
+ y.text.angle = 45
+)
+
+### raster plot (easier to display and export as it convert vectorial dot layer into matricial dot layer)
+res <- fun_open(pdf = FALSE, width = 7, height = 4, return.output = TRUE)
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+ raster = TRUE,
+ raster.ratio = res$dim[2] / res$dim[1], # test raster.ratio = 1 to see the distorsion
+ raster.threshold = 1
+)
+
+
+### Text management
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+text.size = 20
+)
+
+### Title
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+title = "FIRST EXPERIMENT",
+title.text.size = 20
+)
+
+### Management of the legend area and legend titles
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+legend.show = TRUE, # FALSE remove the legend, not the area of the legend
+legend.width = 1, # between 0 (no area for the legend) to 1 (half the device width for the legend area). Use NULL for default management
+legend.name = "CORVETTE" # if categ = "Car", then the legend name is "Car" by default. Use "" to remove the legend name
+)
+
+### Appearance
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+article = FALSE,
+grid = TRUE
+)
+
+### the add argument
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+add = "+ggplot2::theme_classic()"
+)
+fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+add = "+ggplot2::facet_wrap(facets = 'Car', labeller = 'label_both') + ggplot2::theme(strip.background = ggplot2::element_rect(color = 'grey', size = 0.5), strip.text = ggplot2::element_text(size = 10, face = 'bold'), panel.spacing = ggplot2::unit(0.5, 'lines'))" # or ggplot2::vars(Car) instead of 'Car'. See https://ggplot2.tidyverse.org/reference/labeller.html
+) # use legend.show = FALSE, legend.width = 0 to remove the legend area
+
+
+### Other parameters
+res <- fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+return = TRUE, # output returned (and assigned into res)
+return.ggplot = TRUE,
+return.gtable = FALSE,
+plot = FALSE, # no plot displayed
+warn.print = FALSE,
+lib.path = NULL
+)
+# plot the result
+fun_open(pdf = FALSE)
+res$ggplot
+
+# The advantage of $ggplot is that it is easy to update the plot
+res$ggplot + ggplot2::annotate(geom = "text", x = 1.5, y = 400, label = "NOT GOOD", size = 20, angle = 45)
+
+# However, manipulation of res triggers plotting because of the presence of non NULL $ggplot, which is annoying, as explain in the function description. Thus, it is preferable to use return.ggplot = FALSE
+fun_open(pdf = FALSE)
+res
+
+
+
+
+### Notes about the gtable output
+res2 <- fun_gg_scatter(data1 = obs1, x = "Km", y = "Time", categ = "Car",
+return = TRUE,
+return.ggplot = FALSE,
+return.gtable = TRUE, # return.gtable must be TRUE to have a non NULL $gtable output into res2
+plot = TRUE, # plot must be TRUE to have a non NULL $gtable output into res2
+warn.print = FALSE,
+lib.path = NULL
+)
+
+# display the results (does not plot the graph, contrary to $ggplot)
+fun_open(pdf = FALSE)
+res2
+
+# replot
+fun_open(pdf = FALSE)
+gridExtra::grid.arrange(res2$gtable) # Contrary to $ggplot, $gtable cannot be easily updated (see https://stackoverflow.com/questions/26499608/inverse-of-ggplotgrob)
+# plot the first grob
+fun_open(pdf = FALSE)
+gridExtra::grid.arrange(res2$gtable[1,1])
+# plot the second grob
+fun_open(pdf = FALSE)
+gridExtra::grid.arrange(res2$gtable[1,2])
+
+
+
+### All the arguments
+fun_gg_scatter(
+data1 = obs1,
+x = "Km",
+y = "Time",
+categ = NULL,
+categ.class.order = NULL,
+color = NULL,
+geom = "geom_point",
+geom.step.dir = "hv",
+geom.stick.base = NULL,
+alpha = 0.5,
+dot.size = 2,
+dot.shape = 21,
+dot.border.size = 0.5,
+dot.border.color = NULL,
+line.size = 0.5,
+line.type = "solid",
+x.lim = NULL,
+x.lab = NULL,
+x.log = "no",
+x.tick.nb = NULL,
+x.second.tick.nb = NULL,
+x.include.zero = FALSE,
+x.left.extra.margin = 0.05,
+x.right.extra.margin = 0.05,
+x.text.angle = 0,
+y.lim = NULL,
+y.lab = NULL,
+y.log = "no",
+y.tick.nb = NULL,
+y.second.tick.nb = NULL,
+y.include.zero = FALSE,
+y.top.extra.margin = 0.05,
+y.bottom.extra.margin = 0.05,
+y.text.angle = 0,
+raster = FALSE,
+raster.ratio = 1,
+raster.threshold = NULL,
+text.size = 12,
+title = "",
+title.text.size = 12,
+legend.show = TRUE,
+legend.width = 0.5,
+legend.name = NULL,
+article = TRUE,
+grid = FALSE,
+add = NULL,
+return = FALSE,
+return.ggplot = FALSE,
+return.gtable = TRUE,
+plot = TRUE,
+warn.print = FALSE,
+lib.path = NULL
+)
+
+
+
+
+
+
+
+
+
+
+
+
diff --git a/fun_gg_donut.R b/fun_gg_donut.R
new file mode 100644
index 0000000000000000000000000000000000000000..cb0e97e109103b1fd76341ac54d8fa7576cd39e3
--- /dev/null
+++ b/fun_gg_donut.R
@@ -0,0 +1,753 @@
+
+
+fun_gg_donut <- function(
+ data1,
+ freq,
+ categ,
+ fill.palette = NULL,
+ fill.color = NULL,
+ hole.size = 0.5,
+ hole.text = TRUE,
+ hole.text.size = 14,
+ border.color = "gray50",
+ border.size = 0.2,
+ title = "",
+ title.text.size = 7,
+ annotation = NULL,
+ annotation.distance = 0,
+ annotation.size = 3,
+ annotation.force = 1,
+ annotation.force.pull = 100,
+ legend.show = TRUE,
+ legend.width = 0.25,
+ 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 = FALSE,
+ return.ggplot = FALSE,
+ return.gtable = TRUE,
+ plot = TRUE,
+ warn.print = TRUE,
+ lib.path = NULL
+){
+ # 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_gg_palette",
+ "fun_gg_get_legend",
+ "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 to avoid bugs (used in this function)
+ # end reserved words to avoid bugs (used in this function)
+ # arg with no default values
+ mandat.args <- c(
+ "data1",
+ "freq",
+ "categ"
+ )
+ tempo <- eval(parse(text = paste0("missing(", paste0(mandat.args, collapse = ") | missing("), ")")))
+ if(any(tempo)){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", ifelse(length(mandat.args) > 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 #
+ 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 = data1, class = "data.frame", na.contain = TRUE, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = freq, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = categ, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ if( ! is.null(fill.palette)){
+ tempo <- fun_check(data = fill.palette, options = c("BrBG", "PiYG", "PRGn", "PuOr", "RdBu", "RdGy", "RdYlBu", "RdYlGn", "Spectral", "Accent", "Dark2", "Paired", "Pastel1", "Pastel2", "Set1", "Set2", "Set3", "Blues", "BuGn", "BuPu", "GnBu", "Greens", "Greys", "Oranges", "OrRd", "PuBu", "PuBuGn", "PuRd", "Purples", "RdPu", "Reds", "YlGn", "YlGnBu", "YlOrBr", "YlOrRd"), length = 1, fun.name = function.name) ; eval(ee)
+ }else{
+ # no fun_check test here, it is just for checked.arg.names
+ tempo <- fun_check(data = fill.palette, class = "vector")
+ checked.arg.names <- c(checked.arg.names, tempo$object.name)
+ }
+ if( ! is.null(fill.color)){
+ tempo1 <- fun_check(data = fill.color, class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name)
+ tempo2 <- fun_check(data = fill.color, class = "factor", na.contain = TRUE, fun.name = function.name)
+ tempo3 <- fun_check(data = fill.color, class = "integer", double.as.integer.allowed = TRUE, na.contain = TRUE, neg.values = FALSE, fun.name = function.name) # not need to test inf with integers
+ if(tempo1$problem == TRUE & tempo2$problem == TRUE & tempo3$problem == TRUE){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nfill.color ARGUMENT MUST BE A VECTOR OF (1) HEXADECIMAL COLOR STRINGS STARTING BY #, OR (2) COLOR NAMES GIVEN BY colors(), OR (3) POSITIVE INTEGER VALUES")
+ text.check <- c(text.check, tempo.cat)
+ arg.check <- c(arg.check, TRUE)
+ checked.arg.names <- c(checked.arg.names, tempo1$object.name)
+ }else if(tempo3$problem == FALSE & any(is.infinite(fill.color))){ # is.infinite() deals with NA as FALSE
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nfill.color ARGUMENT CANNOT CONTAIN Inf VALUES AMONG POSITIVE INTEGER VALUES")
+ text.check <- c(text.check, tempo.cat)
+ arg.check <- c(arg.check, TRUE)
+ checked.arg.names <- c(checked.arg.names, tempo1$object.name)
+ }else if(tempo3$problem == FALSE & any(fill.color == 0, na.rm = TRUE)){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nfill.color ARGUMENT CANNOT CONTAIN 0 AMONG POSITIVE INTEGER VALUES")
+ text.check <- c(text.check, tempo.cat)
+ arg.check <- c(arg.check, TRUE)
+ checked.arg.names <- c(checked.arg.names, tempo1$object.name)
+ }
+ }
+ tempo <- fun_check(data = hole.size, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = hole.text, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = hole.text.size, class = "vector", mode = "numeric", neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ tempo1 <- fun_check(data = border.color, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name)
+ tempo2 <- fun_check(data = border.color, class = "integer", double.as.integer.allowed = TRUE, neg.values = FALSE, na.contain = FALSE, length = 1, fun.name = function.name) # not need to test inf with integers
+ if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nborder.color ARGUMENT MUST BE A SINGLE CHARACTER STRING OR POSITIVE INTEGER")
+ text.check <- c(text.check, tempo.cat)
+ arg.check <- c(arg.check, TRUE)
+ checked.arg.names <- c(checked.arg.names, tempo1$object.name)
+ }
+ tempo <- fun_check(data = border.size, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = title, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = title.text.size, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ if( ! is.null(annotation)){
+ tempo <- fun_check(data = annotation, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = annotation.distance, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = annotation.size, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = annotation.force, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = annotation.force.pull, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ }else{
+ # no fun_check test here, it is just for checked.arg.names
+ tempo <- fun_check(data = annotation, class = "vector")
+ checked.arg.names <- c(checked.arg.names, tempo$object.name)
+ }
+ tempo <- fun_check(data = legend.show, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+ if( ! is.null(legend.width)){
+ tempo <- fun_check(data = legend.width, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
+ }else{
+ # no fun_check test here, it is just for checked.arg.names
+ tempo <- fun_check(data = legend.width, class = "vector")
+ checked.arg.names <- c(checked.arg.names, tempo$object.name)
+ }
+ if( ! is.null(legend.name)){
+ tempo <- fun_check(data = legend.name, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ }else{
+ # no fun_check test here, it is just for checked.arg.names
+ tempo <- fun_check(data = legend.name, class = "vector")
+ checked.arg.names <- c(checked.arg.names, tempo$object.name)
+ }
+ tempo <- fun_check(data = legend.text.size, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = legend.box.size, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = legend.box.space, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; eval(ee)
+ if( ! is.null(legend.limit)){
+ tempo <- fun_check(data = legend.limit, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
+ }else{
+ # no fun_check test here, it is just for checked.arg.names
+ tempo <- fun_check(data = legend.limit, class = "vector")
+ checked.arg.names <- c(checked.arg.names, tempo$object.name)
+ }
+ tempo <- fun_check(data = legend.add.prop, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+ if( ! is.null(add)){
+ tempo <- fun_check(data = add, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
+ }else{
+ # no fun_check test here, it is just for checked.arg.names
+ tempo <- fun_check(data = add, class = "vector")
+ checked.arg.names <- c(checked.arg.names, tempo$object.name)
+ }
+ tempo <- fun_check(data = return, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = return.ggplot, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = return.gtable, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = plot, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+ tempo <- fun_check(data = warn.print, class = "logical", length = 1, 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) # several possible paths
+ }else{
+ # no fun_check test here, it is just for checked.arg.names
+ tempo <- fun_check(data = lib.path, class = "vector")
+ checked.arg.names <- c(checked.arg.names, tempo$object.name)
+ }
+ 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) #
+ }
+ }
+ # source("C:/Users/Gael/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(
+ "data1",
+ "freq",
+ "categ",
+ # "fill.palette", # inactivated because can be null
+ # "fill.color", # inactivated because can be null
+ "hole.size",
+ "hole.text",
+ "hole.text.size",
+ "border.color",
+ "border.size",
+ "title",
+ "title.text.size",
+ # "annotation", # inactivated because can be null
+ "annotation.distance",
+ "annotation.size",
+ "annotation.force",
+ "annotation.force.pull",
+ "legend.show",
+ # "legend.width", # inactivated because can be null
+ # "legend.name", # inactivated because can be null
+ "legend.text.size",
+ "legend.box.size",
+ "legend.box.space",
+ # "legend.limit", # inactivated because can be null
+ "legend.add.prop",
+ # "add", # inactivated because can be null
+ "return",
+ "return.ggplot",
+ "return.gtable",
+ "plot",
+ "warn.print"
+ # "lib.path" # inactivated because can be null
+ )
+ 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\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
+ if(exists(".Random.seed", envir = .GlobalEnv)){ # if .Random.seed does not exists, it means that no random operation has been performed yet in any R environment
+ tempo.random.seed <- .Random.seed
+ on.exit(assign(".Random.seed", tempo.random.seed, env = .GlobalEnv))
+ }else{
+ on.exit(set.seed(NULL)) # inactivate seeding -> return to complete randomness
+ }
+ set.seed(1)
+ # 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
+ # end warning initiation
+ # other checkings
+ removed.row.nb <- NULL
+ removed.rows <- data.frame(stringsAsFactors = FALSE)
+ data1.ini <- data1 # strictly identical to data1
+ if( ! freq %in% names(data1)){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nfreq ARGUMENT MUST BE A COLUMN NAME OF THE data1 ARGUMENT")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else{
+ if(all(is.na(data1[ , freq]) | is.infinite(data1[ , freq]))){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nTHE freq COLUMN OF data1 CANNOT BE JUST NA OR Inf")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ tempo <- fun_check(data = data1[ , freq], mode = "numeric", neg.values = FALSE, fun.name = function.name)
+ if(tempo$problem == TRUE){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\n", tempo$text)
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ # Inf and NA removal
+ if(any(is.infinite(data1[, freq]) | is.na(data1[, freq]))){
+ warn.count <- warn.count + 1
+ tempo.warn <- paste0("(", warn.count,") PRESENCE OF Inf OR NA VALUES IN THE ", freq, " COLUMN OF THE data1 ARGUMENT AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)")
+ warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ tempo <- which(is.infinite(data1.ini[, freq]) | is.na(data1.ini[, freq])) # data.ini used for the output
+ removed.row.nb <- c(removed.row.nb, tempo)
+ removed.rows <- rbind(removed.rows, data1.ini[tempo, ], stringsAsFactors = FALSE) # data.ini used for the output
+ data1 <- data1[ ! (is.infinite(data1[, freq]) | is.na(data1[, freq])), ] #
+ }
+ # end Inf and NA removal
+ # 0 removal
+ if(any(data1[, freq] == 0)){
+ warn.count <- warn.count + 1
+ tempo.warn <- paste0("(", warn.count,") PRESENCE OF 0 VALUES IN THE ", freq, " COLUMN OF THE data1 ARGUMENT AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)")
+ warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ tempo <- which(data1[, freq] == 0) # data.ini used for the output
+ removed.row.nb <- c(removed.row.nb, tempo)
+ removed.rows <- rbind(removed.rows, data1.ini[tempo, ], stringsAsFactors = FALSE) # data.ini used for the output
+ data1 <- data1[ data1[, freq] != 0, ] #
+ }
+ # end 0 removal
+ }
+
+ if( ! categ %in% names(data1)){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\ncateg ARGUMENT MUST BE A COLUMN NAME OF THE data1 ARGUMENT")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else{
+ if(all(is.na(data1[ , categ]))){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nTHE categ COLUMN OF data1 CANNOT BE JUST NA")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ tempo1 <- fun_check(data = categ, class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name)
+ tempo2 <- fun_check(data = categ, class = "factor", na.contain = TRUE, fun.name = function.name)
+ if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nTHE categ COLUMN OF data1 MUST BE CLASS \"factor\" OR \"character\"")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ # NA removal
+ if(any(is.na(data1[, categ]))){
+ warn.count <- warn.count + 1
+ tempo.warn <- paste0("(", warn.count,") PRESENCE OF NA VALUES IN THE ", categ, " COLUMN OF THE data1 ARGUMENT AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)")
+ warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ tempo <- which(is.na(data1.ini[, categ])) # data.ini used for the output
+ removed.row.nb <- c(removed.row.nb, tempo)
+ removed.rows <- rbind(removed.rows, data1.ini[tempo, ], stringsAsFactors = FALSE) # data.ini used for the output
+ data1 <- data1[ ! is.na(data1[, categ]), ] #
+ }
+ # end Inf and NA removal
+ if(any(duplicated(data1[, categ]))){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nTHE categ COLUMN OF data1 CANNOT CONTAIN DUPLICATED VALUES\n", paste(data1[, categ][duplicated(data1[, categ])], collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ }
+
+ if( ! is.null(annotation)){
+ if( ! annotation %in% names(data1)){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nannotation ARGUMENT MUST BE A COLUMN NAME OF THE data1 ARGUMENT")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else{
+ if(all(is.na(data1[ , annotation]))){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nIF NON NULL, THE annotation COLUMN OF data1 CANNOT BE JUST NA")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ tempo1 <- fun_check(data = annotation, class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name)
+ tempo2 <- fun_check(data = annotation, class = "factor", na.contain = TRUE, fun.name = function.name)
+ if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nTHE annotation COLUMN OF data1 MUST BE CLASS \"factor\" OR \"character\"")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ if(any(duplicated(data1[, annotation]))){
+ warn.count <- warn.count + 1
+ tempo.warn <- paste0("(", warn.count,") PRESENCE OF DUPLICATED VALUES IN THE ", annotation, " COLUMN OF THE data1 ARGUMENT: ", paste0(data1[, annotation][duplicated(data1[, annotation])], collapse = " "))
+ warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ }
+ }
+ }
+ if(length(data1) == 0){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nTHE data1 ARGUMENT IS EMPTY AFTER Inf, NA AND 0 REMOVAL IN THE ", freq, ifelse(is.null(annotation), " AND ", ", "), categ, ifelse(is.null(annotation), "", " AND "), " COLUMNS")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ if( ! is.null(fill.color)){
+ if( ! is.numeric(fill.color)){
+ if( ! all(fill.color[ ! is.na(fill.color)] %in% colors() | grepl(pattern = "^#", fill.color[ ! is.na(fill.color)]), na.rm = TRUE)){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nfill.color ARGUMENT MUST BE A VECTOR OF (1) HEXADECIMAL COLOR STRINGS STARTING BY #, OR (2) COLOR NAMES GIVEN BY colors(), OR (3) INTEGER VALUES")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else{
+ fill.color <- as.character(fill.color) # remove class factor is any
+ }
+ }
+ }
+ if( ! is.numeric(border.color)){
+ if( ! (border.color %in% colors() | grepl(pattern = "^#", border.color))){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nfill.color ARGUMENT MUST BE (1) A HEXADECIMAL COLOR STRING STARTING BY #, OR (2) A COLOR NAME GIVEN BY colors(), OR (3) AN INTEGER VALUE")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else{
+ border.color <- as.character(border.color) # remove class factor is any
+ }
+ }
+ # legend name filling
+ if(is.null(legend.name)){
+ legend.name <- categ
+ }
+ # legend.name not NULL anymore
+ # end legend name filling
+ # verif of add
+ if( ! is.null(add)){
+ if( ! grepl(pattern = "^\\s*\\+", add)){ # check that the add string start by +
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nadd ARGUMENT MUST START WITH \"+\": ", paste(unique(add), collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+
+ }else if( ! grepl(pattern = "(ggplot2|lemon)\\s*::", add)){ #
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nFOR EASIER FUNCTION DETECTION, add ARGUMENT MUST CONTAIN \"ggplot2::\" OR \"lemon::\" IN FRONT OF EACH GGPLOT2 FUNCTION: ", paste(unique(add), collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else if( ! grepl(pattern = ")\\s*$", add)){ # check that the add string finished by )
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nadd ARGUMENT MUST FINISH BY \")\": ", paste(unique(add), collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ }
+ # end verif of add
+ # management of add containing facet
+ facet.categ <- NULL
+ if( ! is.null(add)){
+ facet.check <- TRUE
+ tempo <- unlist(strsplit(x = add, split = "\\s*\\+\\s*(ggplot2|lemon)\\s*::\\s*")) #
+ tempo <- sub(x = tempo, pattern = "^facet_wrap", replacement = "ggplot2::facet_wrap")
+ tempo <- sub(x = tempo, pattern = "^facet_grid", replacement = "ggplot2::facet_grid")
+ tempo <- sub(x = tempo, pattern = "^facet_rep", replacement = "lemon::facet_rep")
+
+ if(any(grepl(x = tempo, pattern = "ggplot2::facet_wrap|lemon::facet_rep_wrap"))){
+ tempo1 <- suppressWarnings(eval(parse(text = tempo[grepl(x = tempo, pattern = "ggplot2::facet_wrap|lemon::facet_rep_wrap")])))
+ facet.categ <- list(names(tempo1$params$facets)) # list of length 1
+ tempo.text <- "facet_wrap OR facet_rep_wrap"
+ facet.check <- FALSE
+ }else if(grepl(x = add, pattern = "ggplot2::facet_grid|lemon::facet_rep_grid")){
+ tempo1 <- suppressWarnings(eval(parse(text = tempo[grepl(x = tempo, pattern = "ggplot2::facet_grid|lemon::facet_rep_grid")])))
+ facet.categ <- list(c(names(tempo1$params$rows), names(tempo1$params$cols))) # list of length 1
+ tempo.text <- "facet_grid OR facet_rep_grid"
+ facet.check <- FALSE
+ }
+ if(facet.check == FALSE & ! all(facet.categ %in% names(data1))){ # WARNING: all(facet.categ %in% names(data1)) is TRUE when facet.categ is NULL
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nDETECTION OF \"", tempo.text, "\" STRING IN THE add ARGUMENT BUT PROBLEM OF VARIABLE DETECTION (COLUMN NAMES OF data1)\nTHE DETECTED VARIABLES ARE:\n", paste(facet.categ, collapse = " "), "\nTHE data1 COLUMN NAMES ARE:\n", paste(names(data1), collapse = " "), "\nPLEASE REWRITE THE add STRING AND RERUN")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ }
+ # if facet.categ is not NULL, it is a list of length 1 now
+ # end management of add containing facet
+ 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, "\nDIRECTORY 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", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ }
+ # end other checkings
+ # reserved word checking
+ if( ! (is.null(add))){
+ if(any(sapply(X = arg.names, FUN = grepl, x = add), na.rm = TRUE)){
+ warn.count <- warn.count + 1
+ tempo.warn <- paste0("(", warn.count,") NAMES OF ", function.name, " ARGUMENTS DETECTED IN THE add STRING:\n", paste(arg.names[sapply(X = arg.names, FUN = grepl, x = add)], collapse = "\n"), "\nRISK OF WRONG OBJECT USAGE INSIDE ", function.name)
+ warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ }
+ }
+ # verif of add
+ if( ! is.null(add)){
+ if( ! grepl(pattern = "^\\s*\\+", add)){ # check that the add string start by +
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nadd ARGUMENT MUST START WITH \"+\": ", paste(unique(add), collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else if( ! grepl(pattern = "(ggplot2|lemon)\\s*::", add)){ #
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nFOR EASIER FUNCTION DETECTION, add ARGUMENT MUST CONTAIN \"ggplot2::\" OR \"lemon::\" IN FRONT OF EACH GGPLOT2 FUNCTION: ", paste(unique(add), collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else if( ! grepl(pattern = ")\\s*$", add)){ # check that the add string finished by )
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nadd ARGUMENT MUST FINISH BY \")\": ", paste(unique(add), collapse = " "))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ }
+ # end verif of add
+ # management of add containing facet
+ facet.categ <- NULL
+ if( ! is.null(add)){
+ facet.check <- TRUE
+ tempo <- unlist(strsplit(x = add, split = "\\s*\\+\\s*(ggplot2|lemon)\\s*::\\s*")) #
+ tempo <- sub(x = tempo, pattern = "^facet_wrap", replacement = "ggplot2::facet_wrap")
+ tempo <- sub(x = tempo, pattern = "^facet_grid", replacement = "ggplot2::facet_grid")
+ tempo <- sub(x = tempo, pattern = "^facet_rep", replacement = "lemon::facet_rep")
+ if(any(grepl(x = tempo, pattern = "ggplot2::facet_wrap|lemon::facet_rep_wrap"), na.rm = TRUE)){
+ tempo1 <- suppressWarnings(eval(parse(text = tempo[grepl(x = tempo, pattern = "ggplot2::facet_wrap|lemon::facet_rep_wrap")])))
+ facet.categ <- names(tempo1$params$facets)
+ tempo.text <- "facet_wrap OR facet_rep_wrap"
+ facet.check <- FALSE
+ }else if(grepl(x = add, pattern = "ggplot2::facet_grid|lemon::facet_rep_grid")){
+ tempo1 <- suppressWarnings(eval(parse(text = tempo[grepl(x = tempo, pattern = "ggplot2::facet_grid|lemon::facet_rep_grid")])))
+ facet.categ <- c(names(tempo1$params$rows), names(tempo1$params$cols))
+ tempo.text <- "facet_grid OR facet_rep_grid"
+ facet.check <- FALSE
+ }
+ if(facet.check == FALSE & ! all(facet.categ %in% names(data1))){ # WARNING: all(facet.categ %in% names(data1)) is TRUE when facet.categ is NULL # all() without na.rm -> ok because facet.categ cannot be NA (tested above)
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nDETECTION OF \"", tempo.text, "\" STRING IN THE add ARGUMENT BUT PROBLEM OF VARIABLE DETECTION (COLUMN NAMES OF data1)\nTHE DETECTED VARIABLES ARE:\n", paste(facet.categ, collapse = " "), "\nTHE data1 COLUMN NAMES ARE:\n", paste(names(data1), collapse = " "), "\nPLEASE REWRITE THE add STRING AND RERUN")
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ }
+ # end management of add containing facet
+ # end reserved word checking
+ # end second round of checking and data preparation
+
+ # package checking
+ fun_pack(req.package = c(
+ "gridExtra",
+ "ggplot2",
+ "lemon",
+ "grid",
+ "ggrepel"
+ ), lib.path = lib.path)
+ # end package checking
+
+ # main code
+ data1 <- data.frame(data1, prop = data1[ , freq] / sum(data1[ , freq]))
+ if(legend.add.prop == TRUE){
+ data1[ , categ] <- paste0(data1[ , categ], " (", round(data1$prop, 2), ")")
+ }
+ data1[ , categ] <- factor(data1[ , categ], levels = data1[ , categ][order(data1$prop, decreasing = TRUE)]) # reorder so that the donut is according to decreasing proportion starting at the top in a clockwise direction
+ data1 <- data1[order(as.numeric(data1[ , categ]), decreasing = FALSE), ] # data1[ , categ] with rows in decreasing order, according to prop
+ data1 <- data.frame(data1, x = 0) # staked bar at the origin of the donut set to x = 0
+ tempo.gg.name <- "gg.indiv.plot."
+ tempo.gg.count <- 0
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste0("ggplot2::ggplot()", if(is.null(add)){""}else{add})))) # add added here to have the facets
+ bar_width = 1
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_col(
+ data = data1,
+ mapping = ggplot2::aes_string(x = "x", y = freq, fill = categ),
+ color = border.color,
+ size = border.size,
+ width = bar_width
+ )) # size is size of the separation in the donut
+ # assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_text(
+ # ggplot2::aes(label = Freq),
+ # position = ggplot2::position_stack(vjust = 0.5)
+ # ))
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_x_continuous(
+ expand = c(0, 0), # prevent extra limits in x axis
+ limits = c(- bar_width / 2 - (bar_width * hole.size) / (1 - hole.size), max(bar_width / 2, annotation.distance))
+ )) # must be centered on x = 0
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ylim(c(0, max(cumsum(data1[ , freq])))))
+ if(hole.text == TRUE){
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
+ geom = "text",
+ x = - bar_width / 2 - (bar_width * hole.size) / (1 - hole.size),
+ y = 0,
+ label = sum(data1[ , freq]),
+ size = hole.text.size
+ ))
+ }
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_polar(theta = "y", direction = -1, start = 0, clip = "on"))
+ if(is.null(fill.color) & ! is.null(fill.palette)){
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_fill_brewer(palette = fill.palette, name = legend.name))
+ }else if( ! is.null(fill.color)){
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_fill_manual(values = fill.color, name = legend.name, na.value = "white"))
+ }
+ if(legend.name != ""){
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::labs(fill = legend.name)) # title of the legend
+ }
+
+ if( ! is.null(add)){ # if add is NULL, then = 0
+ if(grepl(pattern = "ggplot2\\s*::\\s*theme", add) == TRUE){
+ warn.count <- warn.count + 1
+ tempo.warn <- paste0("(", warn.count,") \"ggplot2::theme\" STRING DETECTED IN THE add ARGUMENT\n-> INTERNAL GGPLOT2 THEME FUNCTIONS theme_void() HAS BEEN INACTIVATED, SO THAT THE USER THEME CAN BE EFFECTIVE")
+ warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ add.check <- FALSE
+ }else{
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_void())
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme(
+ legend.text = ggplot2::element_text(size = legend.text.size),
+ legend.spacing.y = grid::unit(legend.box.space, 'mm')
+ ))
+ }
+ }else{
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_void())
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme(
+ legend.text = ggplot2::element_text(size = legend.text.size),
+ legend.spacing.y = grid::unit(legend.box.space, 'mm')
+ ))
+ }
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(
+ fill = ggplot2::guide_legend(
+ override.aes = list(color = "white", size = legend.box.size),
+ byrow = TRUE
+ )
+ )) # remove border of squares in legend
+
+ # annotations on slices
+ if( ! is.null(annotation)){
+ tempo <- rev(cumsum(rev(data1[ , freq])))
+ data1 <- data.frame(data1, text_y = tempo - (tempo - c(tempo[-1], 0)) / 2)
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggrepel::geom_text_repel(
+ data = data1,
+ mapping = ggplot2::aes_string(
+ x = "x",
+ y = "text_y",
+ label = annotation
+ ),
+ size = annotation.size,
+ force = annotation.force,
+ force_pull = annotation.force.pull,
+ nudge_x = annotation.distance, # knowing that the bar is centered on x = 0 and that the right edge is at bar_width / 2, 0 means center of the slice, 0.5 means at the edge if bar_width = 1
+ show.legend = FALSE
+ ))
+ }
+ # end annotations on slices
+
+ # legend management
+ # removal of part of the legend
+ if( ! is.null(legend.limit)){
+ if(sum(data1$prop >= legend.limit) == 0){
+ tempo.cat <- paste0("ERROR IN ", function.name, "\nTHE legend.limit PARAMETER VALUE (", legend.limit, ") IS TOO HIGH FOR THE PROPORTIONS IN THE DONUT PLOT:\n", paste0(data1$prop, collapse = "\n"))
+ stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else{
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_fill_discrete(
+ breaks = as.character(data1[ , categ][data1$prop >= legend.limit])
+ ))
+ }
+ }
+ # end removal of part of the legend
+ if(legend.show == FALSE){ # must be here because must be before bef.final.plot
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(fill = "none")) # inactivate the initial legend
+ }
+ bef.final.plot <- suppressWarnings(suppressMessages(ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))))
+ if( ! is.null(legend.width)){
+ legend.plot <- suppressWarnings(suppressMessages(fun_gg_get_legend(ggplot_built = bef.final.plot, fun.name = function.name, lib.path = lib.path))) # get legend
+ assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(fill = "none")) # inactivate the initial legend
+ if(is.null(legend.plot) & plot == TRUE){ # even if any(unlist(legend.disp)) is TRUE
+ legend.plot <- ggplot2::ggplot()+ggplot2::theme_void() # empty graph instead of legend
+ warn.count <- warn.count + 1
+ tempo.warn <- paste0("(", warn.count,") LEGEND REQUESTED (legend.show ARGUMENT SET TO TRUE)\nBUT IT SEEMS THAT THE PLOT HAS NO LEGEND -> EMPTY LEGEND SPACE CREATED BECAUSE OF THE NON NULL legend.width ARGUMENT\n")
+ warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ }
+ }else{
+ legend.plot <- NULL
+ }
+ # end legend management
+
+ # title
+ title.grob <- grid::textGrob(
+ label = title,
+ x = grid::unit(0, "lines"),
+ y = grid::unit(0, "lines"),
+ hjust = 0,
+ vjust = 0,
+ gp = grid::gpar(fontsize = title.text.size)
+ )
+ # end title
+
+ # drawing
+ pdf(NULL)
+ grob.save <- NULL
+ main.plot <- eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))
+ main.plot.output <- suppressMessages(ggplot2::ggplot_build(main.plot))
+ main.grob <- suppressMessages(suppressWarnings(gridExtra::arrangeGrob(
+ main.plot,
+ top = if(title == ""){" "}else{title.grob},
+ left = " ",
+ right = " "
+ ))) # , left = " ", right = " " : trick to add margins in the plot. padding = unit(0.5, "inch") is for top margin above the title
+ if( ! is.null(legend.width)){
+ grob.save <- suppressMessages(suppressWarnings(gridExtra::grid.arrange(main.grob, legend.plot, ncol=2, widths=c(1, legend.width)))) # assemble grobs, ggplot, gtable into a gtable that defines the positions of the different elements (as grobs)
+ }else{
+ grob.save <- suppressMessages(suppressWarnings(print(main.grob)))
+ }
+ dev.off() # inactivate the pdf(NULL) above
+ if(plot == TRUE){
+ gridExtra::grid.arrange(grob.save) # plot a gtable (grob)
+ }else{
+ warn.count <- warn.count + 1
+ tempo.warn <- paste0("(", warn.count,") PLOT NOT SHOWN AS REQUESTED")
+ warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ }
+ # end drawing
+
+ # output
+ if(warn.print == TRUE & ! is.null(warn)){
+ on.exit(warning(paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE))
+ }
+ on.exit(exp = options(warning.length = ini.warning.length), add = TRUE)
+ if(return == TRUE){
+ if(is.null(unlist(removed.row.nb))){
+ removed.row.nb <- NULL
+ removed.rows <- NULL
+ }
+ tempo <- main.plot.output$layout$panel_params[[1]]
+ output <- list(
+ data = data1,
+ removed.row.nb = removed.row.nb,
+ removed.rows = removed.rows,
+ plot.data = main.plot.output$data,
+ panel = facet.categ,
+ axes = list(
+ x.range = tempo$x.range,
+ x.labels = if(is.null(attributes(tempo$x$breaks))){tempo$x$breaks}else{tempo$x$scale$get_labels()}, # is.null(attributes(tempo$x$breaks)) test if it is number (TRUE) or character (FALSE)
+ x.positions = if(is.null(attributes(tempo$x$breaks))){tempo$x$breaks}else{unlist(attributes(tempo$x$breaks))},
+ y.range = tempo$y.range,
+ y.labels = if(is.null(attributes(tempo$y$breaks))){tempo$y$breaks}else{tempo$y$scale$get_labels()},
+ y.positions = if(is.null(attributes(tempo$y$breaks))){tempo$y$breaks}else{unlist(attributes(tempo$y$breaks))}
+ ),
+ warn = paste0("\n", warn, "\n\n"),
+ ggplot = if(return.ggplot == TRUE){main.plot}else{NULL}, # main plot -> plots the graph if return == TRUE
+ gtable = if(return.gtable == TRUE){grob.save}else{NULL} # gtable of the full graph (main + title + legend)
+ )
+ return(output) # this plots the graph if return.ggplot is TRUE and if no assignment
+ }
+ # end output
+ # end main code
+}
+
+
+
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.R b/fun_gg_scatter.R
new file mode 100644
index 0000000000000000000000000000000000000000..5b79fd4c7252b44f982682a2dc9dc6dc8d1c52bb
--- /dev/null
+++ b/fun_gg_scatter.R
@@ -0,0 +1,2367 @@
+# add density
+# rasterise all kind: https://cran.r-project.org/web/packages/ggrastr/vignettes/Raster_geoms.html
+# if list of data frames, add a legend with names of data frames by default
+
+
+fun_gg_scatter <- function(
+data1,
+x,
+y,
+categ = NULL,
+categ.class.order = NULL,
+color = NULL,
+geom = "geom_point",
+geom.step.dir = "hv",
+geom.stick.base = NULL,
+alpha = 0.5,
+dot.size = 2,
+dot.shape = 21,
+dot.border.size = 0.5,
+dot.border.color = NULL,
+line.size = 0.5,
+line.type = "solid",
+x.lim = NULL,
+x.lab = NULL,
+x.log = "no",
+x.tick.nb = NULL,
+x.second.tick.nb = NULL,
+x.include.zero = FALSE,
+x.left.extra.margin = 0.05,
+x.right.extra.margin = 0.05,
+x.text.angle = 0,
+y.lim = NULL,
+y.lab = NULL,
+y.log = "no",
+y.tick.nb = NULL,
+y.second.tick.nb = NULL,
+y.include.zero = FALSE,
+y.top.extra.margin = 0.05,
+y.bottom.extra.margin = 0.05,
+y.text.angle = 0,
+raster = FALSE,
+raster.ratio = 1,
+raster.threshold = NULL,
+text.size = 12,
+title = "",
+title.text.size = 12,
+legend.show = TRUE,
+legend.width = 0.5,
+legend.name = NULL,
+article = TRUE,
+grid = FALSE,
+add = NULL,
+return = FALSE,
+return.ggplot = FALSE,
+return.gtable = TRUE,
+plot = TRUE,
+warn.print = FALSE,
+lib.path = NULL
+){
+# AIM
+# Plot ggplot2 scatterplot with the possibility to overlay dots from up to 3 different data frames (-> three different legends) and lines from up to 3 different data frames (-> three different legends) -> up to 6 overlays totally
+# For ggplot2 specifications, see: https://ggplot2.tidyverse.org/articles/ggplot2-specs.html
+# WARNINGS
+# Rows containing NA in data1[, c(x, y, categ)] will be removed before processing, with a warning (see below)
+# Size arguments (dot.size, dot.border.size, line.size, text.size and title.text.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, or a list of data frames. Order matters for the order of the legend and for the layer staking (starting from below to top)
+# x: single character string of the data1 column name for x-axis coordinates. If data1 is a list, then x must be a list of single character strings, of same size as data1, with compartment 1 related to compartment 1 of data1, etc. Write NULL for each "geom_hline" in geom argument
+# y: single character string of the data1 column name for y-axis coordinates. If data1 is a list, then y must be a list of single character strings, of same size as data1, with compartment 1 related to compartment 1 of data1, etc. Write NULL for each "geom_vline" in geom argument
+# categ: either NULL or a single character string or a list of single character strings, indicating the data1 column names to use for categories which creates legend display
+# If categ == NULL, no categories -> no legend displayed
+# If data1 is a data frame, categ must be a single character string of the data1 column name for categories
+# If data1 is a list, then categ must be a list of single character strings, of same size as data1, with compartment 1 related to compartment 1 of data1, etc. Some of the list compartments can be NULL (no legend display for these compartments), and other not
+# categ.class.order: either (1) NULL or (2) a vector of character strings or (3) a list of these vectors, setting the order of the classes of categ in the legend display
+# If categ.class.order is NULL, classes are represented according to the alphabetical order
+# If data1 is a data frame, categ.class.order must be a vector of character strings specifying the different classes in the categ column name of data1
+# If data1 is a list, then categ.class.order must be a list of vector of character strings, of same size as data1, with compartment 1 related to compartment 1 of data1, etc. Some of the list compartments can be NULL (alphabetical order for these compartments), and other not
+# color: either (1) NULL, or (2) a vector of character strings or integers, or (3) a list of vectors of character strings or integers
+# If color is NULL, default colors of ggplot2
+# If data1 is a data frame, color argument can be either:
+# (1) a single color string. All the dots of the corresponding data1 will have this color, whatever the categ value (NULL or not)
+# (2) if categ is non-null, a vector of string colors, one for each class of categ. Each color will be associated according to the categ.class.order argument if specified, or to the alphabetical order of categ classes otherwise
+# (3) if categ is non-null, a vector or factor of string colors, like if it was one of the column of data1 data frame. WARNING: a single color per class of categ and a single class of categ per color must be respected
+# Positive integers are also accepted instead of character strings, as long as above rules about length are respected. Integers will be processed by fun_gg_palette() using the max integer value among all the integers in color (see fun_gg_palette())
+# If data1 is a list, then color argument must be either:
+# (1) a list of character strings or integers, of same size as data1, with compartment 1 related to compartment 1 of data1, etc.
+# (2) a single character string or a single integer
+# With a list (first possibility), the rules described for when data1 is a data frame apply to each compartment of the list. Some of the compartments can be NULL. In that case, a different grey color will be used for each NULL compartment. With a single value (second possibility), the same color will be used for all the dots and lines, whatever the data1 list
+# geom: single character string of the kind of plot, or a list of single character strings
+# Either:
+# "geom_point" (scatterplot)
+# "geom_line" (coordinates plotted then line connection, from the lowest to highest x coordinates first and from the lowest to highest y coordinates thenafter)
+# "geom_path" (coordinates plotted then line connection respecting the row order in data1)
+# "geom_step" coordinates plotted then line connection respecting the row order in data1 but drawn in steps). See the geom.step.dir argument
+# "geom_hline" (horizontal line, no x value provided)
+# "geom_vline" (vertical line, no y value provided)
+# "geom_stick" (dots as vertical bars)
+# If data1 is a list, then geom must be either:
+# (1) a list of single character strings, of same size as data1, with compartment 1 related to compartment 1 of data1, etc.
+# (2) a single character string. In that case the same kind of plot will apply for the different compartments of the data1 list
+# WARNING concerning "geom_hline" or "geom_vline":
+# (1) x or y argument must be NULL, respectively
+# (2) x.lim or y.lim argument must NOT be NULL, respectively, if only these kind of lines are drawn (if other geom present, then x.lim = NULL and y.lim = NULL will generate x.lim and y.lim defined by these other geom, which is not possible with "geom_hline" or "geom_vline" alone)
+# (3) the function will draw n lines for n values in the x argument column name of the data1 data frame. If several colors required, the categ argument must be specified and the corresponding categ column name must exist in the data1 data frame with a different class name for each row
+# geom.step.dir: single character string indicating the direction when using "geom_step" of the geom argument, or a list of single character strings
+# Either:
+# "vh" (vertical then horizontal)
+# "hv" (horizontal then vertical)
+# "mid" (step half-way between adjacent x-values)
+# See https://ggplot2.tidyverse.org/reference/geom_path.html
+# If data1 is a list, then geom.step.dir must be either:
+# (1) a list of single character strings, of same size as data1, with compartment 1 related to compartment 1 of data1, etc. The value in compartments related to other geom values than "geom_step" will be ignored
+# (2) a single character string, which will be used for all the "geom_step" values of the geom argument, whatever the data1 list
+# geom.stick.base: either (1) NULL or (2) a single numeric value or (3) a list of single numeric values, setting the base of the sticks when using "geom_stick" of the geom argument
+# If geom.stick.base is NULL, the bottom limit of the y-axis is taken as the base
+# If data1 is a list, then geom.stick.base must be either (1) a list of single numeric values, of same size as data1, with compartment 1 related to compartment 1 of data1, etc., or (2) a single numeric value. With a list (former possibility), the values in compartments related to other geom values than "geom_stick" will be ignored. With a single value (latter possibility), the same base will be used for all the sticks, whatever the data1 list
+# Warning: the y-axis limits are not modified by the value of geom.stick.base, meaning that this value can be outside of the range of y.lim. Add the value of geom.stick.base also in the y.lim argument if required
+# Warning: if geom.stick.base is NULL, the bottom limit of the y-axis is taken as the base. Thus, be careful with inverted y-axis
+# alpha: single numeric value (from 0 to 1) of transparency. If data1 is a list, then alpha must be either (1) a list of single numeric values, of same size as data1, with compartment 1 related to compartment 1 of data1, etc., or (2) a single numeric value. In that case the same transparency will apply for the different compartments of the data1 list
+# dot.size: single numeric value of dot shape radius? in mm. If data1 is a list, then dot.size must be either (1) a list of single numeric values, of same size as data1, with compartment 1 related to compartment 1 of data1, etc., or (2) a single numeric value. With a list (former possibility), the value in compartments related to lines will be ignored. With a single value (latter possibility), the same dot.size will be used for all the dots, whatever the data1 list
+# dot.shape: value indicating the shape of the dots (see https://ggplot2.tidyverse.org/articles/ggplot2-specs.html) If data1 is a list, then dot.shape must be either (1) a list of single shape values, of same size as data1, with compartment 1 related to compartment 1 of data1, etc., or (2) a single shape value. With a list (former possibility), the value in compartments related to lines will be ignored. With a single value (latter possibility), the same dot.shape will be used for all the dots, whatever the data1 list
+# dot.border.size: single numeric value of border dot width in mm. Write zero for no dot border. If data1 is a list, then dot.border.size must be either (1) a list of single numeric values, of same size as data1, with compartment 1 related to compartment 1 of data1, etc., or (2) a single numeric value. With a list (former possibility), the value in compartments related to lines will be ignored. With a single value (latter possibility), the same dot.border.size will be used for all the dots, whatever the data1 list
+# dot.border.color: single character color string defining the color of the dot border (same border color for all the dots, whatever their categories). If dot.border.color == NULL, the border color will be the same as the dot color. A single integer is also accepted instead of a character string, that will be processed by fun_gg_palette()
+# line.size: single numeric value of line width in mm. If data1 is a list, then line.size must be either (1) a list of single numeric values, of same size as data1, with compartment 1 related to compartment 1 of data1, etc., or (2) a single numeric value. With a list (former possibility), the value in compartments related to dots will be ignored. With a single value (latter possibility), the same line.size will be used for all the lines, whatever the data1 list
+# line.type: value indicating the kind of lines (see https://ggplot2.tidyverse.org/articles/ggplot2-specs.html) If data1 is a list, then line.type must be either (1) a list of single line kind values, of same size as data1, with compartment 1 related to compartment 1 of data1, etc., or (2) a single line kind value. With a list (former possibility), the value in compartments related to dots will be ignored. With a single value (latter possibility), the same line.type will be used for all the lines, whatever the data1 list
+# x.lim: 2 numeric values setting the x-axis range. Order of the 2 values matters (for inverted axis). If NULL, the range of the x column name of data1 will be used
+# x.lab: a character string or expression for x-axis label. If NULL, will use the first value of x (x column name of the first data frame in data1). Warning message if the elements in x are different between data frames in data1
+# x.log: either "no", "log2" (values in the x column name of the data1 data frame will be log2 transformed and x-axis will be log2 scaled) or "log10" (values in the x column name of the data1 data frame will be log10 transformed and x-axis will be log10 scaled)
+# x.tick.nb: approximate number of desired values labeling the x-axis (i.e., main ticks, see the n argument of the the cute::fun_scale() function). If NULL and if x.log is "no", then the number of labeling values is set by ggplot2. If NULL and if x.log is "log2" or "log10", then the number of labeling values corresponds to all the exposant integers in the x.lim range (e.g., 10^1, 10^2 and 10^3, meaning 3 main ticks for x.lim = c(9, 1200)). WARNING: if non-NULL and if x.log is "log2" or "log10", labeling can be difficult to read (e.g., ..., 10^2, 10^2.5, 10^3, ...)
+# x.second.tick.nb: number of desired secondary ticks between main ticks. Ignored if x.log is other than "no" (log scale plotted). Use argument return = TRUE and see $plot$x.second.tick.values to have the values associated to secondary ticks. IF NULL, no secondary ticks
+# x.include.zero: logical. Does x.lim range include 0? Ignored if x.log is "log2" or "log10"
+# x.left.extra.margin: single proportion (between 0 and 1) indicating if extra margins must be added to x.lim. If different from 0, add the range of the axis multiplied by x.left.extra.margin (e.g., abs(x.lim[2] - x.lim[1]) * x.left.extra.margin) to the left of x-axis
+# x.right.extra.margin: idem as x.left.extra.margin but to the right of x-axis
+# x.text.angle: integer value of the text angle for the x-axis labeling values, using the same rules as in ggplot2. Use positive value for clockwise rotation: 0 for horizontal, 90 for vertical, 180 for upside down etc. Use negative values for counterclockwise rotation: 0 for horizontal, -90 for vertical, -180 for upside down etc.
+# y.lim: 2 numeric values setting the y-axis range. Order of the 2 values matters (for inverted axis). If NULL, the range of the y column name of data1 will be used
+# y.lab: a character string or expression for y-axis label. If NULL, will use the first value of y (y column name of the first data frame in data1). Warning message if the elements in y are different between data frames in data1
+# y.log: either "no", "log2" (values in the y column name of the data1 data frame will be log2 transformed and y-axis will be log2 scaled) or "log10" (values in the y column name of the data1 data frame will be log10 transformed and y-axis will be log10 scaled)
+# y.tick.nb: approximate number of desired values labeling the y-axis (i.e., main ticks, see the n argument of the the cute::fun_scale() function). If NULL and if y.log is "no", then the number of labeling values is set by ggplot2. If NULL and if y.log is "log2" or "log10", then the number of labeling values corresponds to all the exposant integers in the y.lim range (e.g., 10^1, 10^2 and 10^3, meaning 3 main ticks for y.lim = c(9, 1200)). WARNING: if non-NULL and if y.log is "log2" or "log10", labeling can be difficult to read (e.g., ..., 10^2, 10^2.5, 10^3, ...)
+# y.second.tick.nb: number of desired secondary ticks between main ticks. Ignored if y.log is other than "no" (log scale plotted). Use argument return = TRUE and see $plot$y.second.tick.values to have the values associated to secondary ticks. IF NULL, no secondary ticks
+# y.include.zero: logical. Does y.lim range include 0? Ignored if y.log is "log2" or "log10"
+# y.top.extra.margin: single proportion (between 0 and 1) indicating if extra margins must be added to y.lim. If different from 0, add the range of the axis multiplied by y.top.extra.margin (e.g., abs(y.lim[2] - y.lim[1]) * y.top.extra.margin) to the top of y-axis
+# y.bottom.extra.margin: idem as y.top.extra.margin but to the bottom of y-axis
+# y.text.angle: integer value of the text angle for the y-axis labeling values, using the same rules as in ggplot2. Use positive value for clockwise rotation: 0 for horizontal, 90 for vertical, 180 for upside down etc. Use negative values for counterclockwise rotation: 0 for horizontal, -90 for vertical, -180 for upside down etc.
+# raster: logical. Dots in raster mode? If FALSE, dots from each "geom_point" from geom argument are plotted in vectorial mode (bigger pdf and long to display if lots of dots). If TRUE, dots from each "geom_point" from geom argument are plotted in matricial mode (smaller pdf and easy display if lots of dots, but it takes time to generate the layer). If TRUE, the raster.ratio argument is used to avoid an ellipsoid representation of the dots. If TRUE, solve the transparency problem with some GUI. Overriden by the non-NULL raster.threshold argument
+# raster.ratio: single numeric value indicating the height / width ratio of the graphic device used (for instance provided by the $dim compartment in the output of the fun_open() function). The default value is 1 because by default R opens a square graphic device. But this argument has to be set when using other device dimensions. Ignored if raster == FALSE
+# raster.threshold: positive integer value indicating the limit of the dot number above which "geom_point" layers from the geom argument switch from vectorial mode to matricial mode (see the raster argument). If any layer is matricial, then the raster.ratio argument is used to avoid an ellipsoid representation of the dots. If non-NULL, it overrides the raster argument
+# text.size: numeric value of the font size of the (1) axis numbers and axis legends and (2) texts in the graphic legend (in mm)
+# title: character string of the graph title
+# title.text.size: numeric value of the title font size in mm
+# legend.show: logical. Show legend? Not considered if categ argument is NULL, because this already generate no legend, excepted if legend.width argument is non-NULL. In that specific case (categ is NULL, legend.show is TRUE and legend.width is non-NULL), an empty legend space is created. This can be useful when desiring graphs of exactly the same width, whatever they have legends or not
+# 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 and categ argument is not NULL, then legend.name <- categ. If data1 is a list, then legend.name must be a list of character strings, of same size as data1, with compartment 1 related to compartment 1 of data1, etc. Some of the list compartments can be NULL, and other not
+# article: logical. If TRUE, use an article theme (article like). If FALSE, use a classic related ggplot theme. Use the add argument (e.g., add = "+ggplot2::theme_classic()" for the exact classic ggplot theme
+# grid: logical. Draw lines in the background to better read the box values? Not considered if article == FALSE (grid systematically present)
+# 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_scatter() (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_scatter() 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. Return the graph parameters?
+# return.ggplot: logical. Return the ggplot object in the output list? Ignored if return argument is FALSE. WARNING: always assign the fun_gg_scatter() function (e.g., a <- fun_gg_scatter()) if return.ggplot argument is TRUE, otherwise, double plotting is performed. See $ggplot in the RETURN section below for more details
+# return.gtable: logical. Return the ggplot object as gtable of grobs in the output list? Ignored if plot argument is FALSE. Indeed, the graph must be plotted to get the grobs dispositions. See $gtable in the RETURN section below for more details
+# plot: logical. Plot the graphic? If FALSE and return argument is TRUE, graphical parameters and associated warnings are provided without plotting
+# warn.print: logical. 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: character string indicating the absolute path of the required packages (see below). if NULL, the function will use the R library default folders
+# RETURN
+# a scatter plot if plot argument is TRUE
+# a list of the graph info if return argument is TRUE:
+# $data: the initial data with graphic information added. WARNING: if the x.log or y.log argument is not "no", x or y argument column of the data1 data frame are log2 or log10 converted in $data, respectively. Use 2^values or 10^$values to recover the initial values
+# $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: the graphic box and dot coordinates
+# $dots: dot coordinates
+# y.second.tick.positions: coordinates of secondary ticks (only if y.second.tick.nb argument is non-null or if y.log argument is different from "no")
+# y.second.tick.values: values of secondary ticks. NULL except if y.second.tick.nb argument is non-null or if y.log argument is different from "no")
+# $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. 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). NULL if return.ggplot argument is FALSE. 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
+# lemon (in case of use in the add argument)
+# scales
+# if raster plots are drawn (see the raster and raster.threshold arguments):
+# Cairo
+# grid
+# REQUIRED FUNCTIONS FROM THE cute PACKAGE
+# fun_gg_empty_graph()
+# fun_gg_palette()
+# fun_gg_point_rast()
+# fun_pack()
+# fun_check()
+# fun_round()
+# fun_scale()
+# fun_inter_ticks()
+# EXAMPLES
+# set.seed(1) ; obs1 <- data.frame(Km = c(2, 1, 6, 5, 4, 7), Time = c(2, 1, 6, 5, 4, 7)^2, Car = c("TUUT", "TUUT", "TUUT", "WIIM", "WIIM", "WIIM"), Color1 = rep(c("coral", "lightblue"), each = 3), stringsAsFactors = TRUE) ; fun_gg_scatter(data1 = obs1, x = "Km", y = "Time")
+# DEBUGGING
+# set.seed(1) ; obs1 <- data.frame(km = rnorm(1000, 10, 3), time = rnorm(1000, 10, 3), group1 = rep(c("A1", "A2"), 500), stringsAsFactors = TRUE) ; obs2 <-data.frame(km = rnorm(1000, 15, 3), time = rnorm(1000, 15, 3), group2 = rep(c("G1", "G2"), 500), stringsAsFactors = TRUE) ; set.seed(NULL) ; obs1$km[2:3] <- NA ; data1 = list(L1 = obs1, L2 = obs2) ; x = list(L1 = "km", L2 = "km") ; y = list(L1 = "time", L2 = "time") ; categ = list(L1 = "group1", L2 = "group2") ; categ = NULL ; categ.class.order = NULL ; color = NULL ; geom = "geom_point" ; geom.step.dir = "hv" ; geom.stick.base = NULL ; alpha = 0.5 ; dot.size = 2 ; dot.shape = 21 ; dot.border.size = 0.5 ; dot.border.color = NULL ; line.size = 0.5 ; line.type = "solid" ; x.lim = NULL ; x.lab = NULL ; x.log = "no" ; x.tick.nb = NULL ; x.second.tick.nb = NULL ; x.include.zero = FALSE ; x.left.extra.margin = 0.05 ; x.right.extra.margin = 0.05 ; x.text.angle = 0 ; y.lim = NULL ; y.lab = NULL ; y.log = "no" ; y.tick.nb = NULL ; y.second.tick.nb = NULL ; y.include.zero = FALSE ; y.top.extra.margin = 0.05 ; y.bottom.extra.margin = 0.05 ; y.text.angle = 0 ; raster = FALSE ; raster.ratio = 1 ; raster.threshold = NULL ; text.size = 12 ; title = "" ; title.text.size = 12 ; legend.show = TRUE ; legend.width = 0.5 ; legend.name = NULL ; article = TRUE ; grid = FALSE ; add = NULL ; return = FALSE ; 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_gg_just",
+"fun_gg_empty_graph",
+"fun_gg_palette",
+"fun_gg_point_rast",
+"fun_round",
+"fun_pack",
+"fun_scale",
+"fun_inter_ticks"
+)
+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 to avoid bugs (used in this function)
+reserved.words <- c("fake_x", "fake_y", "fake_categ")
+# end reserved words to avoid bugs (used in this function)
+# arg with no default values
+mandat.args <- c(
+"data1",
+"x",
+"y"
+)
+tempo <- eval(parse(text = paste0("missing(", paste0(mandat.args, collapse = ") | missing("), ")")))
+if(any(tempo)){
+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 #
+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))
+tempo1 <- fun_check(data = data1, class = "data.frame", na.contain = TRUE, fun.name = function.name)
+tempo2 <- fun_check(data = data1, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": data1 ARGUMENT MUST BE A DATA FRAME OR A LIST OF DATA FRAMES")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+if( ! is.null(x)){
+tempo1 <- fun_check(data = x, class = "vector", mode = "character", na.contain = TRUE, length = 1, fun.name = function.name)
+tempo2 <- fun_check(data = x, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": x ARGUMENT MUST BE A SINGLE CHARACTER STRING OR A LIST OF CHARACTER STRINGS")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = x, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+if( ! is.null(y)){
+tempo1 <- fun_check(data = y, class = "vector", mode = "character", na.contain = TRUE, length = 1, fun.name = function.name)
+tempo2 <- fun_check(data = y, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": y ARGUMENT MUST BE A SINGLE CHARACTER STRING OR A LIST OF CHARACTER STRINGS")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = y, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+if( ! is.null(categ)){
+tempo1 <- fun_check(data = categ, class = "vector", mode = "character", length = 1, fun.name = function.name)
+tempo2 <- fun_check(data = categ, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": categ ARGUMENT MUST BE A SINGLE CHARACTER STRING OR A LIST OF CHARACTER STRINGS")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = categ, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+if( ! is.null(categ.class.order)){
+if(is.null(categ)){
+tempo.cat <- paste0("ERROR IN ", function.name, ": categ.class.order ARGUMENT IS NOT NULL, BUT categ IS")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+tempo1 <- fun_check(data = categ.class.order, class = "vector", mode = "character", fun.name = function.name)
+tempo2 <- fun_check(data = categ.class.order, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": categ.class.order ARGUMENT MUST BE A VECTOR OF CHARACTER STRINGS OR A LIST OF VECTOR OF CHARACTER STRINGS")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = categ.class.order, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+if( ! is.null(legend.name)){
+tempo1 <- fun_check(data = legend.name, class = "vector", mode = "character", na.contain = TRUE, length = 1, fun.name = function.name)
+tempo2 <- fun_check(data = legend.name, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": legend.name ARGUMENT MUST BE A SINGLE CHARACTER STRING OR A LIST OF CHARACTER STRINGS")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = legend.name, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+if( ! is.null(color)){
+tempo1 <- fun_check(data = color, class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name)
+tempo2 <- fun_check(data = color, class = "factor", na.contain = TRUE, fun.name = function.name)
+tempo3 <- fun_check(data = color, class = "integer", double.as.integer.allowed = TRUE, na.contain = TRUE, fun.name = function.name)
+tempo4 <- fun_check(data = color, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo4$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE & tempo3$problem == TRUE & tempo4$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": color ARGUMENT MUST BE A VECTOR (OF CHARACTER STRINGS OR INTEGERS) OR A FACTOR OR A LIST OF THESE POSSIBILITIES")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = color, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+tempo1 <- fun_check(data = geom, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name)
+tempo2 <- fun_check(data = geom, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": geom ARGUMENT MUST BE A SINGLE CHARACTER STRING OR A LIST OF CHARACTER STRINGS")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+tempo1 <- fun_check(data = geom.step.dir, options = c("vh", "hv", "mid"), na.contain = FALSE, length = 1, fun.name = function.name)
+tempo2 <- fun_check(data = geom.step.dir, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": geom.step.dir ARGUMENT MUST BE A SINGLE CHARACTER STRING (\"vh\" OR \"hv\" OR \"mid\") OR A LIST OF THESE CHARACTER STRINGS")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+if( ! is.null(geom.stick.base)){
+tempo1 <- fun_check(data = geom.stick.base, class = "vector", mode = "numeric", na.contain = FALSE, length = 1, fun.name = function.name)
+tempo2 <- fun_check(data = color, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": geom.stick.base ARGUMENT MUST BE A SINGLE NUMERIC VALUE OR A LIST OF SINGLE NUMERIC VALUES")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = geom.stick.base, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+tempo1 <- fun_check(data = alpha, prop = TRUE, length = 1, fun.name = function.name)
+tempo2 <- fun_check(data = alpha, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": alpha ARGUMENT MUST BE A SINGLE NUMERIC VALUE BETWEEN 0 AND 1 OR A LIST OF SUCH VALUES")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+tempo1 <- fun_check(data = dot.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name)
+tempo2 <- fun_check(data = dot.size, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": dot.size ARGUMENT MUST BE A SINGLE NUMERIC VALUE OR A LIST OF SINGLE NUMERIC VALUES")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+tempo1 <- fun_check(data = dot.shape, class = "vector", length = 1, fun.name = function.name)
+tempo2 <- fun_check(data = dot.shape, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": dot.shape ARGUMENT MUST BE A SINGLE SHAPE VALUE OR A LIST OF SINGLE SHAPE VALUES (SEE https://ggplot2.tidyverse.org/articles/ggplot2-specs.html)")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+tempo1 <- fun_check(data = dot.border.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name)
+tempo2 <- fun_check(data = dot.border.size, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": dot.border.size ARGUMENT MUST BE A SINGLE NUMERIC VALUE OR A LIST OF SINGLE NUMERIC VALUES")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+if( ! is.null(dot.border.color)){
+tempo1 <- fun_check(data = dot.border.color, class = "vector", mode = "character", length = 1, fun.name = function.name)
+tempo2 <- fun_check(data = dot.border.color, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, length = 1, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+# integer colors -> gg_palette
+tempo.cat <- paste0("ERROR IN ", function.name, ": dot.border.color MUST BE A SINGLE CHARACTER STRING OF COLOR OR A SINGLE INTEGER VALUE")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = dot.border.color, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+tempo1 <- fun_check(data = line.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name)
+tempo2 <- fun_check(data = line.size, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo2$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": line.size ARGUMENT MUST BE A SINGLE NUMERIC VALUE OR A LIST OF SINGLE NUMERIC VALUES")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+tempo1 <- fun_check(data = line.type, class = "vector", typeof = "integer", double.as.integer.allowed = FALSE, length = 1, fun.name = function.name)
+tempo2 <- fun_check(data = line.type, class = "vector", mode = "character", length = 1, fun.name = function.name)
+tempo3 <- fun_check(data = line.type, class = "list", na.contain = TRUE, fun.name = function.name)
+checked.arg.names <- c(checked.arg.names, tempo3$object.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE & tempo3$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": line.type ARGUMENT MUST BE A SINGLE LINE KIND VALUE OR A LIST OF SINGLE LINE KIND VALUES (SEE https://ggplot2.tidyverse.org/articles/ggplot2-specs.html)")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+if( ! is.null(x.lim)){
+tempo <- fun_check(data = x.lim, class = "vector", mode = "numeric", length = 2, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & any(x.lim %in% c(Inf, -Inf))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": x.lim ARGUMENT CANNOT CONTAIN -Inf OR Inf VALUES")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = x.lim, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+if( ! is.null(x.lab)){
+if(all(class(x.lab) %in% "expression")){ # to deal with math symbols
+tempo <- fun_check(data = x.lab, class = "expression", length = 1, fun.name = function.name) ; eval(ee)
+}else{
+tempo <- fun_check(data = x.lab, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = x.lab, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+tempo <- fun_check(data = x.log, options = c("no", "log2", "log10"), length = 1, fun.name = function.name) ; eval(ee)
+if( ! is.null(x.tick.nb)){
+tempo <- fun_check(data = x.tick.nb, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & x.tick.nb < 0){
+tempo.cat <- paste0("ERROR IN ", function.name, ": x.tick.nb ARGUMENT MUST BE A NON-NULL POSITIVE INTEGER")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = x.tick.nb, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+if( ! is.null(x.second.tick.nb)){
+tempo <- fun_check(data = x.second.tick.nb, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & x.second.tick.nb <= 0){
+tempo.cat <- paste0("ERROR IN ", function.name, ": x.second.tick.nb ARGUMENT MUST BE A NON-NULL POSITIVE INTEGER")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = x.second.tick.nb, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+tempo <- fun_check(data = x.include.zero, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = x.left.extra.margin, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = x.right.extra.margin, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = x.text.angle, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, length = 1, neg.values = TRUE, fun.name = function.name) ; eval(ee)
+if( ! is.null(y.lim)){
+tempo <- fun_check(data = y.lim, class = "vector", mode = "numeric", length = 2, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & any(y.lim %in% c(Inf, -Inf))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": y.lim ARGUMENT CANNOT CONTAIN -Inf OR Inf VALUES")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = y.lim, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+if( ! is.null(y.lab)){
+if(all(class(y.lab) %in% "expression")){ # to deal with math symbols
+tempo <- fun_check(data = y.lab, class = "expression", length = 1, fun.name = function.name) ; eval(ee)
+}else{
+tempo <- fun_check(data = y.lab, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = y.lab, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+tempo <- fun_check(data = y.log, options = c("no", "log2", "log10"), length = 1, fun.name = function.name) ; eval(ee)
+if( ! is.null(y.tick.nb)){
+tempo <- fun_check(data = y.tick.nb, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & y.tick.nb < 0){
+tempo.cat <- paste0("ERROR IN ", function.name, ": y.tick.nb ARGUMENT MUST BE A NON-NULL POSITIVE INTEGER")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = y.tick.nb, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+if( ! is.null(y.second.tick.nb)){
+tempo <- fun_check(data = y.second.tick.nb, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee)
+if(tempo$problem == FALSE & y.second.tick.nb <= 0){
+tempo.cat <- paste0("ERROR IN ", function.name, ": y.second.tick.nb ARGUMENT MUST BE A NON-NULL POSITIVE INTEGER")
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = y.second.tick.nb, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+tempo <- fun_check(data = y.include.zero, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = y.top.extra.margin, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = y.bottom.extra.margin, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = y.text.angle, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, length = 1, neg.values = TRUE, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = raster, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = raster.ratio, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
+if( ! is.null(raster.threshold)){
+tempo <- fun_check(data = raster.threshold, class = "vector", typeof = "integer", neg.values = FALSE, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee)
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = raster.threshold, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+tempo <- fun_check(data = text.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = title, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = title.text.size, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = legend.show, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+if( ! is.null(legend.width)){
+tempo <- fun_check(data = legend.width, prop = TRUE, length = 1, fun.name = function.name) ; eval(ee)
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = legend.width, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+tempo <- fun_check(data = article, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = grid, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+if( ! is.null(add)){
+tempo <- fun_check(data = add, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = add, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+tempo <- fun_check(data = return, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = return.ggplot, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = return.gtable, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = plot, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
+tempo <- fun_check(data = warn.print, class = "logical", length = 1, 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)
+if(tempo$problem == FALSE){
+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"))
+text.check <- c(text.check, tempo.cat)
+arg.check <- c(arg.check, TRUE)
+}
+}
+}else{
+# no fun_check test here, it is just for checked.arg.names
+tempo <- fun_check(data = lib.path, class = "vector")
+checked.arg.names <- c(checked.arg.names, tempo$object.name)
+}
+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) #
+}
+}
+# source("C:/Users/Gael/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(
+"data1",
+# "x", # inactivated because of hline or vline
+# "y", # inactivated because of hline or vline
+"geom",
+"geom.step.dir",
+# "geom.stick.base", # inactivated because can be null
+"alpha",
+"dot.size",
+"dot.shape",
+"dot.border.size",
+"line.size",
+"line.type",
+"x.log",
+"x.include.zero",
+"x.left.extra.margin",
+"x.right.extra.margin",
+"x.text.angle",
+"y.log",
+"y.include.zero",
+"y.top.extra.margin",
+"y.bottom.extra.margin",
+"y.text.angle",
+"raster",
+"raster.ratio",
+"text.size",
+"title",
+"title.text.size",
+"legend.show",
+# "legend.width", # inactivated because can be null
+"article",
+"grid",
+"return",
+"return.ggplot",
+"return.gtable",
+"plot",
+"warn.print"
+)
+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\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
+ini.warning.length <- options()$warning.length
+options(warning.length = 8170)
+warn <- NULL
+warn.count <- 0
+# end warning initiation
+# other checkings
+# check list lengths (and names of data1 compartments if present)
+list.color <- NULL
+list.geom <- NULL
+list.geom.step.dir <- NULL
+list.geom.stick.base <- NULL
+list.alpha <- NULL
+list.dot.size <- NULL
+list.dot.shape <- NULL
+list.dot.border.size <- NULL
+list.dot.border.color <- NULL
+list.line.size <- NULL
+list.line.type <- NULL
+if(all(class(data1) == "list")){
+if(length(data1) > 6){
+tempo.cat <- paste0("ERROR IN ", function.name, ": data1 ARGUMENT MUST BE A LIST OF 6 DATA FRAMES MAXIMUM (6 OVERLAYS MAX)")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+if(is.null(names(data1))){
+names(data1) <- paste0("L", 1:length(data1))
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") NULL NAME COMPARTMENT OF data1 LIST -> NAMES RESPECTIVELY ATTRIBUTED TO EACH COMPARTMENT:\n", paste(names(data1), collapse = " "))
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+if( ! is.null(x)){
+if( ! (all(class(x) == "list") & length(data1) == length(x))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": x ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}else{
+x <- vector("list", length(data1))
+}
+if( ! is.null(y)){
+if( ! (all(class(y) == "list") & length(data1) == length(y))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": y ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}else{
+y <- vector("list", length(data1))
+}
+if( ! is.null(categ)){
+if( ! (all(class(categ) == "list") & length(data1) == length(categ))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": categ ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+if( ! is.null(categ.class.order)){
+if( ! (all(class(categ.class.order) == "list") & length(data1) == length(categ.class.order))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": categ.class.order ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+if( ! is.null(color)){
+if( ! ((all(class(color) == "list") & length(data1) == length(color)) | ((all(mode(color) == "character") | all(mode(color) == "numeric")) & length(color)== 1L))){ # list of same length as data1 or single value
+tempo.cat <- paste0("ERROR IN ", function.name, ": color ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST, OR A SINGLE CHARACTER STRING OR INTEGER")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if((all(mode(color) == "character") | all(mode(color) == "numeric")) & length(color)== 1L){ # convert the single value into a list of single value
+list.color <- vector(mode = "list", length = length(data1))
+list.color[] <- color
+}
+}
+if( ! ((all(class(geom) == "list") & length(data1) == length(geom)) | (all(mode(geom) == "character") & length(geom)== 1L))){ # list of same length as data1 or single value
+tempo.cat <- paste0("ERROR IN ", function.name, ": geom ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST, OR A SINGLE CHARACTER VALUE")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(all(mode(geom) == "character") & length(geom)== 1L){ # convert the single value into a list of single value
+list.geom <- vector(mode = "list", length = length(data1))
+list.geom[] <- geom
+}
+if( ! ((all(class(geom.step.dir) == "list") & length(data1) == length(geom.step.dir)) | (all(mode(geom.step.dir) == "character") & length(geom.step.dir)== 1L))){ # list of same length as data1 or single value
+tempo.cat <- paste0("ERROR IN ", function.name, ": geom.step.dir ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST, OR A SINGLE CHARACTER VALUE")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(all(mode(geom.step.dir) == "character") & length(geom.step.dir)== 1L){ # convert the single value into a list of single value
+list.geom.step.dir <- vector(mode = "list", length = length(data1))
+list.geom.step.dir[] <- geom.step.dir
+}
+if( ! is.null(geom.stick.base)){
+if( ! ((all(class(geom.stick.base) == "list") & length(data1) == length(geom.stick.base)) | (all(mode(geom.stick.base) == "numeric") & length(geom.stick.base)== 1L))){ # list of same length as data1 or single value
+tempo.cat <- paste0("ERROR IN ", function.name, ": geom.stick.base ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST, OR A SINGLE NUMERIC VALUE")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(all(mode(geom.stick.base) == "numeric") & length(geom.stick.base)== 1L){ # convert the single value into a list of single value
+list.geom.stick.base <- vector(mode = "list", length = length(data1))
+list.geom.stick.base[] <- geom.stick.base
+}
+}
+if( ! ((all(class(alpha) == "list") & length(data1) == length(alpha)) | (all(mode(alpha) == "numeric") & length(alpha)== 1L))){ # list of same length as data1 or single value
+tempo.cat <- paste0("ERROR IN ", function.name, ": alpha ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST, OR A SINGLE NUMERIC VALUE")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(all(mode(alpha) == "numeric") & length(alpha)== 1L){ # convert the single value into a list of single value
+list.alpha <- vector(mode = "list", length = length(data1))
+list.alpha[] <- alpha
+}
+if( ! ((all(class(dot.size) == "list") & length(data1) == length(dot.size)) | (all(mode(dot.size) == "numeric") & length(dot.size)== 1L))){ # list of same length as data1 or single value
+tempo.cat <- paste0("ERROR IN ", function.name, ": dot.size ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST, OR A SINGLE NUMERIC VALUE")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(all(mode(dot.size) == "numeric") & length(dot.size)== 1L){ # convert the single value into a list of single value
+list.dot.size <- vector(mode = "list", length = length(data1))
+list.dot.size[] <- dot.size
+}
+if( ! ((all(class(dot.shape) == "list") & length(data1) == length(dot.shape)) | (all(mode(dot.shape) != "list") & length(dot.shape)== 1L))){ # list of same length as data1 or single value
+tempo.cat <- paste0("ERROR IN ", function.name, ": dot.shape ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST, OR A SINGLE SHAPE VALUE")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(all(mode(dot.shape) != "list") & length(dot.shape)== 1L){ # convert the single value into a list of single value
+list.dot.shape <- vector(mode = "list", length = length(data1))
+list.dot.shape[] <- dot.shape
+}
+if( ! ((all(class(dot.border.size) == "list") & length(data1) == length(dot.border.size)) | (all(mode(dot.border.size) == "numeric") & length(dot.border.size)== 1L))){ # list of same length as data1 or single value
+tempo.cat <- paste0("ERROR IN ", function.name, ": dot.border.size ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST, OR A SINGLE NUMERIC VALUE")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(all(mode(dot.border.size) == "numeric") & length(dot.border.size)== 1L){ # convert the single value into a list of single value
+list.dot.border.size <- vector(mode = "list", length = length(data1))
+list.dot.border.size[] <- dot.border.size
+}
+if( ! is.null(dot.border.color)){
+if( ! ((all(class(dot.border.color) == "list") & length(data1) == length(dot.border.color)) | ((all(mode(dot.border.color) == "character") | all(mode(dot.border.color) == "numeric")) & length(dot.border.color)== 1L))){ # list of same length as data1 or single value
+tempo.cat <- paste0("ERROR IN ", function.name, ": dot.border.color ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST, OR A SINGLE CHARACTER STRING OR INTEGER")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if((all(mode(dot.border.color) == "character") | all(mode(dot.border.color) == "numeric")) & length(dot.border.color)== 1L){ # convert the single value into a list of single value
+list.dot.border.color <- vector(mode = "list", length = length(data1))
+list.dot.border.color[] <- dot.border.color
+}
+}
+if( ! ((all(class(line.size) == "list") & length(data1) == length(line.size)) | (all(mode(line.size) == "numeric") & length(line.size)== 1L))){ # list of same length as data1 or single value
+tempo.cat <- paste0("ERROR IN ", function.name, ": line.size ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST, OR A SINGLE NUMERIC VALUE")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(all(mode(line.size) == "numeric") & length(line.size)== 1L){ # convert the single value into a list of single value
+list.line.size <- vector(mode = "list", length = length(data1))
+list.line.size[] <- line.size
+}
+if( ! ((all(class(line.type) == "list") & length(data1) == length(line.type)) | (all(mode(line.type) != "list") & length(line.type)== 1L))){ # list of same length as data1 or single value
+tempo.cat <- paste0("ERROR IN ", function.name, ": line.type ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST, OR A SINGLE LINE KIND VALUE")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(all(mode(line.type) != "list") & length(line.type)== 1L){ # convert the single value into a list of single value
+list.line.type <- vector(mode = "list", length = length(data1))
+list.line.type[] <- line.type
+}
+if( ! is.null(legend.name)){
+if( ! (all(class(legend.name) == "list") & length(data1) == length(legend.name))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": legend.name ARGUMENT MUST BE A LIST OF SAME LENGTH AS data1 IF data1 IS A LIST")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+}
+# end check list lengths (and names of data1 compartments if present)
+# conversion into lists
+if(all(is.data.frame(data1))){
+data1 <- list(L1 = data1)
+if(all(class(x) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": x ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+x <- list(L1 = x)
+}
+if(all(class(y) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": y ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+y <- list(L1 = y)
+}
+if( ! is.null(categ)){
+if(all(class(categ) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": categ ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+categ <- list(L1 = categ)
+}
+}
+if( ! is.null(categ.class.order)){
+if(all(class(categ.class.order) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": categ.class.order ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+categ.class.order <- list(L1 = categ.class.order)
+}
+}
+if( ! is.null(color)){
+if(all(class(color) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": color ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+color <- list(L1 = color)
+}
+}
+if(all(class(geom) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": geom ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+geom <- list(L1 = geom)
+}
+if(all(class(geom.step.dir) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": geom.step.dir ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+geom.step.dir <- list(L1 = geom.step.dir)
+}
+if( ! is.null(geom.stick.base)){
+if(all(class(geom.stick.base) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": geom.stick.base ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+geom.stick.base <- list(L1 = geom.stick.base)
+}
+}
+if(all(class(alpha) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": alpha ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+alpha <- list(L1 = alpha)
+}
+if(all(class(dot.size) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": dot.size ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+dot.size <- list(L1 = dot.size)
+}
+if(all(class(dot.shape) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": dot.shape ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+dot.shape <- list(L1 = dot.shape)
+}
+if(all(class(dot.border.size) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": dot.border.size ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+dot.border.size <- list(L1 = dot.border.size)
+}
+if( ! is.null(dot.border.color)){
+if(all(class(dot.border.color) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": dot.border.color ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+dot.border.color <- list(L1 = dot.border.color)
+}
+}
+if(all(class(line.size) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": line.size ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+line.size <- list(L1 = line.size)
+}
+if(all(class(line.type) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": line.type ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+line.type <- list(L1 = line.type)
+}
+if( ! is.null(legend.name)){
+if(all(class(legend.name) == "list")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": legend.name ARGUMENT CANNOT BE A LIST IF data1 IS A DATA FRAME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+legend.name <- list(L1 = legend.name)
+}
+}
+}else if( ! all(sapply(data1, FUN = "class") == "data.frame")){ # if not a data frame, data1 can only be a list, as tested above
+tempo.cat <- paste0("ERROR IN ", function.name, ": data1 ARGUMENT MUST BE A DATA FRAME OR A LIST OF DATA FRAMES")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+# single value converted into list now reattributed to the argument name
+if( ! is.null(color)){
+if( ! is.null(list.color)){
+color <- list.color
+}
+}
+if( ! is.null(list.geom)){
+geom <- list.geom
+}
+if( ! is.null(list.geom.step.dir)){
+geom.step.dir <- list.geom.step.dir
+}
+if( ! is.null(geom.stick.base)){
+if( ! is.null(list.geom.stick.base)){
+geom.stick.base <- list.geom.stick.base
+}
+}
+if( ! is.null(list.alpha)){
+alpha <- list.alpha
+}
+if( ! is.null(list.dot.size)){
+dot.size <- list.dot.size
+}
+if( ! is.null(list.dot.shape)){
+dot.shape <- list.dot.shape
+}
+if( ! is.null(list.dot.border.size)){
+dot.border.size <- list.dot.border.size
+}
+if( ! is.null(dot.border.color)){
+if( ! is.null(list.dot.border.color)){
+dot.border.color <- list.dot.border.color
+}
+}
+if( ! is.null(list.line.size)){
+line.size <- list.line.size
+}
+if( ! is.null(list.line.type)){
+line.type <- list.line.type
+}
+# end single value converted into list now reattributed to the argument name
+# data, x, y, geom, alpha, dot.size, shape, dot.border.size, line.size, line.type, legend.name are list now
+# if non-null, categ, categ.class.order, legend.name, color, dot.border.color are list now
+# end conversion into lists
+# verif of add
+if( ! is.null(add)){
+if( ! grepl(pattern = "^\\s*\\+", add)){ # check that the add string start by +
+tempo.cat <- paste0("ERROR IN ", function.name, ": add ARGUMENT MUST START WITH \"+\": ", paste(unique(add), collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+
+}else if( ! grepl(pattern = "(ggplot2|lemon)\\s*::", add)){ #
+tempo.cat <- paste0("ERROR IN ", function.name, ": FOR EASIER FUNCTION DETECTION, add ARGUMENT MUST CONTAIN \"ggplot2::\" OR \"lemon::\" IN FRONT OF EACH GGPLOT2 FUNCTION: ", paste(unique(add), collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if( ! grepl(pattern = ")\\s*$", add)){ # check that the add string finished by )
+tempo.cat <- paste0("ERROR IN ", function.name, ": add ARGUMENT MUST FINISH BY \")\": ", paste(unique(add), collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+# end verif of add
+# management of add containing facet
+facet.categ <- NULL
+if( ! is.null(add)){
+facet.check <- TRUE
+tempo <- unlist(strsplit(x = add, split = "\\s*\\+\\s*(ggplot2|lemon)\\s*::\\s*")) #
+tempo <- sub(x = tempo, pattern = "^facet_wrap", replacement = "ggplot2::facet_wrap")
+tempo <- sub(x = tempo, pattern = "^facet_grid", replacement = "ggplot2::facet_grid")
+tempo <- sub(x = tempo, pattern = "^facet_rep", replacement = "lemon::facet_rep")
+if(length(data1) > 1 & (any(grepl(x = tempo, pattern = "ggplot2::facet_wrap|lemon::facet_rep_wrap")) | grepl(x = add, pattern = "ggplot2::facet_grid|lemon::facet_rep_grid"))){
+tempo.cat <- paste0("ERROR IN ", function.name, "\nfacet PANELS CANNOT BE USED IF MORE THAN ONE DATA FRAME IN THE data1 ARGUMENT\nPLEASE REWRITE THE add STRING AND RERUN")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+if(any(grepl(x = tempo, pattern = "ggplot2::facet_wrap|lemon::facet_rep_wrap"))){
+tempo1 <- suppressWarnings(eval(parse(text = tempo[grepl(x = tempo, pattern = "ggplot2::facet_wrap|lemon::facet_rep_wrap")])))
+facet.categ <- list(names(tempo1$params$facets)) # list of length 1
+tempo.text <- "facet_wrap OR facet_rep_wrap"
+facet.check <- FALSE
+}else if(grepl(x = add, pattern = "ggplot2::facet_grid|lemon::facet_rep_grid")){
+tempo1 <- suppressWarnings(eval(parse(text = tempo[grepl(x = tempo, pattern = "ggplot2::facet_grid|lemon::facet_rep_grid")])))
+facet.categ <- list(c(names(tempo1$params$rows), names(tempo1$params$cols))) # list of length 1
+tempo.text <- "facet_grid OR facet_rep_grid"
+facet.check <- FALSE
+}
+if(facet.check == FALSE & ! all(facet.categ %in% names(data1[[1]]))){ # WARNING: all(facet.categ %in% names(data1)) is TRUE when facet.categ is NULL
+tempo.cat <- paste0("ERROR IN ", function.name, "\nDETECTION OF \"", tempo.text, "\" STRING IN THE add ARGUMENT BUT PROBLEM OF VARIABLE DETECTION (COLUMN NAMES OF data1)\nTHE DETECTED VARIABLES ARE:\n", paste(facet.categ, collapse = " "), "\nTHE data1 COLUMN NAMES ARE:\n", paste(names(data1[[1]]), collapse = " "), "\nPLEASE REWRITE THE add STRING AND RERUN")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+}
+# if facet.categ is not NULL, it is a list of length 1 now
+# end management of add containing facet
+# legend name filling
+if(is.null(legend.name) & ! is.null(categ)){
+legend.name <- categ
+}else if(is.null(legend.name) & is.null(categ)){
+legend.name <- vector("list", length(data1)) # null list
+}
+# legend.name not NULL anymore (list)
+# end legend name filling
+# ini categ for legend display
+fin.lg.disp <- vector("list", 6) # will be used at the end to display or not legends
+fin.lg.disp[] <- FALSE
+legend.disp <- vector("list", length(data1))
+if(is.null(categ) | legend.show == FALSE){
+legend.disp[] <- FALSE
+}else{
+for(i2 in 1:length(data1)){
+if(is.null(categ[[i2]])){
+legend.disp[[i2]] <- FALSE
+}else{
+legend.disp[[i2]] <- TRUE
+}
+}
+}
+# end ini categ for legend display
+# integer colors into gg_palette
+tempo.check.color <- NULL
+for(i1 in 1:length(data1)){
+if(any(is.na(color[[i1]]))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), ": color ARGUMENT CANNOT CONTAIN NA")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+tempo.check.color <- c(tempo.check.color, fun_check(data = color[[i1]], data.name = ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), class = "integer", double.as.integer.allowed = TRUE, na.contain = TRUE, fun.name = function.name)$problem)
+}
+tempo.check.color <- ! tempo.check.color # invert TRUE and FALSE because if integer, then problem = FALSE
+if(any(tempo.check.color == TRUE)){ # convert integers into colors
+tempo.integer <- unlist(color[tempo.check.color])
+tempo.color <- fun_gg_palette(max(tempo.integer, na.rm = TRUE))
+for(i1 in 1:length(data1)){
+if(tempo.check.color[i1] == TRUE){
+color[[i1]] <-tempo.color[color[[i1]]]
+}
+}
+}
+# end integer colors into gg_palette
+# loop (checking inside list compartment)
+compart.null.color <- 0 # will be used to attribute a color when color is non-null but a compartment of color is NULL
+data1.ini <- data1 # to report NA removal
+removed.row.nb <- vector("list", length = length(data1)) # to report NA removal. Contains NULL
+removed.rows <- vector("list", length = length(data1)) # to report NA removal. Contains NULL
+for(i1 in 1:length(data1)){
+tempo <- fun_check(data = data1[[i1]], data.name = ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), class = "data.frame", na.contain = TRUE, fun.name = function.name)
+if(tempo$problem == TRUE){
+stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+# reserved word checking
+if(any(names(data1[[i1]]) %in% reserved.words)){ # I do not use fun_name_change() because cannot control y before creating "fake_y". But ok because reserved are not that common
+tempo.cat <- paste0("ERROR IN ", function.name, ": COLUMN NAMES OF ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), " ARGUMENT CANNOT BE ONE OF THESE WORDS\n", paste(reserved.words, collapse = " "), "\nTHESE ARE RESERVED FOR THE ", function.name, " FUNCTION")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+if( ! (is.null(add))){
+if(any(sapply(X = reserved.words, FUN = grepl, x = add))){
+tempo.cat <- paste0("ERROR IN ", function.name, "\nDETECTION OF COLUMN NAMES OF data1 IN THE add ARGUMENT STRING, THAT CORRESPOND TO RESERVED STRINGS FOR ", function.name, "\nFOLLOWING COLUMN NAMES HAVE TO BE CHANGED:\n", paste(arg.names[sapply(X = reserved.words, FUN = grepl, x = add)], collapse = "\n"), "\nFOR INFORMATION, THE RESERVED WORDS ARE:\n", paste(reserved.words, collapse = "\n"))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(any(sapply(X = arg.names, FUN = grepl, x = add))){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") NAMES OF ", function.name, " ARGUMENTS DETECTED IN THE add STRING:\n", paste(arg.names[sapply(X = arg.names, FUN = grepl, x = add)], collapse = "\n"), "\nRISK OF WRONG OBJECT USAGE INSIDE ", function.name)
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+# end reserved word checking
+# check of geom now because required for y argument
+tempo <- fun_check(data = geom[[i1]], data.name = ifelse(length(geom)== 1L, "geom", paste0("geom NUMBER ", i1)), options = c("geom_point", "geom_line", "geom_path", "geom_step", "geom_hline", "geom_vline", "geom_stick"), length = 1, fun.name = function.name)
+if(tempo$problem == TRUE){
+stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+if(geom[[i1]] == "geom_step" & is.null(geom.step.dir[[i1]])){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(geom.step.dir)== 1L, "geom.step.dir", paste0("ELEMENT ", i1, " OF geom.step.dir ARGUMENT")), ": geom.step.dir ARGUMENT CANNOT BE NULL IF ", ifelse(length(geom)== 1L, "geom", paste0("ELEMENT ", i1, " OF geom")), " ARGUMENT IS \"geom_step\"\nHERE geom.step.dir ARGUMENT IS: ", paste(geom.step.dir[[i1]], collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(geom[[i1]] == "geom_step" & ! is.null(geom.step.dir[[i1]])){
+tempo <- fun_check(data = geom.step.dir[[i1]], data.name = ifelse(length(geom.step.dir)== 1L, "geom.step.dir", paste0("geom.step.dir NUMBER ", i1)), options = c("vh", "hv", "mid"), length = 1, fun.name = function.name)
+if(tempo$problem == TRUE){
+stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+if( ! (is.null(geom.stick.base))){
+if(geom[[i1]] == "geom_stick" & ! is.null(geom.stick.base[[i1]])){
+tempo <- fun_check(data = geom.stick.base[[i1]], data.name = ifelse(length(geom.stick.base)== 1L, "geom.stick.base", paste0("geom.stick.base NUMBER ", i1)), mode = "numeric", length = 1, na.contain = FALSE, fun.name = function.name)
+if(tempo$problem == TRUE){
+stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+}
+# end check of geom now because required for y argument
+if(is.null(x[[i1]])){
+if(all(geom[[i1]] != "geom_hline")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(x)== 1L, "x", paste0("ELEMENT ", i1, " OF x ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), ": x ARGUMENT CANNOT BE NULL EXCEPT IF ", ifelse(length(geom)== 1L, "x", paste0("geom NUMBER ", i1)), " ARGUMENT IS \"geom_hline\"\nHERE geom ARGUMENT IS: ", paste(geom[[i1]], collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+x[[i1]] <- "fake_x"
+data1[[i1]] <- cbind(data1[[i1]], fake_x = NA, stringsAsFactors = TRUE)
+data1[[i1]][, "fake_x"] <- as.numeric(data1[[i1]][, "fake_x"])
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") NULL ", ifelse(length(x)== 1L, "x", paste0("ELEMENT ", i1, " OF x")), " ARGUMENT ASSOCIATED TO ", ifelse(length(geom)== 1L, "geom", paste0("geom NUMBER ", i1)), " ARGUMENT ", geom[[i1]], " -> FAKE COLUMN ADDED TO DATA FRAME ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), ", NAMED \"fake_x\" FOR FINAL DRAWING")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}else{
+if(all(geom[[i1]] == "geom_hline")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(x)== 1L, "x", paste0("ELEMENT ", i1, " OF x ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), ": x ARGUMENT MUST BE NULL IF ", ifelse(length(geom)== 1L, "geom", paste0("geom NUMBER ", i1)), " ARGUMENT IS \"geom_hline\"")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+tempo <- fun_check(data = x[[i1]], data.name = ifelse(length(x)== 1L, "x", paste0("ELEMENT ", i1, " OF x ARGUMENT")), class = "vector", mode = "character", length = 1, fun.name = function.name)
+if(tempo$problem == TRUE){
+stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+if(is.null(y[[i1]])){
+if(all(geom[[i1]] != "geom_vline")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(y)== 1L, "y", paste0("ELEMENT ", i1, " OF y ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), ": y ARGUMENT CANNOT BE NULL EXCEPT IF ", ifelse(length(geom)== 1L, "y", paste0("geom NUMBER ", i1)), " ARGUMENT IS \"geom_vline\"\nHERE geom ARGUMENT IS: ", paste(geom[[i1]], collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+y[[i1]] <- "fake_y"
+data1[[i1]] <- cbind(data1[[i1]], fake_y = NA, stringsAsFactors = TRUE)
+data1[[i1]][, "fake_y"] <- as.numeric(data1[[i1]][, "fake_y"])
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") NULL ", ifelse(length(y)== 1L, "y", paste0("ELEMENT ", i1, " OF y")), " ARGUMENT ASSOCIATED TO ", ifelse(length(geom)== 1L, "geom", paste0("geom NUMBER ", i1)), " ARGUMENT ", geom[[i1]], " -> FAKE COLUMN ADDED TO DATA FRAME ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), ", NAMED \"fake_y\" FOR FINAL DRAWING")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}else{
+if(all(geom[[i1]] == "geom_vline")){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(y)== 1L, "y", paste0("ELEMENT ", i1, " OF y ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), ": y ARGUMENT MUST BE NULL IF ", ifelse(length(geom)== 1L, "geom", paste0("geom NUMBER ", i1)), " ARGUMENT IS \"geom_vline\"")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+tempo <- fun_check(data = y[[i1]], data.name = ifelse(length(y)== 1L, "y", paste0("ELEMENT ", i1, " OF y ARGUMENT")), class = "vector", mode = "character", length = 1, fun.name = function.name)
+if(tempo$problem == TRUE){
+stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+# x[[i1]] and y[[i1]] not NULL anymore
+if( ! (x[[i1]] %in% names(data1[[i1]]))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(x)== 1L, "x", paste0("ELEMENT ", i1, " OF x")), " ARGUMENT MUST BE A COLUMN NAME OF ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT\nHERE IT IS: ", paste(x[[i1]], collapse = " "))))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+if( ! (y[[i1]] %in% names(data1[[i1]]))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(y)== 1L, "y", paste0("ELEMENT ", i1, " OF y")), " ARGUMENT MUST BE A COLUMN NAME OF ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT\nHERE IT IS: ", paste(y[[i1]], collapse = " "))))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+tempo <- fun_check(data = data1[[i1]][, x[[i1]]], data.name = ifelse(length(x)== 1L, "x ARGUMENT (AS COLUMN NAME OF data1 DATA FRAME)", paste0("ELEMENT ", i1, " OF x ARGUMENT", " (AS COLUMN NAME OF data1 DATA FRAME NUMBER ", i1, ")")), class = "vector", mode = "numeric", na.contain = TRUE, fun.name = function.name)
+if(tempo$problem == TRUE){
+stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+tempo <- fun_check(data = data1[[i1]][, y[[i1]]], data.name = ifelse(length(y)== 1L, "y ARGUMENT (AS COLUMN NAME OF data1 DATA FRAME)", paste0("ELEMENT ", i1, " OF y ARGUMENT", " (AS COLUMN NAME OF data1 DATA FRAME NUMBER ", i1, ")")), class = "vector", mode = "numeric", na.contain = TRUE, fun.name = function.name)
+if(tempo$problem == TRUE){
+stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+if(x[[i1]] == "fake_x" & y[[i1]] == "fake_y"){ # because the code cannot accept to be both "fake_x" and "fake_y" at the same time
+tempo.cat <- paste0("ERROR IN ", function.name, ": CODE INCONSISTENCY 2\nTHE CODE CANNOT ACCEPT x AND y TO BE \"fake_x\" AND \"fake_y\" IN THE SAME DATA FRAME ", i1, " ")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+
+if(( ! is.null(categ)) & ( ! is.null(categ[[i1]]))){ # is.null(categ[[i1]]) works even if categ is NULL # is.null(categ[[i1]]) works even if categ is NULL # if categ[[i1]] = NULL, fake_categ will be created later on
+tempo <- fun_check(data = categ[[i1]], data.name = ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")),, class = "vector", mode = "character", length = 1, fun.name = function.name)
+if(tempo$problem == TRUE){
+stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+if( ! (categ[[i1]] %in% names(data1[[i1]]))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ")), " ARGUMENT MUST BE A COLUMN NAME OF ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT\nHERE IT IS: ", paste(categ[[i1]], collapse = " "))))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+tempo1 <- fun_check(data = data1[[i1]][, categ[[i1]]], data.name = ifelse(length(categ)== 1L, "categ OF data1 ARGUMENT", paste0("ELEMENT ", i1, " OF categ ARGUMENT IN DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name)
+tempo2 <- fun_check(data = data1[[i1]][, categ[[i1]]], data.name = ifelse(length(categ)== 1L, "categ OF data1 ARGUMENT", paste0("ELEMENT ", i1, " OF categ ARGUMENT IN DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), class = "factor", na.contain = TRUE, fun.name = function.name)
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(categ)== 1L, "categ OF data1 ARGUMENT", paste0("ELEMENT ", i1, " OF categ ARGUMENT IN DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), " MUST BE A FACTOR OR CHARACTER VECTOR")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(tempo1$problem == FALSE){
+data1[[i1]][, categ[[i1]]] <- factor(data1[[i1]][, categ[[i1]]]) # if already a factor, change nothing, if characters, levels according to alphabetical order
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") IN ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), ", THE CHARACTER COLUMN HAS BEEN CONVERTED TO FACTOR")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+
+}
+if(geom[[i1]] == "geom_vline" | geom[[i1]] == "geom_hline"){
+if(length(unique(data1[[i1]][, categ[[i1]]])) != nrow(data1[[i1]])){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(geom)== 1L, "geom OF data1 ARGUMENT", paste0("geom NUMBER ", i1, " OF DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), " ARGUMENT IS ", geom[[i1]], ", MEANING THAT ", ifelse(length(categ)== 1L, "categ OF data1 ARGUMENT", paste0("ELEMENT ", i1, " OF categ ARGUMENT IN DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), " MUST HAVE A DIFFERENT CLASS PER LINE OF data1 (ONE x VALUE PER CLASS)")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+}else if(( ! is.null(categ)) & is.null(categ[[i1]])){ # is.null(categ[[i1]]) works even if categ is NULL # if categ[[i1]] = NULL, fake_categ will be created. WARNING: is.null(categ[[i1]]) means no legend display (see above), because categ has not been precised. This also means a single color for data1[[i1]]
+if(length(color[[i1]]) > 1){ # 0 means is.null(color[[i1]]) or is.null(color) and 1 is ok -> single color for data1[[i1]]
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") NULL ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ")), " ARGUMENT BUT CORRESPONDING COLORS IN ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " HAS LENGTH OVER 1\n", paste(color[[i1]], collapse = " "), "\nWHICH IS NOT COMPATIBLE WITH NULL CATEG -> COLOR RESET TO A SINGLE COLOR")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+color[i1] <- list(NULL) # will provide a single color below # Warning color[[i1]] <- NULL removes the compartment
+}
+categ[[i1]] <- "fake_categ"
+data1[[i1]] <- cbind(data1[[i1]], fake_categ = "", stringsAsFactors = TRUE)
+# inactivated because give a different color to different "Line_" categ while a single color for all the data1[[i1]] required. Thus, put back after the color management
+# if(geom[[i1]] == "geom_hline" | geom[[i1]] == "geom_vline"){
+# data1[[i1]][, "fake_categ"] <- paste0("Line_", 1:nrow(data1[[i1]]))
+# }else{
+data1[[i1]][, "fake_categ"] <- data1[[i1]][, "fake_categ"] # as.numeric("") create a vector of NA but class numeric
+# }
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") NULL ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ")), " ARGUMENT -> FOR DATA FRAME ", ifelse(length(data1)== 1L, "data1 ARGUMENT:", paste0("NUMBER ", i1, " OF data1 ARGUMENT:")), "\n- FAKE \"fake_categ\" COLUMN ADDED FILLED WITH \"\"(OR WITH \"Line_...\" FOR LINES)\n- SINGLE COLOR USED FOR PLOTTING\n- NO LEGEND DISPLAYED")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+# OK: if categ is not NULL, all the non-null categ columns of data1 are factors from here
+
+# management of log scale and Inf removal
+if(x[[i1]] != "fake_x"){
+if(any(( ! is.finite(data1[[i1]][, x[[i1]]])) & ( ! is.na(data1[[i1]][, x[[i1]]])))){ # is.finite also detects NA: ( ! is.finite(data1[, y])) & ( ! is.na(data1[, y])) detects only Inf
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") PRESENCE OF -Inf OR Inf VALUES IN ", ifelse(length(categ)== 1L, "x", paste0("ELEMENT ", i1, " OF x ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), " AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+if(y[[i1]] != "fake_y"){
+if(any(( ! is.finite(data1[[i1]][, y[[i1]]])) & ( ! is.na(data1[[i1]][, y[[i1]]])))){ # is.finite also detects NA: ( ! is.finite(data1[, y])) & ( ! is.na(data1[, y])) detects only Inf
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") PRESENCE OF -Inf OR Inf VALUES IN ", ifelse(length(categ)== 1L, "y", paste0("ELEMENT ", i1, " OF y ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), " AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+# log conversion
+if(x.log != "no"){
+tempo1 <- ! is.finite(data1[[i1]][, x[[i1]]]) # where are initial NA and Inf
+data1[[i1]][, x[[i1]]] <- suppressWarnings(get(x.log)(data1[[i1]][, x[[i1]]]))# no env = sys.nframe(), inherit = FALSE in get() because look for function in the classical scope
+if(any( ! (tempo1 | is.finite(data1[[i1]][, x[[i1]]])))){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") LOG CONVERSION INTRODUCED -Inf OR Inf OR NaN VALUES IN ", ifelse(length(categ)== 1L, "x", paste0("ELEMENT ", i1, " OF x ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), " AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+if(y.log != "no"){
+tempo1 <- ! is.finite(data1[[i1]][, y[[i1]]]) # where are initial NA and Inf
+data1[[i1]][, y[[i1]]] <- suppressWarnings(get(y.log)(data1[[i1]][, y[[i1]]]))# no env = sys.nframe(), inherit = FALSE in get() because look for function in the classical scope
+if(any( ! (tempo1 | is.finite(data1[[i1]][, y[[i1]]])))){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") LOG CONVERSION INTRODUCED -Inf OR Inf OR NaN VALUES IN ", ifelse(length(categ)== 1L, "y", paste0("ELEMENT ", i1, " OF y ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), " AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+# Inf removal
+# removed.row.nb[[i1]] <- NULL # already NULL and Warning this removes the compartment
+removed.rows[[i1]] <- data.frame(stringsAsFactors = FALSE)
+if(any(( ! is.finite(data1[[i1]][, x[[i1]]])) & ( ! is.na(data1[[i1]][, x[[i1]]])))){ # is.finite also detects NA: ( ! is.finite(data1[[i1]][, x[[i1]]])) & ( ! is.na(data1[[i1]][, x[[i1]]])) detects only Inf
+removed.row.nb[[i1]] <- c(removed.row.nb[[i1]], which(( ! is.finite(data1[[i1]][, x[[i1]]])) & ( ! is.na(data1[[i1]][, x[[i1]]]))))
+}
+if(any(( ! is.finite(data1[[i1]][, y[[i1]]])) & ( ! is.na(data1[[i1]][, y[[i1]]])))){ # is.finite also detects NA: ( ! is.finite(data1[[i1]][, y[[i1]]])) & ( ! is.na(data1[[i1]][, y[[i1]]])) detects only Inf
+removed.row.nb[[i1]] <- c(removed.row.nb[[i1]], which(( ! is.finite(data1[[i1]][, y[[i1]]])) & ( ! is.na(data1[[i1]][, y[[i1]]]))))
+}
+if( ! is.null(removed.row.nb[[i1]])){
+removed.row.nb[[i1]] <- unique(removed.row.nb[[i1]]) # to remove the duplicated positions (NA in both x and y)
+removed.rows[[i1]] <- rbind(removed.rows[[i1]], data1.ini[[i1]][removed.row.nb[[i1]], ]) # here data1.ini used to have the y = O rows that will be removed because of Inf creation after log transformation
+data1[[i1]] <- data1[[i1]][-removed.row.nb[[i1]], ]
+data1.ini[[i1]] <- data1.ini[[i1]][-removed.row.nb[[i1]], ] #
+}
+# From here, data1 and data.ini have no more Inf
+# end Inf removal
+# x.lim and y.lim dealt later on, after the end f the loop
+# end management of log scale and Inf removal
+# na detection and removal
+column.check <- unique(unlist(c( # unlist because creates a list
+if(x[[i1]] == "fake_x"){NULL}else{x[[i1]]},
+if(y[[i1]] == "fake_y"){NULL}else{y[[i1]]},
+if( ! is.null(categ)){if(is.null(categ[[i1]])){NULL}else{categ[[i1]]}},
+if( ! is.null(facet.categ)){if(is.null(facet.categ[[i1]])){NULL}else{facet.categ[[i1]]}}
+))) # dot.categ because can be a 3rd column of data1
+if(any(is.na(data1[[i1]][, column.check]))){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") NA DETECTED IN COLUMNS ", paste(column.check, collapse = " "), " OF ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), " AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+for(i3 in 1:length(column.check)){
+if(any(is.na(data1[[i1]][, column.check[i3]]))){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("NA REMOVAL DUE TO COLUMN ", column.check[i3], " OF ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")))
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+tempo <- unique(unlist(lapply(lapply(c(data1[[i1]][column.check]), FUN = is.na), FUN = which)))
+removed.row.nb[[i1]] <- c(removed.row.nb[[i1]], tempo)
+removed.rows[[i1]] <- rbind(removed.rows[[i1]], data1.ini[[i1]][tempo, ]) # # tempo used because removed.row.nb is not empty. Here data1.ini used to have the non NA rows that will be removed because of NAN creation after log transformation (neg values for instance)
+column.check <- column.check[ ! (column.check == x[[i1]] | column.check == y[[i1]])] # remove x and y to keep quali columns
+if(length(tempo) != 0){
+data1[[i1]] <- data1[[i1]][-tempo, ] # WARNING tempo here and not removed.row.nb because the latter contain more numbers thant the former
+data1.ini[[i1]] <- data1.ini[[i1]][-tempo, ] # WARNING tempo here and not removed.row.nb because the latter contain more numbers than the former
+for(i4 in 1:length(column.check)){
+if(any( ! unique(removed.rows[[i1]][, column.check[i4]]) %in% unique(data1[[i1]][, column.check[i4]]))){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") IN COLUMN ", column.check[i4], " OF ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), ", THE FOLLOWING CLASSES HAVE DISAPPEARED AFTER NA REMOVAL\n(IF COLUMN USED IN THE PLOT, THIS CLASS WILL NOT BE DISPLAYED):\n", paste(unique(removed.rows[[i1]][, column.check[i4]])[ ! unique(removed.rows[[i1]][, column.check[i4]]) %in% unique(data1[[i1]][, column.check[i4]])], collapse = " "))
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+tempo.levels <- levels(data1[[i1]][, column.check[i4]])[levels(data1[[i1]][, column.check[i4]]) %in% unique(as.character(data1[[i1]][, column.check[i4]]))]
+data1[[i1]][, column.check[i4]] <- factor(as.character(data1[[i1]][, column.check[i4]]), levels = tempo.levels)
+if(column.check[i4] %in% categ[[i1]] & ! is.null(categ.class.order)){
+categ.class.order[[i1]] <- levels(data1[[i1]][, column.check[i4]])[levels(data1[[i1]][, column.check[i4]]) %in% unique(data1[[i1]][, column.check[i4]])] # remove the absent class in the categ.class.order vector
+data1[[i1]][, column.check[i4]] <- factor(as.character(data1[[i1]][, column.check[i4]]), levels = unique(categ.class.order[[i1]]))
+}
+}
+}
+}
+}
+# end na detection and removal
+# From here, data1 and data.ini have no more NA or NaN in x, y, categ (if categ != NULL) and facet.categ (if categ != NULL)
+if( ! is.null(categ.class.order)){
+# the following check will be done several times but I prefer to keep it here, after the creation of categ
+if(is.null(categ[[i1]]) & ! is.null(categ.class.order[[i1]])){
+tempo.cat <- paste0("ERROR IN ", function.name, "\nCOMPARTMENT ", i1, " OF categ ARGUMENT CANNOT BE NULL IF COMPARTMENT ", i1, " OF categ.class.order ARGUMENT IS NOT NULL: ", paste(categ.class.order, collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+if(is.null(categ.class.order[[i1]])){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") THE categ.class.order COMPARTMENT ", i1, " IS NULL. ALPHABETICAL ORDER WILL BE APPLIED")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+data1[[i1]][, categ[[i1]]] <- factor(as.character(data1[[i1]][, categ[[i1]]])) # if already a factor, change nothing, if characters, levels according to alphabetical order
+categ.class.order[[i1]] <- levels(data1[[i1]][, categ[[i1]]]) # character vector that will be used later
+}else{
+tempo <- fun_check(data = categ.class.order[[i1]], data.name = paste0("COMPARTMENT ", i1 , " OF categ.class.order ARGUMENT"), class = "vector", mode = "character", length = length(levels(data1[[i1]][, categ[[i1]]])), fun.name = function.name) # length(data1[, categ[i1]) -> if data1[, categ[i1] was initially character vector, then conversion as factor after the NA removal, thus class number ok. If data1[, categ[i1] was initially factor, no modification after the NA removal, thus class number ok
+if(tempo$problem == TRUE){
+stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+if(any(duplicated(categ.class.order[[i1]]))){
+tempo.cat <- paste0("ERROR IN ", function.name, "\nCOMPARTMENT ", i1, " OF categ.class.order ARGUMENT CANNOT HAVE DUPLICATED CLASSES: ", paste(categ.class.order[[i1]], collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if( ! (all(categ.class.order[[i1]] %in% unique(data1[[i1]][, categ[[i1]]])) & all(unique(data1[[i1]][, categ[[i1]]]) %in% categ.class.order[[i1]]))){
+tempo.cat <- paste0("ERROR IN ", function.name, "\nCOMPARTMENT ", i1, " OF categ.class.order ARGUMENT MUST BE CLASSES OF COMPARTMENT ", i1, " OF categ ARGUMENT\nHERE IT IS:\n", paste(categ.class.order[[i1]], collapse = " "), "\nFOR COMPARTMENT ", i1, " OF categ.class.order AND IT IS:\n", paste(unique(data1[[i1]][, categ[[i1]]]), collapse = " "), "\nFOR COLUMN ", categ[[i1]], " OF data1 NUMBER ", i1)
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+data1[[i1]][, categ[[i1]]] <- factor(data1[[i1]][, categ[[i1]]], levels = categ.class.order[[i1]]) # reorder the factor
+}
+names(categ.class.order)[i1] <- categ[[i1]]
+}
+}
+# OK: if categ.class.order is not NULL, all the NULL categ.class.order columns of data1 are character from here
+
+if( ! is.null(legend.name[[i1]])){
+tempo <- fun_check(data = legend.name[[i1]], data.name = ifelse(length(legend.name)== 1L, "legend.name", paste0("legend.name NUMBER ", i1)),, class = "vector", mode = "character", length = 1, fun.name = function.name)
+if(tempo$problem == TRUE){
+stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+if( ! is.null(color)){ # if color is NULL, will be filled later on
+# check the nature of color
+if(is.null(color[[i1]])){
+compart.null.color <- compart.null.color + 1
+color[[i1]] <- grey(compart.null.color / 8) # cannot be more than 7 overlays. Thus 7 different greys. 8/8 is excluded because white dots
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") NULL COLOR IN ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " ASSOCIATED TO ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), ", SINGLE COLOR ", paste(color[[i1]], collapse = " "), " HAS BEEN ATTRIBUTED")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+tempo1 <- fun_check(data = color[[i1]], data.name = ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name) # na.contain = TRUE in case of colum of data1
+tempo2 <- fun_check(data = color[[i1]], data.name = ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), class = "factor", na.contain = TRUE, fun.name = function.name) # idem
+if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " MUST BE A FACTOR OR CHARACTER VECTOR OR INTEGER VECTOR") # integer possible because dealt above
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if( ! (all(color[[i1]] %in% colors() | grepl(pattern = "^#", color[[i1]])))){ # check that all strings of low.color start by #
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " MUST BE A HEXADECIMAL COLOR VECTOR STARTING BY # AND/OR COLOR NAMES GIVEN BY colors() OR A COLUMN NAME OF THE data1 PARAMETER: ", paste(unique(color[[i1]]), collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+if(any(is.na(color[[i1]]))){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") IN ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), ", THE COLORS:\n", paste(unique(color[[i1]]), collapse = " "), "\nCONTAINS NA")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+# end check the nature of color
+# check the length of color
+if(is.null(categ) & length(color[[i1]]) != 1){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " MUST BE A SINGLE COLOR IF categ IS NULL")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if( ! is.null(categ)){
+# No problem of NA management by ggplot2 because already removed
+if(categ[[i1]] == "fake_categ" & length(color[[i1]]) != 1){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " MUST BE A SINGLE COLOR IF ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IS NULL")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(length(color[[i1]]) == length(unique(data1[[i1]][, categ[[i1]]]))){ # here length(color) is equal to the different number of categ
+data1[[i1]][, categ[[i1]]] <- factor(data1[[i1]][, categ[[i1]]]) # if already a factor, change nothing, if characters, levels according to alphabetical order
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") IN ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), ", THE FOLLOWING COLORS:\n", paste(color[[i1]], collapse = " "), "\nHAVE BEEN ATTRIBUTED TO THESE CLASSES:\n", paste(levels(factor(data1[[i1]][, categ[[i1]]])), collapse = " "))
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}else if(length(color[[i1]]) == length(data1[[i1]][, categ[[i1]]])){# here length(color) is equal to nrow(data1[[i1]]) -> Modif to have length(color) equal to the different number of categ (length(color) == length(levels(data1[[i1]][, categ[[i1]]])))
+data1[[i1]] <- cbind(data1[[i1]], color = color[[i1]], stringsAsFactors = TRUE)
+tempo.check <- unique(data1[[i1]][ , c(categ[[i1]], "color")])
+if( ! (nrow(data1[[i1]]) == length(color[[i1]]) & nrow(tempo.check) == length(unique(data1[[i1]][ , categ[[i1]]])))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color")), " ARGUMENT HAS THE LENGTH OF ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), "\nBUT IS INCORRECTLY ASSOCIATED TO EACH CLASS OF THIS categ:\n", paste(unique(mapply(FUN = "paste", data1[[i1]][ ,categ[[i1]]], data1[[i1]][ ,"color"])), collapse = "\n"))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+data1[[i1]][, categ[[i1]]] <- factor(data1[[i1]][, categ[[i1]]]) # if already a factor, change nothing, if characters, levels according to alphabetical order
+color[[i1]] <- unique(color[[i1]][order(data1[[i1]][, categ[[i1]]])]) # Modif to have length(color) equal to the different number of categ (length(color) == length(levels(data1[[i1]][, categ[[i1]]])))
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count, ") FROM FUNCTION ", function.name, ": ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " HAS THE LENGTH OF ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), " COLUMN VALUES\nCOLORS HAVE BEEN RESPECTIVELY ASSOCIATED TO EACH CLASS OF categ AS:\n", paste(levels(factor(data1[[i1]][, categ[[i1]]])), collapse = " "), "\n", paste(color[[i1]], collapse = " "))
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}else if(length(color[[i1]])== 1L){
+data1[[i1]][, categ[[i1]]] <- factor(data1[[i1]][, categ[[i1]]]) # if already a factor, change nothing, if characters, levels according to alphabetical order
+color[[i1]] <- rep(color[[i1]], length(levels(data1[[i1]][, categ[[i1]]])))
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") IN ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), ", COLOR HAS LENGTH 1 MEANING THAT ALL THE DIFFERENT CLASSES OF ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), "\n", paste(levels(factor(data1[[i1]][, categ[[i1]]])), collapse = " "), "\nWILL HAVE THE SAME COLOR\n", paste(color[[i1]], collapse = " "))
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}else{
+tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " MUST BE\n(1) LENGTH 1\nOR (2) THE LENGTH OF ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), " COLUMN VALUES\nOR (3) THE LENGTH OF THE CLASSES IN THIS COLUMN\nHERE IT IS COLOR LENGTH ", length(color[[i1]]), " VERSUS CATEG LENGTH ", length(data1[[i1]][, categ[[i1]]]), " AND CATEG CLASS LENGTH ", length(unique(data1[[i1]][, categ[[i1]]])), "\nPRESENCE OF NA IN THE COLUMN x, y OR categ OF data1 COULD BE THE PROBLEME")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+}
+if((geom[[i1]] == "geom_hline" | geom[[i1]] == "geom_vline") & ! is.null(categ[[i1]])){ # add here after the color management, to deal with the different lines to plot inside any data[[i1]]
+if(categ[[i1]] == "fake_categ"){
+data1[[i1]][, "fake_categ"] <- factor(paste0("Line_", formatC(1:nrow(data1[[i2]]), width = nchar(nrow(data1[[i2]])), flag = "0")))
+}
+}
+tempo <- fun_check(data = alpha[[i1]], data.name = ifelse(length(alpha)== 1L, "alpha", paste0("alpha NUMBER ", i1)), prop = TRUE, length = 1, fun.name = function.name)
+if(tempo$problem == TRUE){
+stop(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+# end loop (checking inside list compartment)
+if(length(data1) > 1){
+if(length(unique(unlist(x)[ ! x == "fake_x"])) > 1){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") THE x ARGUMENT DOES NOT CONTAIN IDENTICAL COLUMN NAMES:\n", paste(unlist(x), collapse = " "), "\nX-AXIS OVERLAYING DIFFERENT VARIABLES?")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+if(length(data1) > 1){
+if(length(unique(unlist(y)[ ! y == "fake_y"])) > 1){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") THE y ARGUMENT DOES NOT CONTAIN IDENTICAL COLUMN NAMES:\n", paste(unlist(y), collapse = " "), "\nY-AXIS OVERLAYING DIFFERENT VARIABLES?")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+if(sum(geom %in% "geom_point") > 3){
+tempo.cat <- paste0("ERROR IN ", function.name, ": geom ARGUMENT CANNOT HAVE MORE THAN THREE \"geom_point\" ELEMENTS")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(length(geom) - sum(geom %in% "geom_point") > 3){
+tempo.cat <- paste0("ERROR IN ", function.name, ": geom ARGUMENT CANNOT HAVE MORE THAN THREE LINE ELEMENTS")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+# x.lim management before transfo by x.log
+if(x.log != "no" & ! is.null(x.lim)){
+if(any(x.lim <= 0)){
+tempo.cat <- paste0("ERROR IN ", function.name, "\nx.lim ARGUMENT CANNOT HAVE ZERO OR NEGATIVE VALUES WITH THE x.log ARGUMENT SET TO ", x.log, ":\n", paste(x.lim, collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(any( ! is.finite(if(x.log == "log10"){log10(x.lim)}else{log2(x.lim)}))){
+tempo.cat <- paste0("ERROR IN ", function.name, "\nx.lim ARGUMENT RETURNS INF/NA WITH THE x.log ARGUMENT SET TO ", x.log, "\nAS SCALE COMPUTATION IS ", ifelse(x.log == "log10", "log10", "log2"), ":\n", paste(if(x.log == "log10"){log10(x.lim)}else{log2(x.lim)}, collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+if(x.log != "no" & x.include.zero == TRUE){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") x.log ARGUMENT SET TO ", x.log, " AND x.include.zero ARGUMENT SET TO TRUE -> x.include.zero ARGUMENT RESET TO FALSE BECAUSE 0 VALUE CANNOT BE REPRESENTED IN LOG SCALE")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+x.include.zero <- FALSE
+}
+# end x.lim management before transfo by x.log
+# y.lim management before transfo by y.log
+if(y.log != "no" & ! is.null(y.lim)){
+if(any(y.lim <= 0)){
+tempo.cat <- paste0("ERROR IN ", function.name, "\ny.lim ARGUMENT CANNOT HAVE ZERO OR NEGATIVE VALUES WITH THE y.log ARGUMENT SET TO ", y.log, ":\n", paste(y.lim, collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(any( ! is.finite(if(y.log == "log10"){log10(y.lim)}else{log2(y.lim)}))){
+tempo.cat <- paste0("ERROR IN ", function.name, "\ny.lim ARGUMENT RETURNS INF/NA WITH THE y.log ARGUMENT SET TO ", y.log, "\nAS SCALE COMPUTATION IS ", ifelse(y.log == "log10", "log10", "log2"), ":\n", paste(if(y.log == "log10"){log10(y.lim)}else{log2(y.lim)}, collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+if(y.log != "no" & y.include.zero == TRUE){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") y.log ARGUMENT SET TO ", y.log, " AND y.include.zero ARGUMENT SET TO TRUE -> y.include.zero ARGUMENT RESET TO FALSE BECAUSE 0 VALUE CANNOT BE REPRESENTED IN LOG SCALE")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+y.include.zero <- FALSE
+}
+# end y.lim management before transfo by y.log
+# end other checkings
+# reserved word checking
+#already done above
+# end reserved word checking
+# end second round of checking and data preparation
+
+
+# package checking
+fun_pack(req.package = c(
+"gridExtra",
+"ggplot2",
+"lemon",
+"scales"
+), load = FALSE, lib.path = lib.path)
+# packages Cairo and grid tested by fun_gg_point_rast()
+# end package checking
+
+
+
+
+# main code
+# axes management
+if(is.null(x.lim)){
+if(any(unlist(mapply(FUN = "[[", data1, x, SIMPLIFY = FALSE)) %in% c(Inf, -Inf))){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") THE x COLUMN IN data1 CONTAINS -Inf OR Inf VALUES THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+x.lim <- suppressWarnings(range(unlist(mapply(FUN = "[[", data1, x, SIMPLIFY = FALSE)), na.rm = TRUE, finite = TRUE)) # finite = TRUE removes all the -Inf and Inf except if only this. In that case, whatever the -Inf and/or Inf present, output -Inf;Inf range. Idem with NA only. y.lim added here. If NULL, ok if y argument has values
+}else if(x.log != "no"){
+x.lim <- get(x.log)(x.lim) # no env = sys.nframe(), inherit = FALSE in get() because look for function in the classical scope
+}
+if(x.log != "no"){
+if(any( ! is.finite(x.lim))){
+tempo.cat <- paste0("ERROR IN ", function.name, "\nx.lim ARGUMENT CANNOT HAVE ZERO OR NEGATIVE VALUES WITH THE x.log ARGUMENT SET TO ", x.log, ":\n", paste(x.lim, collapse = " "), "\nPLEASE, CHECK DATA VALUES (PRESENCE OF ZERO OR INF VALUES)")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+if(suppressWarnings(all(x.lim %in% c(Inf, -Inf)))){ # happen when x is only NULL
+if(all(unlist(geom) %in% c("geom_vline", "geom_stick"))){
+tempo.cat <- paste0("ERROR IN ", function.name, " NOT POSSIBLE TO DRAW geom_vline OR geom_stick KIND OF LINES ALONE IF x.lim ARGUMENT IS SET TO NULL, SINCE NO X-AXIS DEFINED (", ifelse(length(x)== 1L, "x", paste0("ELEMENT ", i1, " OF x")), " ARGUMENT MUST BE NULL FOR THESE KIND OF LINES)")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+tempo.cat <- paste0("ERROR IN ", function.name, " x.lim ARGUMENT MADE OF NA, -Inf OR Inf ONLY: ", paste(x.lim, collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+x.lim.order <- order(x.lim) # to deal with inverse axis
+# print(x.lim.order)
+x.lim <- sort(x.lim)
+x.lim[1] <- x.lim[1] - abs(x.lim[2] - x.lim[1]) * ifelse(diff(x.lim.order) > 0, x.right.extra.margin, x.left.extra.margin) # diff(x.lim.order) > 0 means not inversed axis
+x.lim[2] <- x.lim[2] + abs(x.lim[2] - x.lim[1]) * ifelse(diff(x.lim.order) > 0, x.left.extra.margin, x.right.extra.margin) # diff(x.lim.order) > 0 means not inversed axis
+if(x.include.zero == TRUE){ # no need to check x.log != "no" because done before
+x.lim <- range(c(x.lim, 0), na.rm = TRUE, finite = TRUE) # finite = TRUE removes all the -Inf and Inf except if only this. In that case, whatever the -Inf and/or Inf present, output -Inf;Inf range. Idem with NA only
+}
+x.lim <- x.lim[x.lim.order]
+if(any(is.na(x.lim))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": CODE INCONSISTENCY 3")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+if(is.null(y.lim)){
+if(any(unlist(mapply(FUN = "[[", data1, y, SIMPLIFY = FALSE)) %in% c(Inf, -Inf))){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") THE y COLUMN IN data1 CONTAINS -Inf OR Inf VALUES THAT WILL NOT BE CONSIDERED IN THE PLOT RANGE")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+y.lim <- suppressWarnings(range(unlist(mapply(FUN = "[[", data1, y, SIMPLIFY = FALSE)), na.rm = TRUE, finite = TRUE)) # finite = TRUE removes all the -Inf and Inf except if only this. In that case, whatever the -Inf and/or Inf present, output -Inf;Inf range. Idem with NA only. y.lim added here. If NULL, ok if y argument has values
+}else if(y.log != "no"){
+y.lim <- get(y.log)(y.lim) # no env = sys.nframe(), inherit = FALSE in get() because look for function in the classical scope
+}
+if(y.log != "no"){
+if(any( ! is.finite(y.lim))){
+tempo.cat <- paste0("ERROR IN ", function.name, "\ny.lim ARGUMENT CANNOT HAVE ZERO OR NEGATIVE VALUES WITH THE y.log ARGUMENT SET TO ", y.log, ":\n", paste(y.lim, collapse = " "), "\nPLEASE, CHECK DATA VALUES (PRESENCE OF ZERO OR INF VALUES)")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+if(suppressWarnings(all(y.lim %in% c(Inf, -Inf)))){ # happen when y is only NULL
+if(all(unlist(geom) == "geom_vline")){
+tempo.cat <- paste0("ERROR IN ", function.name, " NOT POSSIBLE TO DRAW geom_vline KIND OF LINES ALONE IF y.lim ARGUMENT IS SET TO NULL, SINCE NO Y-AXIS DEFINED (", ifelse(length(y)== 1L, "y", paste0("ELEMENT ", i1, " OF y")), " ARGUMENT MUST BE NULL FOR THESE KIND OF LINES)")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+tempo.cat <- paste0("ERROR IN ", function.name, " y.lim ARGUMENT MADE OF NA, -Inf OR Inf ONLY: ", paste(y.lim, collapse = " "))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+y.lim.order <- order(y.lim) # to deal with inverse axis
+y.lim <- sort(y.lim)
+y.lim[1] <- y.lim[1] - abs(y.lim[2] - y.lim[1]) * ifelse(diff(y.lim.order) > 0, y.bottom.extra.margin, y.top.extra.margin) # diff(y.lim.order) > 0 means not inversed axis
+y.lim[2] <- y.lim[2] + abs(y.lim[2] - y.lim[1]) * ifelse(diff(y.lim.order) > 0, y.top.extra.margin, y.bottom.extra.margin) # diff(y.lim.order) > 0 means not inversed axis
+if(y.include.zero == TRUE){ # no need to check y.log != "no" because done before
+y.lim <- range(c(y.lim, 0), na.rm = TRUE, finite = TRUE) # finite = TRUE removes all the -Inf and Inf except if only this. In that case, whatever the -Inf and/or Inf present, output -Inf;Inf range. Idem with NA only
+}
+y.lim <- y.lim[y.lim.order]
+if(any(is.na(y.lim))){
+tempo.cat <- paste0("ERROR IN ", function.name, ": CODE INCONSISTENCY 4")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+# end axes management
+
+
+
+
+# create a fake categ if NULL to deal with legend display
+if(is.null(categ)){
+categ <- vector("list", length(data1))
+categ[] <- "fake_categ"
+for(i2 in 1:length(data1)){
+data1[[i2]] <- cbind(data1[[i2]], fake_categ = "", stringsAsFactors = TRUE)
+if(geom[[i2]] == "geom_hline" | geom[[i2]] == "geom_vline"){
+data1[[i2]][, "fake_categ"] <- factor(paste0("Line_", 1:nrow(data1[[i2]])))
+}
+}
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") NULL categ ARGUMENT -> FAKE \"fake_categ\" COLUMN ADDED TO EACH DATA FRAME OF data1, AND FILLED WITH \"\"")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+# categ is not NULL anymore
+if(is.null(categ.class.order)){
+categ.class.order <- vector("list", length = length(data1))
+tempo.categ.class.order <- NULL
+for(i2 in 1:length(categ.class.order)){
+categ.class.order[[i2]] <- levels(data1[[i2]][, categ[[i2]]])
+names(categ.class.order)[i2] <- categ[[i2]]
+tempo.categ.class.order <- c(tempo.categ.class.order, ifelse(i2 != 1, "\n", ""), categ.class.order[[i2]])
+}
+if(any(unlist(legend.disp))){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") THE categ.class.order SETTING IS NULL. ALPHABETICAL ORDER WILL BE APPLIED FOR CLASS ORDERING:\n", paste(tempo.categ.class.order, collapse = " "))
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+# end create a fake categ if NULL to deal with legend display
+# categ.class.order is not NULL anymore
+
+
+# vector of color with length as in levels(categ) of data1
+if(is.null(color)){
+color <- vector("list", length(data1))
+length.categ.list <- lapply(lapply(mapply(FUN = "[[", data1, categ, SIMPLIFY = FALSE), FUN = unique), FUN = function(x){length(x[ ! is.na(x)])})
+length.categ.list[sapply(categ, FUN = "==", "fake_categ")] <- 1 # when is.null(color), a single color for all the dots or lines of data[[i1]] that contain "fake_categ" category
+total.categ.length <- sum(unlist(length.categ.list), na.rm = TRUE)
+tempo.color <- fun_gg_palette(total.categ.length)
+tempo.count <- 0
+for(i2 in 1:length(data1)){
+color[[i2]] <- tempo.color[(1:length.categ.list[[i2]]) + tempo.count]
+tempo.count <- tempo.count + length.categ.list[[i2]]
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") NULL color ARGUMENT -> COLORS RESPECTIVELY ATTRIBUTED TO EACH CLASS OF ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i2, " OF categ ARGUMENT")), " (", categ[[i2]], ") IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i2, " OF data1 ARGUMENT")), ":\n", paste(color[[i2]], collapse = " "), "\n", paste(if(all(levels(data1[[i2]][, categ[[i2]]]) == "")){'\"\"'}else{levels(data1[[i2]][, categ[[i2]]])}, collapse = " "))
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+# end vector of color with length as in levels(categ) of data1
+# color is not NULL anymore
+
+
+
+
+
+# last check
+for(i1 in 1:length(data1)){
+if(categ[[i1]] != "fake_categ" & length(color[[i1]]) != length(unique(data1[[i1]][, categ[[i1]]]))){
+tempo.cat <- paste0("ERROR IN ", function.name, " LAST CHECK: ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " MUST HAVE THE LENGTH OF LEVELS OF ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), "\nHERE IT IS COLOR LENGTH ", length(color[[i1]]), " VERSUS CATEG LEVELS LENGTH ", length(unique(data1[[i1]][, categ[[i1]]])), "\nREMINDER: A SINGLE COLOR PER CLASS OF CATEG AND A SINGLE CLASS OF CATEG PER COLOR MUST BE RESPECTED")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else if(categ[[i1]] == "fake_categ" & length(color[[i1]]) != 1){
+tempo.cat <- paste0("ERROR IN ", function.name, " LAST CHECK: ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " MUST HAVE LENGTH 1 WHEN ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IS NULL\nHERE IT IS COLOR LENGTH ", length(color[[i1]]))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+# end last check
+
+
+
+
+
+# conversion of geom_hline and geom_vline
+for(i1 in 1:length(data1)){
+if(geom[[i1]] == "geom_hline" | geom[[i1]] == "geom_vline"){
+final.data.frame <- data.frame()
+for(i3 in 1:nrow(data1[[i1]])){
+tempo.data.frame <- rbind(data1[[i1]][i3, ], data1[[i1]][i3, ], stringsAsFactors = TRUE)
+if(geom[[i1]] == "geom_hline"){
+tempo.data.frame[, x[[i1]]] <- x.lim
+}else if(geom[[i1]] == "geom_vline"){
+tempo.data.frame[, y[[i1]]] <- y.lim
+}else{
+tempo.cat <- paste0("ERROR IN ", function.name, ": CODE INCONSISTENCY 5")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+# 3 lines below inactivated because I put that above
+# if(is.null(categ[[i1]])){
+# data1[, "fake_categ"] <- paste0("Line_", i3)
+# }
+final.data.frame <- rbind(final.data.frame, tempo.data.frame, stringsAsFactors = TRUE)
+}
+data1[[i1]] <- final.data.frame
+geom[[i1]] <- "geom_line"
+if(length(color[[i1]])== 1L){
+color[[i1]] <- rep(color[[i1]], length(unique(data1[[i1]][ , categ[[i1]]])))
+}else if(length(color[[i1]]) != length(unique(data1[[i1]][ , categ[[i1]]]))){
+tempo.cat <- paste0("ERROR IN ", function.name, " geom_hline AND geom_vline CONVERSION TO FIT THE XLIM AND YLIM LIMITS OF THE DATA: ", ifelse(length(color)== 1L, "color", paste0("ELEMENT NUMBER ", i1, " OF color ARGUMENT")), " MUST HAVE THE LENGTH OF LEVELS OF ", ifelse(length(categ)== 1L, "categ", paste0("ELEMENT ", i1, " OF categ ARGUMENT")), " IN ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i1, " OF data1 ARGUMENT")), "\nHERE IT IS COLOR LENGTH ", length(color[[i1]]), " VERSUS CATEG LEVELS LENGTH ", length(unique(data1[[i1]][, categ[[i1]]])))
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+}
+}
+# end conversion of geom_hline and geom_vline
+
+
+
+
+# kind of geom_point (vectorial or raster)
+scatter.kind <- vector("list", length = length(data1)) # list of same length as data1, that will be used to use either ggplot2::geom_point() (vectorial dot layer) or fun_gg_point_rast() (raster dot layer)
+fix.ratio <- FALSE
+if(is.null(raster.threshold)){
+if(raster == TRUE){
+scatter.kind[] <- "fun_gg_point_rast" # not important to fill everything: will be only used when geom == "geom_point"
+fix.ratio <- TRUE
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") RASTER PLOT GENERATED -> ASPECT RATIO OF THE PLOT REGION SET BY THE raster.ratio ARGUMENT (", fun_round(raster.ratio, 2), ") TO AVOID A BUG OF ELLIPSOID DOT DRAWING")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}else{
+scatter.kind[] <- "ggplot2::geom_point"
+}
+}else{
+for(i2 in 1:length(data1)){
+if(geom[[i2]] == "geom_point"){
+if(nrow(data1[[i2]]) <= raster.threshold){
+scatter.kind[[i2]] <- "ggplot2::geom_point"
+}else{
+scatter.kind[[i2]] <- "fun_gg_point_rast"
+fix.ratio <- TRUE
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") ", ifelse(length(data1)== 1L, "data1 ARGUMENT", paste0("DATA FRAME NUMBER ", i2, " OF data1 ARGUMENT")), " LAYER AS RASTER (NOT VECTORIAL)")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+}
+if(any(unlist(scatter.kind) == "fun_gg_point_rast")){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") RASTER PLOT GENERATED -> ASPECT RATIO OF THE PLOT REGION SET BY THE raster.ratio ARGUMENT (", fun_round(raster.ratio, 2), ") TO AVOID A BUG OF ELLIPSOID DOT DRAWING")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+# end kind of geom_point (vectorial or raster)
+
+
+
+
+# no need loop part
+coord.names <- NULL
+tempo.gg.name <- "gg.indiv.plot."
+tempo.gg.count <- 0
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste0("ggplot2::ggplot()", if(is.null(add)){""}else{add})))) # add added here to have the facets
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::xlab(if(is.null(x.lab)){x[[1]]}else{x.lab}))
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ylab(if(is.null(y.lab)){y[[1]]}else{y.lab}))
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggtitle(title))
+# text angle management
+x.tempo.just <- fun_gg_just(angle = x.text.angle, pos = "bottom", kind = "axis")
+y.tempo.just <- fun_gg_just(angle = y.text.angle, pos = "left", kind = "axis")
+# end text angle management
+add.check <- TRUE
+if( ! is.null(add)){ # if add is NULL, then = 0
+if(grepl(pattern = "ggplot2::theme", add) == TRUE){
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") \"ggplot2::theme\" STRING DETECTED IN THE add ARGUMENT\n-> INTERNAL GGPLOT2 THEME FUNCTIONS theme() AND theme_classic() HAVE BEEN INACTIVATED, TO BE USED BY THE USER\n-> article ARGUMENT WILL BE IGNORED\nIT IS RECOMMENDED TO USE \"+ theme(aspect.ratio = raster.ratio)\" IF RASTER MODE IS ACTIVATED")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+add.check <- FALSE
+}
+}
+if(add.check == TRUE & article == TRUE){
+# WARNING: not possible to add several times theme(). NO message but the last one overwrites the others
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_classic(base_size = text.size))
+if(grid == TRUE){
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme(
+text = ggplot2::element_text(size = text.size),
+plot.title = ggplot2::element_text(size = title.text.size), # stronger than text
+legend.key = ggplot2::element_rect(color = "white", size = 1.5), # size of the frame of the legend
+line = ggplot2::element_line(size = 0.5),
+axis.line.y.left = ggplot2::element_line(colour = "black"), # draw lines for the y axis
+axis.line.x.bottom = ggplot2::element_line(colour = "black"), # draw lines for the x axis
+panel.grid.major.x = ggplot2::element_line(colour = "grey85", size = 0.75),
+panel.grid.minor.x = ggplot2::element_line(colour = "grey90", size = 0.25),
+panel.grid.major.y = ggplot2::element_line(colour = "grey85", size = 0.75),
+panel.grid.minor.y = ggplot2::element_line(colour = "grey90", size = 0.25),
+axis.text.x = ggplot2::element_text(angle = x.tempo.just$angle, hjust = x.tempo.just$hjust, vjust = x.tempo.just$vjust),
+axis.text.y = ggplot2::element_text(angle = y.tempo.just$angle, hjust = y.tempo.just$hjust, vjust = y.tempo.just$vjust),
+aspect.ratio = if(fix.ratio == TRUE){raster.ratio}else{NULL} # for raster
+))
+}else{
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme(
+text = ggplot2::element_text(size = text.size),
+plot.title = ggplot2::element_text(size = title.text.size), # stronger than text
+line = ggplot2::element_line(size = 0.5),
+legend.key = ggplot2::element_rect(color = "white", size = 1.5), # size of the frame of the legend
+axis.line.y.left = ggplot2::element_line(colour = "black"),
+axis.line.x.bottom = ggplot2::element_line(colour = "black"),
+axis.text.x = ggplot2::element_text(angle = x.tempo.just$angle, hjust = x.tempo.just$hjust, vjust = x.tempo.just$vjust),
+axis.text.y = ggplot2::element_text(angle = y.tempo.just$angle, hjust = y.tempo.just$hjust, vjust = y.tempo.just$vjust),
+aspect.ratio = if(fix.ratio == TRUE){raster.ratio}else{NULL} # for raster
+))
+}
+}else if(add.check == TRUE & article == FALSE){
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme(
+text = ggplot2::element_text(size = text.size),
+plot.title = ggplot2::element_text(size = title.text.size), # stronger than text
+line = ggplot2::element_line(size = 0.5),
+legend.key = ggplot2::element_rect(color = "white", size = 1.5), # size of the frame of the legend
+panel.background = ggplot2::element_rect(fill = "grey95"),
+axis.line.y.left = ggplot2::element_line(colour = "black"),
+axis.line.x.bottom = ggplot2::element_line(colour = "black"),
+panel.grid.major.x = ggplot2::element_line(colour = "grey85", size = 0.75),
+panel.grid.minor.x = ggplot2::element_line(colour = "grey90", size = 0.25),
+panel.grid.major.y = ggplot2::element_line(colour = "grey85", size = 0.75),
+panel.grid.minor.y = ggplot2::element_line(colour = "grey90", size = 0.25),
+strip.background = ggplot2::element_rect(fill = "white", colour = "black"),
+axis.text.x = ggplot2::element_text(angle = x.tempo.just$angle, hjust = x.tempo.just$hjust, vjust = x.tempo.just$vjust),
+axis.text.y = ggplot2::element_text(angle = y.tempo.just$angle, hjust = y.tempo.just$hjust, vjust = y.tempo.just$vjust),
+aspect.ratio = if(fix.ratio == TRUE){raster.ratio}else{NULL} # for raster
+# do not work -> legend.position = "none" # to remove the legend completely: https://www.datanovia.com/en/blog/how-to-remove-legend-from-a-ggplot/
+))
+}
+# end no need loop part
+
+
+# loop part
+point.count <- 0
+line.count <- 0
+lg.order <- vector(mode = "list", length = 6) # order of the legend
+lg.order <- lapply(lg.order, as.numeric) # order of the legend
+lg.color <- vector(mode = "list", length = 6) # color of the legend
+lg.dot.shape <- vector(mode = "list", length = 6) # etc.
+lg.dot.size <- vector(mode = "list", length = 6) # etc.
+lg.dot.size <- lapply(lg.dot.size, as.numeric) # etc.
+lg.dot.border.size <- vector(mode = "list", length = 6) # etc.
+lg.dot.border.size <- lapply(lg.dot.border.size, as.numeric) # etc.
+lg.dot.border.color <- vector(mode = "list", length = 6) # etc.
+lg.line.size <- vector(mode = "list", length = 6) # etc.
+lg.line.size <- lapply(lg.line.size, as.numeric) # etc.
+lg.line.type <- vector(mode = "list", length = 6) # etc.
+lg.alpha <- vector(mode = "list", length = 6) # etc.
+lg.alpha <- lapply(lg.alpha, as.numeric) # etc.
+for(i1 in 1:length(data1)){
+if(geom[[i1]] == "geom_point"){
+point.count <- point.count + 1
+if(point.count== 1L){
+fin.lg.disp[[1]] <- legend.disp[[point.count + line.count]]
+lg.order[[1]] <- point.count + line.count
+lg.color[[1]] <- color[[i1]] # if color == NULL -> NULL
+lg.dot.shape[[1]] <- dot.shape[[i1]]
+lg.dot.size[[1]] <- dot.size[[i1]]
+lg.dot.border.size[[1]] <- dot.border.size[[i1]]
+lg.dot.border.color[[1]] <- dot.border.color[[i1]] # if dot.border.color == NULL -> NULL
+if(plot == TRUE & fin.lg.disp[[1]] == TRUE & dot.shape[[1]] %in% 0:14 & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list())== 0L & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE DOTS (DOT LAYER NUMBER ", point.count, ") IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+lg.alpha[[1]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
+}else{
+lg.alpha[[1]] <- alpha[[i1]]
+}
+class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
+for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same
+tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ]
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = scatter.kind[[i1]]))(data = tempo.data.frame, mapping = ggplot2::aes_string(x = x[[i1]], y = y[[i1]], fill = categ[[i1]]), shape = dot.shape[[i1]], size = dot.size[[i1]], stroke = dot.border.size[[i1]], color = if(dot.shape[[i1]] %in% 21:24 & ! is.null(dot.border.color)){dot.border.color[[i1]]}else{color[[i1]][i5]}, alpha = alpha[[i1]], show.legend = if(i5== 1L){TRUE}else{FALSE})) # WARNING: a single color allowed for color argument outside aesthetic, but here a single color for border --> loop could be inactivated but kept for commodity # legend.show option do not remove the legend, only the aesthetic of the legend (dot, line, etc.). Used here to avoid multiple layers of legend which corrupt transparency
+coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
+}
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_fill_manual(name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = as.character(color[[i1]]), breaks = class.categ)) # values are the values of fill, breaks reorder the classes according to class.categ in the legend, order argument of guide_legend determines the order of the different aesthetics in the legend (not order of classes). See guide_legend settings of scale_..._manual below
+}
+if(point.count== 2L){
+fin.lg.disp[[2]] <- legend.disp[[point.count + line.count]]
+lg.order[[2]] <- point.count + line.count
+lg.color[[2]] <- color[[i1]] # if color == NULL -> NULL
+lg.dot.shape[[2]] <- dot.shape[[i1]]
+lg.dot.size[[2]] <- dot.size[[i1]]
+lg.dot.border.size[[2]] <- dot.border.size[[i1]]
+lg.dot.border.color[[2]] <- dot.border.color[[i1]] # if dot.border.color == NULL -> NULL
+if(plot == TRUE & fin.lg.disp[[2]] == TRUE & dot.shape[[2]] %in% 0:14 & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list())== 0L & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE DOTS (DOT LAYER NUMBER ", point.count, ") IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+lg.alpha[[2]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
+}else{
+lg.alpha[[2]] <- alpha[[i1]]
+}
+class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
+for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same
+tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ]
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = scatter.kind[[i1]]))(data = tempo.data.frame, mapping = ggplot2::aes_string(x = x[[i1]], y = y[[i1]], shape = categ[[i1]]), size = dot.size[[i1]], stroke = dot.border.size[[i1]], fill = color[[i1]][i5], color = if(dot.shape[[i1]] %in% 21:24 & ! is.null(dot.border.color)){dot.border.color[[i1]]}else{color[[i1]][i5]}, alpha = alpha[[i1]], show.legend = FALSE)) # WARNING: a single color allowed for fill argument outside aesthetic, hence the loop # legend.show option do not remove the legend, only the aesthetic of the legend (dot, line, etc.). Used here to avoid multiple layers of legend which corrupt transparency
+coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
+}
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_shape_manual(name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(dot.shape[[i1]], length(color[[i1]])), breaks = class.categ)) # values are the values of shape, breaks reorder the classes according to class.categ in the legend. See guide_legend settings of scale_..._manual below
+
+}
+if(point.count== 3L){
+fin.lg.disp[[3]] <- legend.disp[[point.count + line.count]]
+lg.order[[3]] <- point.count + line.count
+lg.color[[3]] <- color[[i1]] # if color == NULL -> NULL
+lg.dot.shape[[3]] <- dot.shape[[i1]]
+lg.dot.size[[3]] <- dot.size[[i1]]
+lg.dot.border.size[[3]] <- dot.border.size[[i1]]
+lg.dot.border.color[[3]] <- dot.border.color[[i1]] # if dot.border.color == NULL -> NULL
+if(plot == TRUE & fin.lg.disp[[3]] == TRUE & dot.shape[[3]] %in% 0:14 & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list())== 0L & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE DOTS (DOT LAYER NUMBER ", point.count, ") IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+lg.alpha[[3]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
+}else{
+lg.alpha[[3]] <- alpha[[i1]]
+}
+class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
+for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same
+tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ]
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = scatter.kind[[i1]]))(data = tempo.data.frame, mapping = ggplot2::aes_string(x = x[[i1]], y = y[[i1]], stroke = categ[[i1]]), shape = dot.shape[[i1]], size = dot.size[[i1]], fill = color[[i1]][i5], stroke = dot.border.size[[i1]], color = if(dot.shape[[i1]] %in% 21:24 & ! is.null(dot.border.color)){dot.border.color[[i1]]}else{color[[i1]][i5]}, alpha = alpha[[i1]], show.legend = FALSE)) # WARNING: a single color allowed for color argument outside aesthetic, hence the loop # legend.show option do not remove the legend, only the aesthetic of the legend (dot, line, etc.). Used here to avoid multiple layers of legend which corrupt transparency
+coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
+}
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "stroke", name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(dot.border.size[[i1]], length(color[[i1]])), breaks = class.categ)) # values are the values of stroke, breaks reorder the classes according to class.categ in the legend. See guide_legend settings of scale_..._manual below
+
+}
+}else{
+line.count <- line.count + 1
+if(line.count== 1L){
+fin.lg.disp[[4]] <- legend.disp[[point.count + line.count]]
+lg.order[[4]] <- point.count + line.count
+lg.color[[4]] <- color[[i1]] # if color == NULL -> NULL
+lg.line.size[[4]] <- line.size[[i1]]
+lg.line.type[[4]] <- line.type[[i1]]
+if(plot == TRUE & fin.lg.disp[[4]] == TRUE & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list())== 0L & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE LINES (LINE LAYER NUMBER ", line.count, ") IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+lg.alpha[[4]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
+}else{
+lg.alpha[[4]] <- alpha[[i1]]
+}
+class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
+for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same
+tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ]
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste0("ggplot2::", # no CR here te0("ggpl
+ifelse(geom[[i1]] == 'geom_stick', 'geom_segment', geom[[i1]]), # geom_segment because geom_stick converted to geom_segment for plotting
+"(data = tempo.data.frame, mapping = ggplot2::aes(x = ",
+x[[i1]],
+ifelse(geom[[i1]] == 'geom_stick', ", yend = ", ", y = "),
+y[[i1]],
+if(geom[[i1]] == 'geom_stick'){paste0(', xend = ', x[[i1]], ', y = ', ifelse(is.null(geom.stick.base), y.lim[1], geom.stick.base[[i1]]))},
+", linetype = ",
+categ[[i1]],
+"), color = \"",
+color[[i1]][i5],
+"\", size = ",
+line.size[[i1]],
+ifelse(geom[[i1]] == 'geom_path', ', lineend = \"round\"', ''),
+ifelse(geom[[i1]] == 'geom_step', paste0(', direction = \"', geom.step.dir[[i1]], '\"'), ''),
+", alpha = ",
+alpha[[i1]],
+", show.legend = ",
+ifelse(i5== 1L, TRUE, FALSE),
+")"
+)))) # WARNING: a single color allowed for color argument outside aesthetic, hence the loop # legend.show option do not remove the legend, only the aesthetic of the legend (dot, line, etc.). Used here to avoid multiple layers of legend which corrupt transparency
+coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
+}
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "linetype", name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(line.type[[i1]], length(color[[i1]])), breaks = class.categ)) # values are the values of linetype. 1 means solid. Regarding the alpha bug, I have tried different things without success: alpha in guide alone, in geom alone, in both, with different values, breaks reorder the classes according to class.categ in the legend
+}
+if(line.count== 2L){
+fin.lg.disp[[5]] <- legend.disp[[point.count + line.count]]
+lg.order[[5]] <- point.count + line.count
+lg.color[[5]] <- color[[i1]] # if color == NULL -> NULL
+lg.line.size[[5]] <- line.size[[i1]]
+lg.line.type[[5]] <- line.type[[i1]]
+if(plot == TRUE & fin.lg.disp[[5]] == TRUE & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list())== 0L & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE LINES (LINE LAYER NUMBER ", line.count, ") IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+lg.alpha[[5]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
+}else{
+lg.alpha[[5]] <- alpha[[i1]]
+}
+class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
+for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same
+tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ]
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste0("ggplot2::", # no CR here te0("ggpl
+ifelse(geom[[i1]] == 'geom_stick', 'geom_segment', geom[[i1]]), # geom_segment because geom_stick converted to geom_segment for plotting
+"(data = tempo.data.frame, mapping = ggplot2::aes(x = ",
+x[[i1]],
+ifelse(geom[[i1]] == 'geom_stick', ", yend = ", ", y = "),
+y[[i1]],
+if(geom[[i1]] == 'geom_stick'){paste0(', xend = ', x[[i1]], ', y = ', ifelse(is.null(geom.stick.base), y.lim[1], geom.stick.base[[i1]]))},
+", alpha = ",
+categ[[i1]],
+"), color = \"",
+color[[i1]][i5],
+"\", size = ",
+line.size[[i1]],
+", linetype = ",
+ifelse(is.numeric(line.type[[i1]]), "", "\""),
+line.type[[i1]],
+ifelse(is.numeric(line.type[[i1]]), "", "\""),
+ifelse(geom[[i1]] == 'geom_path', ', lineend = \"round\"', ''),
+ifelse(geom[[i1]] == 'geom_step', paste0(', direction = \"', geom.step.dir[[i1]], '\"'), ''),
+", show.legend = FALSE)"
+)))) # WARNING: a single color allowed for color argument outside aesthetic, hence the loop # legend.show option do not remove the legend, only the aesthetic of the legend (dot, line, etc.). Used here to avoid multiple layers of legend which corrupt transparency
+coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
+}
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "alpha", name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(alpha[[i1]], length(color[[i1]])), breaks = class.categ)) # values are the values of linetype. 1 means solid. Regarding the alpha bug, I have tried different things without success: alpha in guide alone, in geom alone, in both, with different values, breaks reorder the classes according to class.categ in the legend
+}
+if(line.count== 3L){
+fin.lg.disp[[6]] <- legend.disp[[point.count + line.count]]
+lg.order[[6]] <- point.count + line.count
+lg.color[[6]] <- color[[i1]] # if color == NULL -> NULL
+lg.line.size[[6]] <- line.size[[i1]]
+lg.line.type[[6]] <- line.type[[i1]]
+if(plot == TRUE & fin.lg.disp[[6]] == TRUE & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list())== 0L & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE LINES (LINE LAYER NUMBER ", line.count, ") IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+lg.alpha[[6]] <- 1 # to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
+}else{
+lg.alpha[[6]] <- alpha[[i1]]
+}
+class.categ <- levels(factor(data1[[i1]][, categ[[i1]]]))
+for(i5 in 1:length(color[[i1]])){ # or length(class.categ). It is the same because already checked that lengths are the same
+tempo.data.frame <- data1[[i1]][data1[[i1]][, categ[[i1]]] == class.categ[i5], ]
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = paste0("ggplot2::", # no CR here te0("ggpl
+ifelse(geom[[i1]] == 'geom_stick', 'geom_segment', geom[[i1]]), # geom_segment because geom_stick converted to geom_segment for plotting
+"(data = tempo.data.frame, mapping = ggplot2::aes(x = ",
+x[[i1]],
+ifelse(geom[[i1]] == 'geom_stick', ", yend = ", ", y = "),
+y[[i1]],
+if(geom[[i1]] == 'geom_stick'){paste0(', xend = ', x[[i1]], ', y = ', ifelse(is.null(geom.stick.base), y.lim[1], geom.stick.base[[i1]]))},
+", size = ",
+categ[[i1]],
+"), color = \"",
+color[[i1]][i5],
+"\", linetype = ",
+ifelse(is.numeric(line.type[[i1]]), "", "\""),
+line.type[[i1]],
+ifelse(is.numeric(line.type[[i1]]), "", "\""),
+ifelse(geom[[i1]] == 'geom_path', ', lineend = \"round\"', ''),
+ifelse(geom[[i1]] == 'geom_step', paste0(', direction = \"', geom.step.dir[[i1]], '\"'), ''),
+", alpha = ",
+alpha[[i1]],
+", show.legend = FALSE)"
+)))) # WARNING: a single color allowed for color argument outside aesthetic, hence the loop # legend.show option do not remove the legend, only the aesthetic of the legend (dot, line, etc.). Used here to avoid multiple layers of legend which corrupt transparency
+coord.names <- c(coord.names, paste0(geom[[i1]], ".", class.categ[i5]))
+}
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "size", name = if(is.null(legend.name)){NULL}else{legend.name[[i1]]}, values = rep(line.size[[i1]], length(color[[i1]])), breaks = class.categ)) # values are the values of linetype. 1 means solid. Regarding the alpha bug, I have tried different things without success: alpha in guide alone, in geom alone, in both, breaks reorder the classes according to class.categ in the legend
+}
+}
+}
+# end loop part
+
+
+
+
+# legend display
+tempo.legend.final <- 'ggplot2::guides(
+fill = if(fin.lg.disp[[1]] == TRUE){
+ggplot2::guide_legend(
+order = lg.order[[1]],
+override.aes = list(
+fill = lg.color[[1]],
+colour = if(lg.dot.shape[[1]] %in% 21:24 & ! is.null(dot.border.color)){lg.dot.border.color[[1]]}else{lg.color[[1]]}, # lg.dot.shape[[1]] %in% 21:24 are the only one that can be filled
+shape = lg.dot.shape[[1]],
+size = lg.dot.size[[1]],
+stroke = lg.dot.border.size[[1]],
+alpha = lg.alpha[[1]],
+linetype = 0
+)
+)
+}else{
+"none"
+},
+shape = if(fin.lg.disp[[2]] == TRUE){
+ggplot2::guide_legend(
+order = lg.order[[2]],
+override.aes = list(
+fill = lg.color[[2]],
+colour = if(lg.dot.shape[[2]] %in% 21:24 & ! is.null(dot.border.color)){lg.dot.border.color[[2]]}else{lg.color[[2]]}, # lg.dot.shape[[2]] %in% 21:24 are the only one that can be filled
+shape = lg.dot.shape[[2]],
+size = lg.dot.size[[2]],
+stroke = lg.dot.border.size[[2]],
+alpha = lg.alpha[[2]],
+linetype = 0
+)
+)
+}else{
+"none"
+},
+stroke = if(fin.lg.disp[[3]] == TRUE){
+ggplot2::guide_legend(
+order = lg.order[[3]],
+override.aes = list(
+fill = lg.color[[3]],
+colour = if(lg.dot.shape[[3]] %in% 21:24 & ! is.null(dot.border.color)){lg.dot.border.color[[3]]}else{lg.color[[3]]}, # lg.dot.shape[[3]] %in% 21:24 are the only one that can be filled
+shape = lg.dot.shape[[3]],
+size = lg.dot.size[[3]],
+stroke = lg.dot.border.size[[3]],
+alpha = lg.alpha[[3]],
+linetype = 0
+)
+)
+}else{
+"none"
+},
+linetype = if(fin.lg.disp[[4]] == TRUE){
+ggplot2::guide_legend(
+order = lg.order[[4]],
+override.aes = list(
+color = lg.color[[4]],
+size = lg.line.size[[4]],
+linetype = lg.line.type[[4]],
+alpha = lg.alpha[[4]],
+shape = NA
+)
+)
+}else{
+"none"
+},
+alpha = if(fin.lg.disp[[5]] == TRUE){
+ggplot2::guide_legend(
+order = lg.order[[5]],
+override.aes = list(
+color = lg.color[[5]],
+size = lg.line.size[[5]],
+linetype = lg.line.type[[5]],
+alpha = lg.alpha[[5]],
+shape = NA
+)
+)
+}else{
+"none"
+},
+size = if(fin.lg.disp[[6]] == TRUE){
+ggplot2::guide_legend(
+order = lg.order[[6]],
+override.aes = list(
+color = lg.color[[6]],
+size = lg.line.size[[6]],
+linetype = lg.line.type[[6]],
+alpha = lg.alpha[[6]],
+shape = NA
+)
+)
+}else{
+"none"
+}
+)' # clip = "off" to have secondary ticks outside plot region does not work
+if( ! is.null(legend.width)){
+if(any(unlist(legend.disp))){ # means some TRUE
+tempo.graph.info <- suppressMessages(ggplot2::ggplot_build(eval(parse(text = paste0(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), ' + ', tempo.legend.final))))) # will be recovered later again, when ylim will be considered
+legend.final <- fun_gg_get_legend(ggplot_built = tempo.graph.info, fun.name = function.name) # get legend
+fin.lg.disp[] <- FALSE # remove all the legends. Must be done even if fin.lg.disp is not appearing in the code thenafter. Otherwise twice the legend
+if(is.null(legend.final) & plot == TRUE){ # even if any(unlist(legend.disp)) is TRUE
+legend.final <- fun_gg_empty_graph() # empty graph instead of legend
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") LEGEND REQUESTED (NON-NULL categ ARGUMENT OR legend.show ARGUMENT SET TO TRUE)\nBUT IT SEEMS THAT THE PLOT HAS NO LEGEND -> EMPTY LEGEND SPACE CREATED BECAUSE OF THE NON-NULL legend.width ARGUMENT\n")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}else if(plot == TRUE){ # means all FALSE
+legend.final <- ggplot2::ggplot()+ggplot2::theme_void() # empty graph instead of legend
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") LEGEND REQUESTED (NON-NULL categ ARGUMENT OR legend.show ARGUMENT SET TO TRUE)\nBUT IT SEEMS THAT THE PLOT HAS NO LEGEND -> EMPTY LEGEND SPACE CREATED BECAUSE OF THE NON-NULL legend.width ARGUMENT\n")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+}
+if( ! any(unlist(legend.disp))){
+fin.lg.disp[] <- FALSE # remove all the legends. Must be done even if fin.lg.disp is not appearing in the code thenafter. Otherwise twice the legend
+}
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), eval(parse(text = tempo.legend.final)))
+# end legend display
+
+
+
+
+
+# scale management
+tempo.coord <- suppressMessages(ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ", ' + ggplot2::scale_x_continuous(expand = c(0, 0), limits = sort(x.lim), oob = scales::rescale_none) + ggplot2::scale_y_continuous(expand = c(0, 0), limits = sort(y.lim), oob = scales::rescale_none)'))))$layout$panel_params[[1]]) # here I do not need the x-axis and y-axis orientation, I just need the number of main ticks
+# x.second.tick.positions # coordinates of secondary ticks (only if x.second.tick.nb argument is non-null or if x.log argument is different from "no")
+if(x.log != "no"){ # integer main ticks for log2 and log10
+tempo.scale <- (as.integer(min(x.lim, na.rm = TRUE)) - 1):(as.integer(max(x.lim, na.rm = TRUE)) + 1)
+}else{
+tempo <- if(is.null(attributes(tempo.coord$x$breaks))){tempo.coord$x$breaks}else{unlist(attributes(tempo.coord$x$breaks))}
+if(all(is.na(tempo))){
+tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nONLY NA IN tempo.coord$x$breaks")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+if(length(unique(x.lim)) <= 1){
+tempo.cat <- paste0("ERROR IN ", function.name, "\nIT SEEMS THAT X-AXIS VALUES HAVE A NULL RANGE: ", paste(x.lim, collapse = " "), "\nPLEASE, USE THE x.lim ARGUMENT WITH 2 DIFFERENT VALUES TO SOLVE THIS")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+tempo.scale <- fun_scale(lim = x.lim, n = ifelse(is.null(x.tick.nb), length(tempo[ ! is.na(tempo)]), x.tick.nb)) # in ggplot 3.3.0, tempo.coord$x.major_source replaced by tempo.coord$x$breaks. If fact: n = ifelse(is.null(x.tick.nb), length(tempo[ ! is.na(tempo)]), x.tick.nb)) replaced by n = ifelse(is.null(x.tick.nb), 4, x.tick.nb))
+}
+}
+x.second.tick.values <- NULL
+x.second.tick.pos <- NULL
+if(x.log != "no"){
+tempo <- fun_inter_ticks(lim = x.lim, log = x.log)
+x.second.tick.values <- tempo$values
+x.second.tick.pos <- tempo$coordinates
+# if(vertical == TRUE){ # do not remove in case the bug is fixed
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
+geom = "segment",
+x = x.second.tick.pos,
+xend = x.second.tick.pos,
+y = if(diff(y.lim) > 0){tempo.coord$y.range[1]}else{tempo.coord$y.range[2]},
+yend = if(diff(y.lim) > 0){tempo.coord$y.range[1] + abs(diff(tempo.coord$y.range)) / 80}else{tempo.coord$y.range[2] - abs(diff(tempo.coord$y.range)) / 80}
+))
+# }else{ # not working because of the ggplot2 bug
+# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(geom = "segment", y = x.second.tick.pos, yend = x.second.tick.pos, x = tempo.coord$x.range[1], xend = tempo.coord$x.range[1] + diff(tempo.coord$x.range) / 80))
+# }
+coord.names <- c(coord.names, "x.second.tick.positions")
+}else if(( ! is.null(x.second.tick.nb)) & x.log == "no"){
+# if(x.second.tick.nb > 0){ #inactivated because already checked before
+if(length(tempo.scale) < 2){
+tempo.cat1 <- c("x.tick.nb", "x.second.tick.nb")
+tempo.cat2 <- sapply(list(x.tick.nb, x.second.tick.nb), FUN = paste0, collapse = " ")
+tempo.sep <- sapply(mapply(" ", max(nchar(tempo.cat1)) - nchar(tempo.cat1) + 3, FUN = rep, SIMPLIFY = FALSE), FUN = paste0, collapse = "")
+tempo.cat <- paste0("ERROR IN ", function.name, "\nTHE NUMBER OF GENERATED TICKS FOR THE X-AXIS IS NOT CORRECT: ", length(tempo.scale), "\nUSING THESE ARGUMENT SETTINGS (NO DISPLAY MEANS NULL VALUE):\n", paste0(tempo.cat1, tempo.sep, tempo.cat2, collapse = "\n"), "\nPLEASE, TEST OTHER VALUES")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+}else{
+tempo <- fun_inter_ticks(lim = x.lim, log = x.log, breaks = tempo.scale, n = x.second.tick.nb)
+}
+x.second.tick.values <- tempo$values
+x.second.tick.pos <- tempo$coordinates
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
+geom = "segment",
+x = x.second.tick.pos,
+xend = x.second.tick.pos,
+y = if(diff(y.lim) > 0){tempo.coord$y.range[1]}else{tempo.coord$y.range[2]},
+yend = if(diff(y.lim) > 0){tempo.coord$y.range[1] + abs(diff(tempo.coord$y.range)) / 80}else{tempo.coord$y.range[2] - abs(diff(tempo.coord$y.range)) / 80}
+))
+coord.names <- c(coord.names, "x.second.tick.positions")
+}
+# for the ggplot2 bug with x.log, this does not work: eval(parse(text = ifelse(vertical == FALSE & x.log == "log10", "ggplot2::scale_x_continuous", "ggplot2::scale_x_continuous")))
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_x_continuous(
+breaks = tempo.scale,
+minor_breaks = x.second.tick.pos,
+labels = if(x.log == "log10"){scales::trans_format("identity", scales::math_format(10^.x))}else if(x.log == "log2"){scales::trans_format("identity", scales::math_format(2^.x))}else if(x.log == "no"){ggplot2::waiver()}else{tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 10") ; stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)},
+expand = c(0, 0), # remove space after after axis limits
+limits = sort(x.lim), # NA indicate that limits must correspond to data limits but xlim() already used
+oob = scales::rescale_none,
+trans = ifelse(diff(x.lim) < 0, "reverse", "identity") # equivalent to ggplot2::scale_x_reverse() but create the problem of x-axis label disappearance with x.lim decreasing. Thus, do not use. Use xlim() below and after this
+))
+# end x.second.tick.positions
+# y.second.tick.positions # coordinates of secondary ticks (only if y.second.tick.nb argument is non-null or if y.log argument is different from "no")
+if(y.log != "no"){ # integer main ticks for log2 and log10
+tempo.scale <- (as.integer(min(y.lim, na.rm = TRUE)) - 1):(as.integer(max(y.lim, na.rm = TRUE)) + 1)
+}else{
+tempo <- if(is.null(attributes(tempo.coord$y$breaks))){tempo.coord$y$breaks}else{unlist(attributes(tempo.coord$y$breaks))}
+if(all(is.na(tempo))){
+tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nONLY NA IN tempo.coord$y$breaks")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}
+if(length(unique(y.lim)) <= 1){
+tempo.cat <- paste0("ERROR IN ", function.name, "\nIT SEEMS THAT Y-AXIS VALUES HAVE A NULL RANGE: ", paste(y.lim, collapse = " "), "\nPLEASE, USE THE y.lim ARGUMENT WITH 2 DIFFERENT VALUES TO SOLVE THIS")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+tempo.scale <- fun_scale(lim = y.lim, n = ifelse(is.null(y.tick.nb), length(tempo[ ! is.na(tempo)]), y.tick.nb)) # in ggplot 3.3.0, tempo.coord$y.major_source replaced by tempo.coord$y$breaks. If fact: n = ifelse(is.null(y.tick.nb), length(tempo[ ! is.na(tempo)]), y.tick.nb)) replaced by n = ifelse(is.null(y.tick.nb), 4, y.tick.nb))
+}
+}
+y.second.tick.values <- NULL
+y.second.tick.pos <- NULL
+if(y.log != "no"){
+tempo <- fun_inter_ticks(lim = y.lim, log = y.log)
+y.second.tick.values <- tempo$values
+y.second.tick.pos <- tempo$coordinates
+# if(vertical == TRUE){ # do not remove in case the bug is fixed
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
+geom = "segment",
+y = y.second.tick.pos,
+yend = y.second.tick.pos,
+x = if(diff(x.lim) > 0){tempo.coord$x.range[1]}else{tempo.coord$x.range[2]},
+xend = if(diff(x.lim) > 0){tempo.coord$x.range[1] + abs(diff(tempo.coord$x.range)) / 80}else{tempo.coord$x.range[2] - abs(diff(tempo.coord$x.range)) / 80}
+))
+# }else{ # not working because of the ggplot2 bug
+# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(geom = "segment", x = y.second.tick.pos, xend = y.second.tick.pos, y = tempo.coord$y.range[1], yend = tempo.coord$y.range[1] + diff(tempo.coord$y.range) / 80))
+# }
+coord.names <- c(coord.names, "y.second.tick.positions")
+}else if(( ! is.null(y.second.tick.nb)) & y.log == "no"){
+# if(y.second.tick.nb > 0){ #inactivated because already checked before
+if(length(tempo.scale) < 2){
+tempo.cat1 <- c("y.tick.nb", "y.second.tick.nb")
+tempo.cat2 <- sapply(list(y.tick.nb, y.second.tick.nb), FUN = paste0, collapse = " ")
+tempo.sep <- sapply(mapply(" ", max(nchar(tempo.cat1)) - nchar(tempo.cat1) + 3, FUN = rep, SIMPLIFY = FALSE), FUN = paste0, collapse = "")
+tempo.cat <- paste0("ERROR IN ", function.name, "\nTHE NUMBER OF GENERATED TICKS FOR THE Y-AXIS IS NOT CORRECT: ", length(tempo.scale), "\nUSING THESE ARGUMENT SETTINGS (NO DISPLAY MEANS NULL VALUE):\n", paste0(tempo.cat1, tempo.sep, tempo.cat2, collapse = "\n"), "\nPLEASE, TEST OTHER VALUES")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+}else{
+tempo <- fun_inter_ticks(lim = y.lim, log = y.log, breaks = tempo.scale, n = y.second.tick.nb)
+}
+y.second.tick.values <- tempo$values
+y.second.tick.pos <- tempo$coordinates
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
+geom = "segment",
+y = y.second.tick.pos,
+yend = y.second.tick.pos,
+x = if(diff(x.lim) > 0){tempo.coord$x.range[1]}else{tempo.coord$x.range[2]},
+xend = if(diff(x.lim) > 0){tempo.coord$x.range[1] + abs(diff(tempo.coord$x.range)) / 80}else{tempo.coord$x.range[2] - abs(diff(tempo.coord$x.range)) / 80}
+))
+coord.names <- c(coord.names, "y.second.tick.positions")
+}
+# for the ggplot2 bug with y.log, this does not work: eval(parse(text = ifelse(vertical == FALSE & y.log == "log10", "ggplot2::scale_x_continuous", "ggplot2::scale_y_continuous")))
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_y_continuous(
+breaks = tempo.scale,
+minor_breaks = y.second.tick.pos,
+labels = if(y.log == "log10"){scales::trans_format("identity", scales::math_format(10^.x))}else if(y.log == "log2"){scales::trans_format("identity", scales::math_format(2^.x))}else if(y.log == "no"){ggplot2::waiver()}else{tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 10") ; stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)},
+expand = c(0, 0), # remove space after axis limits
+limits = sort(y.lim), # NA indicate that limits must correspond to data limits but ylim() already used
+oob = scales::rescale_none,
+trans = ifelse(diff(y.lim) < 0, "reverse", "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
+))
+# end y.second.tick.positions
+assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_cartesian(xlim = x.lim, ylim = y.lim)) # clip = "off" to have secondary ticks outside plot region. The problem is that points out of bounds are also drawn outside the plot region. Thus, I cannot use it # at that stage, x.lim and y.lim not NULL anymore
+# end scale management
+
+
+
+
+# drawing
+fin.plot <- eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))
+grob.save <- NULL
+if(plot == TRUE){
+if( ! is.null(legend.width)){ # any(unlist(legend.disp)) == TRUE removed to have empty legend space # not & any(unlist(fin.lg.disp)) == TRUE here because converted to FALSE
+grob.save <- suppressMessages(suppressWarnings(gridExtra::grid.arrange(fin.plot, legend.final, ncol=2, widths=c(1, legend.width))))
+}else{
+grob.save <- suppressMessages(suppressWarnings(print(fin.plot)))
+}
+}else{
+warn.count <- warn.count + 1
+tempo.warn <- paste0("(", warn.count,") PLOT NOT SHOWN AS REQUESTED")
+warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+}
+# end drawing
+
+
+
+# output
+if(warn.print == TRUE & ! is.null(warn)){
+on.exit(warning(paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE))
+}
+on.exit(exp = options(warning.length = ini.warning.length), add = TRUE)
+if(return == TRUE){
+output <- suppressMessages(ggplot2::ggplot_build(fin.plot))
+# output$data <- output$data[-1] # yes for boxplot but not for scatter # remove the first data because corresponds to the initial empty boxplot
+if(length(output$data) != length(coord.names)){
+tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, ": length(output$data) AND length(coord.names) MUST BE IDENTICAL. CODE HAS TO BE MODIFIED")
+stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+}else{
+names(output$data) <- coord.names
+}
+if(is.null(unlist(removed.row.nb))){
+removed.row.nb <- NULL
+removed.rows <- NULL
+}else{
+for(i3 in 1:length(data1)){
+if( ! is.null(removed.row.nb[[i3]])){
+removed.row.nb[[i3]] <- sort(removed.row.nb[[i3]])
+removed.rows[[i3]] <- data1.ini[[i3]][removed.row.nb[[i3]], ]
+}
+}
+}
+tempo <- output$layout$panel_params[[1]]
+output <- list(
+data = data1,
+removed.row.nb = removed.row.nb,
+removed.rows = removed.rows,
+plot = c(output$data, x.second.tick.values = list(x.second.tick.values), y.second.tick.values = list(y.second.tick.values)),
+panel = facet.categ,
+axes = list(
+x.range = tempo$x.range,
+x.labels = if(is.null(attributes(tempo$x$breaks))){tempo$x$breaks}else{tempo$x$scale$get_labels()}, # is.null(attributes(tempo$x$breaks)) test if it is number (TRUE) or character (FALSE)
+x.positions = if(is.null(attributes(tempo$x$breaks))){tempo$x$breaks}else{unlist(attributes(tempo$x$breaks))},
+y.range = tempo$y.range,
+y.labels = if(is.null(attributes(tempo$y$breaks))){tempo$y$breaks}else{tempo$y$scale$get_labels()},
+y.positions = if(is.null(attributes(tempo$y$breaks))){tempo$y$breaks}else{unlist(attributes(tempo$y$breaks))}
+),
+warn = paste0("\n", warn, "\n\n"),
+ggplot = if(return.ggplot == TRUE){fin.plot}else{NULL}, # fin.plot plots the graph if return == TRUE
+gtable = if(return.gtable == TRUE){grob.save}else{NULL} #
+)
+return(output) # this plots the graph if return.ggplot is TRUE and if no assignment
+}
+# end output
+# end main code
+}
+
+
+
diff --git a/gg_donut.R b/gg_donut.R
new file mode 100644
index 0000000000000000000000000000000000000000..d2a5ff5cf0343a7565a5898db5a9854184d465e5
--- /dev/null
+++ b/gg_donut.R
@@ -0,0 +1,797 @@
+#' @title gg_donut
+#' @description
+#' 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.
+#' @param data1 a dataframe compatible with ggplot2.
+#' @param freq single character string of the data1 column name of the frequencies.
+#' @param categ single character string of the data1 column name of categories (qualitative variable).
+#' @param fill.palette single character string of a palette name (see ?ggplot2::scale_fill_brewer() for the list).Ignored if fill.color is not NULL.
+#' @param 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.
+#' @param hole.size single positive proportion of donut central hole, 0 meaning no hole (pie chart) and 1 no plot (donut with a null thickness).
+#' @param hole.text logical (either TRUE or FALSE). Display the sum of frequencies (column of data1 indicated in the freq argument).
+#' @param hole.text.size single positive numeric value of the title font size in mm. Ignored if hole.text is FALSE
+#' @param 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).
+#' @param title single character string of the graph title.
+#' @param title.text.size single numeric value of the title font size in mm.
+#' @param 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.
+#' @param 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.
+#' @param annotation.size single positive numeric value of the annotation font size in mm. Ignored if annotation is NULL.
+#' @param 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.
+#' @param annotation.force.pull single positive numeric value of the force of attraction between a text label and its corresponding data point. See ?
+#' @param legend.show logical (either TRUE or FALSE). Show legend?.
+#' @param 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.
+#' @param 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.
+#' @param legend.text.size single numeric value of the font size in mm of the legend labels.
+#' @param legend.box.size single numeric value of the size of the legend squares in mm.
+#' @param legend.box.space single numeric value of the space between the legend boxes in mm.
+#' @param 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.
+#' @param legend.add.prop logical (either TRUE or FALSE). add the proportion after the class names in the legend ?
+#' @param add character string allowing to add more ggplot2 features (dots, lines, themes, facet, etc.). Ignored if NULL.
+#' @param return logical (either TRUE or FALSE). Return the graph parameters?
+#' @param 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 gg_donut() function (e.g., a <- 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.
+#' @param 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.
+#' @param 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.
+#' @param 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.
+#' @param 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.
+#' @returns a donut plot if plot argument is TRUE.
+#' @returns 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
+#' @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) ; gg_donut(data1 = obs1, freq = "Km", categ = "Car", annotation = "Country")
+#' @importFrom ggplot2 aes_string
+#' @importFrom ggplot2 annotate
+#' @importFrom ggplot2 coord_polar
+#' @importFrom ggplot2 element_text
+#' @importFrom ggplot2 geom_col
+#' @importFrom ggplot2 ggplot
+#' @importFrom ggplot2 ggplot_build
+#' @importFrom ggplot2 guides
+#' @importFrom ggplot2 guide_legend
+#' @importFrom ggplot2 labs
+#' @importFrom ggplot2 scale_fill_brewer
+#' @importFrom ggplot2 scale_fill_manual
+#' @importFrom ggplot2 scale_x_continuous
+#' @importFrom ggplot2 theme
+#' @importFrom ggplot2 theme_void
+#' @importFrom ggplot2 ylim
+#' @importFrom ggrepel geom_text_repel
+#' @importFrom grDevices colors
+#' @importFrom gridExtra arrangeGrob
+#' @importFrom gridExtra grid.arrange
+#' @importFrom grid unit
+#' @importFrom saferDev::arg_check
+#' @details
+#' - 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)).
+#' -(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 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.
+#' -the call of objects inside the quotes of add can lead to an error if the name of these objects are some of the 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))'
+#' @export
+gg_donut <- function(
+ data1,
+ freq,
+ categ,
+ fill.palette = NULL,
+ fill.color = NULL,
+ hole.size = 0.5,
+ hole.text = TRUE,
+ hole.text.size = 14,
+ border.color = "gray50",
+ border.size = 0.2,
+ title = "",
+ title.text.size = 7,
+ annotation = NULL,
+ annotation.distance = 0,
+ annotation.size = 3,
+ annotation.force = 1,
+ annotation.force.pull = 100,
+ legend.show = TRUE,
+ legend.width = 0.25,
+ 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 = FALSE,
+ return.ggplot = FALSE,
+ return.gtable = TRUE,
+ plot = TRUE,
+ warn.print = TRUE,
+ lib.path = NULL
+){
+ # 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
+ # package name
+ package.name <- "ggcute"
+ # end package name
+ # function name
+ function.name <- base::paste0(base::as.list(base::match.call(expand.dots = FALSE))[[1]], "()") # function name with "()" paste, which split into a vector of three: c("::()", "package()", "function()") if "package::function()" is used.
+ if(function.name[1] == "::()"){
+ function.name <- function.name[3]
+ }
+ arg.names <- base::names(base::formals(fun = base::sys.function(base::sys.parent(n = 2)))) # names of all the arguments
+ arg.user.setting <- base::as.list(base::match.call(expand.dots = FALSE))[-1] # list of the argument settings (excluding default values not provided by the user)
+ # end function name
+ # critical operator checking
+ .base_op_check(external.function.name = function.name)
+ # end critical operator checking
+ # package checking
+ # check of lib.path
+ if( ! base::is.null(lib.path)){
+ if( ! base::all(base::typeof(lib.path) == "character")){ # no na.rm = TRUE with typeof
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE: DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT MUST BE A VECTOR OF CHARACTERS:\n", base::paste(lib.path, collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else if( ! base::all(base::dir.exists(lib.path), na.rm = TRUE)){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
+ tempo.cat <-base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE: DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", base::paste(lib.path, collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ base::.libPaths(new = base::sub(x = lib.path, pattern = "/$|\\\\$", replacement = "")) # .libPaths(new = ) add path to default path. BEWARE: .libPaths() does not support / at the end of a submitted path. Thus check and replace last / or \\ in path
+ lib.path <- base::.libPaths()
+ }
+ }else{
+ lib.path <- base::.libPaths() # .libPaths(new = lib.path) # or .libPaths(new = c(.libPaths(), lib.path))
+ }
+ # end check of lib.path
+
+
+ # check of the required function from the required packages
+ .pack_and_function_check(
+ fun = base::c(
+ "ggplot2::aes_string",
+ "ggplot2::annotate",
+ "ggplot2::coord_polar",
+ "ggplot2::element_text",
+ "ggplot2::geom_col",
+ "ggplot2::ggplot",
+ "ggplot2::ggplot_build",
+ "ggplot2::guides",
+ "ggplot2::guide_legend",
+ "ggplot2::labs",
+ "ggplot2::scale_fill_brewer",
+ "ggplot2::scale_fill_manual",
+ "ggplot2::scale_x_continuous",
+ "ggplot2::theme",
+ "ggplot2::theme_void",
+ "ggplot2::ylim",
+ "ggrepel::geom_text_repel",
+ "grDevices::colors",
+ "gridExtra::arrangeGrob",
+ "gridExtra::grid.arrange",
+ "grid::unit",
+ "saferDev::arg_check"
+ ),
+ lib.path = lib.path,
+ external.function.name = function.name
+ )
+ # end check of the required function from the required packages
+ # end package checking
+
+ # argument primary checking
+ # arg with no default values
+ mandat.args <- base::c(
+ "data1",
+ "freq",
+ "categ"
+ )
+ tempo <- base::eval(base::parse(text = base::paste0("base::missing(", base::paste0(mandat.args, collapse = ") | base::missing("), ")")))
+ if(base::any(tempo)){ # normally no NA for missing() output
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE\nFOLLOWING ARGUMENT", base::ifelse(base::sum(tempo, na.rm = TRUE) > 1, "S HAVE", "HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", base::paste0(mandat.args, collapse = "\n"))
+ base::stop(base::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 checking with arg_check()
+ # argument checking
+ argum.check <- NULL #
+ text.check <- NULL #
+ checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
+ ee <- base::expression(argum.check <- base::c(argum.check, tempo$problem) , text.check <- base::c(text.check, tempo$text) , checked.arg.names <- base::c(checked.arg.names, tempo$object.name))
+ tempo <- saferDev::arg_check(data = data1, class = "data.frame", na.contain = TRUE, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = freq, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = categ, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ if( ! base::is.null(fill.palette)){
+ tempo <- saferDev::arg_check(data = fill.palette, options = base::c("BrBG", "PiYG", "PRGn", "PuOr", "RdBu", "RdGy", "RdYlBu", "RdYlGn", "Spectral", "Accent", "Dark2", "Paired", "Pastel1", "Pastel2", "Set1", "Set2", "Set3", "Blues", "BuGn", "BuPu", "GnBu", "Greens", "Greys", "Oranges", "OrRd", "PuBu", "PuBuGn", "PuRd", "Purples", "RdPu", "Reds", "YlGn", "YlGnBu", "YlOrBr", "YlOrRd"), length = 1, fun.name = function.name) ; base::eval(ee)
+ }else{
+ # no saferDev::arg_check test here, it is just for checked.arg.names
+ tempo <- saferDev::arg_check(data = fill.palette, class = "vector")
+ checked.arg.names <- base::c(checked.arg.names, tempo$object.name)
+ }
+ if( ! base::is.null(fill.color)){
+ tempo1 <- saferDev::arg_check(data = fill.color, class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name)
+ tempo2 <- saferDev::arg_check(data = fill.color, class = "factor", na.contain = TRUE, fun.name = function.name)
+ tempo3 <- saferDev::arg_check(data = fill.color, class = "integer", double.as.integer.allowed = TRUE, na.contain = TRUE, neg.values = FALSE, fun.name = function.name) # not need to test inf with integers
+ if(tempo1$problem == TRUE & tempo2$problem == TRUE & tempo3$problem == TRUE){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nfill.color ARGUMENT MUST BE A VECTOR OF (1) HEXADECIMAL COLOR STRINGS STARTING BY #, OR (2) COLOR NAMES GIVEN BY colors(), OR (3) POSITIVE INTEGER VALUES")
+ text.check <- base::c(text.check, tempo.cat)
+ argum.check <- base::c(argum.check, TRUE)
+ checked.arg.names <- base::c(checked.arg.names, tempo1$object.name)
+ }else if(tempo3$problem == FALSE & base::any(base::is.infinite(fill.color))){ # is.infinite() deals with NA as FALSE
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nfill.color ARGUMENT CANNOT CONTAIN Inf VALUES AMONG POSITIVE INTEGER VALUES")
+ text.check <- base::c(text.check, tempo.cat)
+ argum.check <- base::c(argum.check, TRUE)
+ checked.arg.names <- base::c(checked.arg.names, tempo1$object.name)
+ }else if(tempo3$problem == FALSE & base::any(fill.color == 0, na.rm = TRUE)){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nfill.color ARGUMENT CANNOT CONTAIN 0 AMONG POSITIVE INTEGER VALUES")
+ text.check <- base::c(text.check, tempo.cat)
+ argum.check <- base::c(argum.check, TRUE)
+ checked.arg.names <- base::c(checked.arg.names, tempo1$object.name)
+ }
+ }
+ tempo <- saferDev::arg_check(data = hole.size, prop = TRUE, length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = hole.text, class = "logical", length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = hole.text.size, class = "vector", mode = "numeric", neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo1 <- saferDev::arg_check(data = border.color, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name)
+ tempo2 <- saferDev::arg_check(data = border.color, class = "integer", double.as.integer.allowed = TRUE, neg.values = FALSE, na.contain = FALSE, length = 1, fun.name = function.name) # not need to test inf with integers
+ if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nborder.color ARGUMENT MUST BE A SINGLE CHARACTER STRING OR POSITIVE INTEGER")
+ text.check <- base::c(text.check, tempo.cat)
+ argum.check <- base::c(argum.check, TRUE)
+ checked.arg.names <- base::c(checked.arg.names, tempo1$object.name)
+ }
+ tempo <- saferDev::arg_check(data = border.size, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = title, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = title.text.size, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ if( ! base::is.null(annotation)){
+ tempo <- saferDev::arg_check(data = annotation, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = annotation.distance, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = annotation.size, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = annotation.force, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = annotation.force.pull, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ }else{
+ # no saferDev::arg_check test here, it is just for checked.arg.names
+ tempo <- saferDev::arg_check(data = annotation, class = "vector")
+ checked.arg.names <- base::c(checked.arg.names, tempo$object.name)
+ }
+ tempo <- saferDev::arg_check(data = legend.show, class = "logical", length = 1, fun.name = function.name) ; base::eval(ee)
+ if( ! base::is.null(legend.width)){
+ tempo <- saferDev::arg_check(data = legend.width, prop = TRUE, length = 1, fun.name = function.name) ; base::eval(ee)
+ }else{
+ # no saferDev::arg_check test here, it is just for checked.arg.names
+ tempo <- saferDev::arg_check(data = legend.width, class = "vector")
+ checked.arg.names <- base::c(checked.arg.names, tempo$object.name)
+ }
+ if( ! base::is.null(legend.name)){
+ tempo <- saferDev::arg_check(data = legend.name, class = "vector", mode = "character", na.contain = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ }else{
+ # no saferDev::arg_check test here, it is just for checked.arg.names
+ tempo <- saferDev::arg_check(data = legend.name, class = "vector")
+ checked.arg.names <- c(checked.arg.names, tempo$object.name)
+ }
+ tempo <- saferDev::arg_check(data = legend.text.size, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = legend.box.size, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = legend.box.space, class = "vector", mode = "numeric", na.contain = FALSE, neg.values = FALSE, inf.values = FALSE, length = 1, fun.name = function.name) ; base::eval(ee)
+ if( ! base::is.null(legend.limit)){
+ tempo <- saferDev::arg_check(data = legend.limit, prop = TRUE, length = 1, fun.name = function.name) ; base::eval(ee)
+ }else{
+ # no saferDev::arg_check test here, it is just for checked.arg.names
+ tempo <- saferDev::arg_check(data = legend.limit, class = "vector")
+ checked.arg.names <- base::c(checked.arg.names, tempo$object.name)
+ }
+ tempo <- saferDev::arg_check(data = legend.add.prop, class = "logical", length = 1, fun.name = function.name) ; base::eval(ee)
+ if( ! base::is.null(add)){
+ tempo <- saferDev::arg_check(data = add, class = "vector", mode = "character", length = 1, fun.name = function.name) ; base::eval(ee)
+ }else{
+ # no saferDev::arg_check test here, it is just for checked.arg.names
+ tempo <- saferDev::arg_check(data = add, class = "vector")
+ checked.arg.names <- base::c(checked.arg.names, tempo$object.name)
+ }
+ tempo <- saferDev::arg_check(data = return, class = "logical", length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = return.ggplot, class = "logical", length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = return.gtable, class = "logical", length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = plot, class = "logical", length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = warn.print, class = "logical", length = 1, fun.name = function.name) ; base::eval(ee)
+ if( ! base::is.null(lib.path)){
+ tempo <- saferDev::arg_check(data = lib.path, class = "vector", mode = "character", fun.name = function.name) ; base::eval(ee) # several possible paths
+ }else{
+ # no saferDev::arg_check test here, it is just for checked.arg.names
+ tempo <- saferDev::arg_check(data = lib.path, class = "vector")
+ checked.arg.names <- base::c(checked.arg.names, tempo$object.name)
+ }
+ if( ! base::is.null(argum.check)){
+ if(base::any(argum.check) == TRUE){
+ base::stop(base::paste0("\n\n================\n\n", base::paste(text.check[argum.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
+ }
+ }
+ # end argument checking with arg_check()
+ # check with r_debugging_tools
+ # source("C:/Users/Gael/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_saferDev::arg_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 saferDev::arg_check()
+ # end check with r_debugging_tools
+ # end argument primary checking
+
+ if( ! (base::all(base::class(arg.user.setting) == "list", na.rm = TRUE) & base::length(arg.user.setting) == 0)){
+ tempo.arg <- base::names(arg.user.setting) # values provided by the user
+ tempo.log <- base::suppressWarnings(base::sapply(base::lapply(base::lapply(tempo.arg, FUN = base::get, envir = base::sys.nframe(), inherits = FALSE), FUN = base::is.na), FUN = base::any)) & base::lapply(base::lapply(tempo.arg, FUN = base::get, envir = base::sys.nframe(), inherits = FALSE), FUN = base::length) == 1L # no argument provided by the user can be just NA
+ if(base::any(tempo.log) == TRUE){ # normally no NA because is.na() used here
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE\n", base::ifelse(base::sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT JUST BE NA:", base::paste0(tempo.arg[tempo.log], collapse = "\n"))
+ base::stop(base::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 <-base::c(
+ "data1",
+ "freq",
+ "categ",
+ # "fill.palette", # inactivated because can be null
+ # "fill.color", # inactivated because can be null
+ "hole.size",
+ "hole.text",
+ "hole.text.size",
+ "border.color",
+ "border.size",
+ "title",
+ "title.text.size",
+ # "annotation", # inactivated because can be null
+ "annotation.distance",
+ "annotation.size",
+ "annotation.force",
+ "annotation.force.pull",
+ "legend.show",
+ # "legend.width", # inactivated because can be null
+ # "legend.name", # inactivated because can be null
+ "legend.text.size",
+ "legend.box.size",
+ "legend.box.space",
+ # "legend.limit", # inactivated because can be null
+ "legend.add.prop",
+ # "add", # inactivated because can be null
+ "return",
+ "return.ggplot",
+ "return.gtable",
+ "plot",
+ "warn.print"
+ # "lib.path" # inactivated because can be null
+ )
+ tempo.log <- base::sapply(base::lapply(tempo.arg, FUN = base::get, envir = base::sys.nframe(), inherits = FALSE), FUN = base::is.null)
+ if(base::any(tempo.log) == TRUE){# normally no NA with is.null()
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE:\n", base::ifelse(base::sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS\n", "THIS ARGUMENT\n"), base::paste0(tempo.arg[tempo.log], collapse = "\n"),"\nCANNOT BE NULL")
+ base::stop(base::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
+ if(base::exists(".Random.seed", envir = .GlobalEnv)){ # if .Random.seed does not exists, it means that no random operation has been performed yet in any R environment
+ tempo.random.seed <- .Random.seed
+ base::on.exit(base::assign(".Random.seed", tempo.random.seed, env = .GlobalEnv))
+ }else{
+ base::on.exit(base::set.seed(NULL)) # inactivate seeding -> return to complete randomness
+ }
+ base::set.seed(1)
+ # end code that protects set.seed() in the global environment
+ # warning initiation
+ ini.warning.length <- base::options()$warning.length
+ base::options(warning.length = 8170)
+ warn <- NULL
+ warn.count <- 0
+ # end warning initiation
+ # other checkings
+ removed.row.nb <- NULL
+ removed.rows <- base::data.frame(stringsAsFactors = FALSE)
+ data1.ini <- data1 # strictly identical to data1
+ if( ! freq %in% base::names(data1)){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nfreq ARGUMENT MUST BE A COLUMN NAME OF THE data1 ARGUMENT")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else{
+ if(base::all(base::is.na(data1[ , freq]) | base::is.infinite(data1[ , freq]))){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nTHE freq COLUMN OF data1 CANNOT BE JUST NA OR Inf")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ tempo <- saferDev::arg_check(data = data1[ , freq], mode = "numeric", neg.values = FALSE, fun.name = function.name)
+ if(tempo$problem == TRUE){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\n", tempo$text)
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ # Inf and NA removal
+ if(base::any(base::is.infinite(data1[, freq]) | base::is.na(data1[, freq]))){
+ warn.count <- warn.count + 1
+ tempo.warn <- base::paste0("(", warn.count,") PRESENCE OF Inf OR NA VALUES IN THE ", freq, " COLUMN OF THE data1 ARGUMENT AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)")
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
+ tempo <- base::which(base::is.infinite(data1.ini[, freq]) | base::is.na(data1.ini[, freq])) # data.ini used for the output
+ removed.row.nb <- base::c(removed.row.nb, tempo)
+ removed.rows <- base::rbind(removed.rows, data1.ini[tempo, ], stringsAsFactors = FALSE) # data.ini used for the output
+ data1 <- data1[ ! (base::is.infinite(data1[, freq]) | base::is.na(data1[, freq])), ] #
+ }
+ # end Inf and NA removal
+ # 0 removal
+ if(base::any(data1[, freq] == 0)){
+ warn.count <- warn.count + 1
+ tempo.warn <- base::paste0("(", warn.count,") PRESENCE OF 0 VALUES IN THE ", freq, " COLUMN OF THE data1 ARGUMENT AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)")
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
+ tempo <- base::which(data1[, freq] == 0) # data.ini used for the output
+ removed.row.nb <- base::c(removed.row.nb, tempo)
+ removed.rows <- base::rbind(removed.rows, data1.ini[tempo, ], stringsAsFactors = FALSE) # data.ini used for the output
+ data1 <- data1[ data1[, freq] != 0, ] #
+ }
+ # end 0 removal
+ }
+
+ if( ! categ %in% base::names(data1)){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\ncateg ARGUMENT MUST BE A COLUMN NAME OF THE data1 ARGUMENT")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else{
+ if(base::all(base::is.na(data1[ , categ]))){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nTHE categ COLUMN OF data1 CANNOT BE JUST NA")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ tempo1 <- saferDev::arg_check(data = categ, class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name)
+ tempo2 <- saferDev::arg_check(data = categ, class = "factor", na.contain = TRUE, fun.name = function.name)
+ if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nTHE categ COLUMN OF data1 MUST BE CLASS \"factor\" OR \"character\"")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ # NA removal
+ if(base::any(base::is.na(data1[, categ]))){
+ warn.count <- warn.count + 1
+ tempo.warn <- base::paste0("(", warn.count,") PRESENCE OF NA VALUES IN THE ", categ, " COLUMN OF THE data1 ARGUMENT AND CORRESPONDING ROWS REMOVED (SEE $removed.row.nb AND $removed.rows)")
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
+ tempo <- base::which(base::is.na(data1.ini[, categ])) # data.ini used for the output
+ removed.row.nb <- base::c(removed.row.nb, tempo)
+ removed.rows <- base::rbind(removed.rows, data1.ini[tempo, ], stringsAsFactors = FALSE) # data.ini used for the output
+ data1 <- data1[ ! base::is.na(data1[, categ]), ] #
+ }
+ # end Inf and NA removal
+ if(base::any(base::duplicated(data1[, categ]))){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nTHE categ COLUMN OF data1 CANNOT CONTAIN DUPLICATED VALUES\n", base::paste(data1[, categ][base::duplicated(data1[, categ])], collapse = " "))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ }
+
+ if( ! base::is.null(annotation)){
+ if( ! annotation %in% base::names(data1)){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nannotation ARGUMENT MUST BE A COLUMN NAME OF THE data1 ARGUMENT")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else{
+ if(base::all(base::is.na(data1[ , annotation]))){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nIF NON NULL, THE annotation COLUMN OF data1 CANNOT BE JUST NA")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ tempo1 <- saferDev::arg_check(data = annotation, class = "vector", mode = "character", na.contain = TRUE, fun.name = function.name)
+ tempo2 <- saferDev::arg_check(data = annotation, class = "factor", na.contain = TRUE, fun.name = function.name)
+ if(tempo1$problem == TRUE & tempo2$problem == TRUE){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nTHE annotation COLUMN OF data1 MUST BE CLASS \"factor\" OR \"character\"")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ if(base::any(base::duplicated(data1[, annotation]))){
+ warn.count <- warn.count + 1
+ tempo.warn <- base::paste0("(", warn.count,") PRESENCE OF DUPLICATED VALUES IN THE ", annotation, " COLUMN OF THE data1 ARGUMENT: ", base::paste0(data1[, annotation][base::duplicated(data1[, annotation])], collapse = " "))
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
+ }
+ }
+ }
+ if(base::length(data1) == 0){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nTHE data1 ARGUMENT IS EMPTY AFTER Inf, NA AND 0 REMOVAL IN THE ", freq, base::ifelse(base::is.null(annotation), " AND ", ", "), categ, base::ifelse(base::is.null(annotation), "", " AND "), " COLUMNS")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ if( ! base::is.null(fill.color)){
+ if( ! base::is.numeric(fill.color)){
+ if( ! base::all(fill.color[ ! base::is.na(fill.color)] %in% grDevices::colors() | base::grepl(pattern = "^#", fill.color[ ! base::is.na(fill.color)]), na.rm = TRUE)){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nfill.color ARGUMENT MUST BE A VECTOR OF (1) HEXADECIMAL COLOR STRINGS STARTING BY #, OR (2) COLOR NAMES GIVEN BY colors(), OR (3) INTEGER VALUES")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else{
+ fill.color <- base::as.character(fill.color) # remove class factor is any
+ }
+ }
+ }
+ if( ! base::is.numeric(border.color)){
+ if( ! (border.color %in% grDevices::colors() | base::grepl(pattern = "^#", border.color))){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nfill.color ARGUMENT MUST BE (1) A HEXADECIMAL COLOR STRING STARTING BY #, OR (2) A COLOR NAME GIVEN BY colors(), OR (3) AN INTEGER VALUE")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else{
+ border.color <- base::as.character(border.color) # remove class factor is any
+ }
+ }
+ # legend name filling
+ if(base::is.null(legend.name)){
+ legend.name <- categ
+ }
+ # legend.name not NULL anymore
+ # end legend name filling
+ # verif of add
+ if( ! base::is.null(add)){
+ if( ! base::grepl(pattern = "^\\s*\\+", add)){ # check that the add string start by +
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nadd ARGUMENT MUST START WITH \"+\": ", base::paste(base::unique(add), collapse = " "))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+
+ }else if( ! base::grepl(pattern = "(ggplot2|lemon)\\s*::", add)){ #
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nFOR EASIER FUNCTION DETECTION, add ARGUMENT MUST CONTAIN \"ggplot2::\" OR \"lemon::\" IN FRONT OF EACH GGPLOT2 FUNCTION: ", base::paste(base::unique(add), collapse = " "))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else if( ! base::grepl(pattern = ")\\s*$", add)){ # check that the add string finished by )
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nadd ARGUMENT MUST FINISH BY \")\": ", base::paste(base::unique(add), collapse = " "))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ }
+ # end verif of add
+ # management of add containing facet
+ facet.categ <- NULL
+ if( ! base::is.null(add)){
+ facet.check <- TRUE
+ tempo <- base::unlist(base::strsplit(x = add, split = "\\s*\\+\\s*(ggplot2|lemon)\\s*::\\s*")) #
+ tempo <- base::sub(x = tempo, pattern = "^facet_wrap", replacement = "ggplot2::facet_wrap")
+ tempo <- base::sub(x = tempo, pattern = "^facet_grid", replacement = "ggplot2::facet_grid")
+ tempo <- base::sub(x = tempo, pattern = "^facet_rep", replacement = "lemon::facet_rep")
+
+ if(base::any(base::grepl(x = tempo, pattern = "ggplot2::facet_wrap|lemon::facet_rep_wrap"))){
+ tempo1 <- base::suppressWarnings(base::eval(base::parse(text = tempo[base::grepl(x = tempo, pattern = "ggplot2::facet_wrap|lemon::facet_rep_wrap")])))
+ facet.categ <- base::list(base::names(tempo1$params$facets)) # list of length 1
+ tempo.text <- "facet_wrap OR facet_rep_wrap"
+ facet.check <- FALSE
+ }else if(base::grepl(x = add, pattern = "ggplot2::facet_grid|lemon::facet_rep_grid")){
+ tempo1 <- base::suppressWarnings(base::eval(base::parse(text = tempo[base::grepl(x = tempo, pattern = "ggplot2::facet_grid|lemon::facet_rep_grid")])))
+ facet.categ <- base::list(base::c(base::names(tempo1$params$rows), base::names(tempo1$params$cols))) # list of length 1
+ tempo.text <- "facet_grid OR facet_rep_grid"
+ facet.check <- FALSE
+ }
+ if(facet.check == FALSE & ! base::all(facet.categ %in% base::names(data1))){ # WARNING: all(facet.categ %in% names(data1)) is TRUE when facet.categ is NULL
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nDETECTION OF \"", tempo.text, "\" STRING IN THE add ARGUMENT BUT PROBLEM OF VARIABLE DETECTION (COLUMN NAMES OF data1)\nTHE DETECTED VARIABLES ARE:\n", base::paste(facet.categ, collapse = " "), "\nTHE data1 COLUMN NAMES ARE:\n", base::paste(base::names(data1), collapse = " "), "\nPLEASE REWRITE THE add STRING AND RERUN")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ }
+ # if facet.categ is not NULL, it is a list of length 1 now
+ # end management of add containing facet
+ if( ! base::is.null(lib.path)){
+ if( ! base::all(base::dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nDIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", base::paste(lib.path, collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }
+ }
+ # end other checkings
+ # reserved word checking
+ if( ! (base::is.null(add))){
+ if(base::any(base::sapply(X = arg.names, FUN = grepl, x = add), na.rm = TRUE)){
+ warn.count <- warn.count + 1
+ tempo.warn <- base::paste0("(", warn.count,") NAMES OF ", function.name, " ARGUMENTS DETECTED IN THE add STRING:\n", base::paste(arg.names[base::sapply(X = arg.names, FUN = grepl, x = add)], collapse = "\n"), "\nRISK OF WRONG OBJECT USAGE INSIDE ", function.name)
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
+ }
+ }
+ # verif of add
+ if( ! base::is.null(add)){
+ if( ! base::grepl(pattern = "^\\s*\\+", add)){ # check that the add string start by +
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nadd ARGUMENT MUST START WITH \"+\": ", base::paste(base::unique(add), collapse = " "))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else if( ! base::grepl(pattern = "(ggplot2|lemon)\\s*::", add)){ #
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nFOR EASIER FUNCTION DETECTION, add ARGUMENT MUST CONTAIN \"ggplot2::\" OR \"lemon::\" IN FRONT OF EACH GGPLOT2 FUNCTION: ", base::paste(base::unique(add), collapse = " "))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else if( ! base::grepl(pattern = ")\\s*$", add)){ # check that the add string finished by )
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nadd ARGUMENT MUST FINISH BY \")\": ", base::paste(base::unique(add), collapse = " "))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ }
+ # end verif of add
+ # management of add containing facet
+ facet.categ <- NULL
+ if( ! base::is.null(add)){
+ facet.check <- TRUE
+ tempo <- base::unlist(base::strsplit(x = add, split = "\\s*\\+\\s*(ggplot2|lemon)\\s*::\\s*")) #
+ tempo <- base::sub(x = tempo, pattern = "^facet_wrap", replacement = "ggplot2::facet_wrap")
+ tempo <- base::sub(x = tempo, pattern = "^facet_grid", replacement = "ggplot2::facet_grid")
+ tempo <- base::sub(x = tempo, pattern = "^facet_rep", replacement = "lemon::facet_rep")
+ if(base::any(base::grepl(x = tempo, pattern = "ggplot2::facet_wrap|lemon::facet_rep_wrap"), na.rm = TRUE)){
+ tempo1 <- base::suppressWarnings(base::eval(base::parse(text = tempo[base::grepl(x = tempo, pattern = "ggplot2::facet_wrap|lemon::facet_rep_wrap")])))
+ facet.categ <- base::names(tempo1$params$facets)
+ tempo.text <- "facet_wrap OR facet_rep_wrap"
+ facet.check <- FALSE
+ }else if(base::grepl(x = add, pattern = "ggplot2::facet_grid|lemon::facet_rep_grid")){
+ tempo1 <- base::suppressWarnings(base::eval(base::parse(text = tempo[base::grepl(x = tempo, pattern = "ggplot2::facet_grid|lemon::facet_rep_grid")])))
+ facet.categ <- base::c(base::names(tempo1$params$rows), base::names(tempo1$params$cols))
+ tempo.text <- "facet_grid OR facet_rep_grid"
+ facet.check <- FALSE
+ }
+ if(facet.check == FALSE & ! base::all(facet.categ %in% base::names(data1))){ # WARNING: all(facet.categ %in% names(data1)) is TRUE when facet.categ is NULL # all() without na.rm -> ok because facet.categ cannot be NA (tested above)
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nDETECTION OF \"", tempo.text, "\" STRING IN THE add ARGUMENT BUT PROBLEM OF VARIABLE DETECTION (COLUMN NAMES OF data1)\nTHE DETECTED VARIABLES ARE:\n", base::paste(facet.categ, collapse = " "), "\nTHE data1 COLUMN NAMES ARE:\n", base::paste(base::names(data1), collapse = " "), "\nPLEASE REWRITE THE add STRING AND RERUN")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ }
+ # end management of add containing facet
+ # end reserved word checking
+ # end second round of checking and data preparation
+
+
+
+ # main code
+ data1 <- base::data.frame(data1, prop = data1[ , freq] / base::sum(data1[ , freq]))
+ if(legend.add.prop == TRUE){
+ data1[ , categ] <- base::paste0(data1[ , categ], " (", base::round(data1$prop, 2), ")")
+ }
+ data1[ , categ] <- base::factor(data1[ , categ], levels = data1[ , categ][base::order(data1$prop, decreasing = TRUE)]) # reorder so that the donut is according to decreasing proportion starting at the top in a clockwise direction
+ data1 <- data1[base::order(base::as.numeric(data1[ , categ]), decreasing = FALSE), ] # data1[ , categ] with rows in decreasing order, according to prop
+ data1 <- base::data.frame(data1, x = 0) # staked bar at the origin of the donut set to x = 0
+ tempo.gg.name <- "gg.indiv.plot."
+ tempo.gg.count <- 0
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), base::eval(base::parse(text = base::paste0("ggplot2::ggplot()", if(base::is.null(add)){""}else{add})))) # add added here to have the facets
+ bar_width = 1
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_col(
+ data = data1,
+ mapping = ggplot2::aes_string(x = "x", y = freq, fill = categ),
+ color = border.color,
+ size = border.size,
+ width = bar_width
+ )) # size is size of the separation in the donut
+ # assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_text(
+ # ggplot2::aes(label = Freq),
+ # position = ggplot2::position_stack(vjust = 0.5)
+ # ))
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_x_continuous(
+ expand = base::c(0, 0), # prevent extra limits in x axis
+ limits = base::c(- bar_width / 2 - (bar_width * hole.size) / (1 - hole.size), base::max(bar_width / 2, annotation.distance))
+ )) # must be centered on x = 0
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ylim(base::c(0, base::max(base::cumsum(data1[ , freq])))))
+ if(hole.text == TRUE){
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
+ geom = "text",
+ x = - bar_width / 2 - (bar_width * hole.size) / (1 - hole.size),
+ y = 0,
+ label = base::sum(data1[ , freq]),
+ size = hole.text.size
+ ))
+ }
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_polar(theta = "y", direction = -1, start = 0, clip = "on"))
+ if(base::is.null(fill.color) & ! base::is.null(fill.palette)){
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_fill_brewer(palette = fill.palette, name = legend.name))
+ }else if( ! base::is.null(fill.color)){
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_fill_manual(values = fill.color, name = legend.name, na.value = "white"))
+ }
+ if(legend.name != ""){
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::labs(fill = legend.name)) # title of the legend
+ }
+
+ if( ! base::is.null(add)){ # if add is NULL, then = 0
+ if(base::grepl(pattern = "ggplot2\\s*::\\s*theme", add) == TRUE){
+ warn.count <- warn.count + 1
+ tempo.warn <- base::paste0("(", warn.count,") \"ggplot2::theme\" STRING DETECTED IN THE add ARGUMENT\n-> INTERNAL GGPLOT2 THEME FUNCTIONS theme_void() HAS BEEN INACTIVATED, SO THAT THE USER THEME CAN BE EFFECTIVE")
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
+ add.check <- FALSE
+ }else{
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_void())
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme(
+ legend.text = ggplot2::element_text(size = legend.text.size),
+ legend.spacing.y = grid::unit(legend.box.space, 'mm')
+ ))
+ }
+ }else{
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_void())
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme(
+ legend.text = ggplot2::element_text(size = legend.text.size),
+ legend.spacing.y = grid::unit(legend.box.space, 'mm')
+ ))
+ }
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(
+ fill = ggplot2::guide_legend(
+ override.aes = base::list(color = "white", size = legend.box.size),
+ byrow = TRUE
+ )
+ )) # remove border of squares in legend
+
+ # annotations on slices
+ if( ! base::is.null(annotation)){
+ tempo <- base::rev(base::cumsum(base::rev(data1[ , freq])))
+ data1 <- base::data.frame(data1, text_y = tempo - (tempo - base::c(tempo[-1], 0)) / 2)
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggrepel::geom_text_repel(
+ data = data1,
+ mapping = ggplot2::aes_string(
+ x = "x",
+ y = "text_y",
+ label = annotation
+ ),
+ size = annotation.size,
+ force = annotation.force,
+ force_pull = annotation.force.pull,
+ nudge_x = annotation.distance, # knowing that the bar is centered on x = 0 and that the right edge is at bar_width / 2, 0 means center of the slice, 0.5 means at the edge if bar_width = 1
+ show.legend = FALSE
+ ))
+ }
+ # end annotations on slices
+
+ # legend management
+ # removal of part of the legend
+ if( ! base::is.null(legend.limit)){
+ if(base::sum(data1$prop >= legend.limit) == 0){
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nTHE legend.limit PARAMETER VALUE (", legend.limit, ") IS TOO HIGH FOR THE PROPORTIONS IN THE DONUT PLOT:\n", base::paste0(data1$prop, collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)
+ }else{
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_fill_discrete(
+ breaks = base::as.character(data1[ , categ][data1$prop >= legend.limit])
+ ))
+ }
+ }
+ # end removal of part of the legend
+ if(legend.show == FALSE){ # must be here because must be before bef.final.plot
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(fill = "none")) # inactivate the initial legend
+ }
+ bef.final.plot <- base::suppressWarnings(base::suppressMessages(ggplot2::ggplot_build(base::eval(base::parse(text = base::paste(base::paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))))
+ if( ! base::is.null(legend.width)){
+ legend.plot <- base::suppressWarnings(base::suppressMessages(gg_get_legend(ggplot_built = bef.final.plot, fun.name = function.name, lib.path = lib.path))) # get legend
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(fill = "none")) # inactivate the initial legend
+ if(base::is.null(legend.plot) & plot == TRUE){ # even if any(unlist(legend.disp)) is TRUE
+ legend.plot <- ggplot2::ggplot()+ggplot2::theme_void() # empty graph instead of legend
+ warn.count <- warn.count + 1
+ tempo.warn <- base::paste0("(", warn.count,") LEGEND REQUESTED (legend.show ARGUMENT SET TO TRUE)\nBUT IT SEEMS THAT THE PLOT HAS NO LEGEND -> EMPTY LEGEND SPACE CREATED BECAUSE OF THE NON NULL legend.width ARGUMENT\n")
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
+ }
+ }else{
+ legend.plot <- NULL
+ }
+ # end legend management
+
+ # title
+ title.grob <- grid::textGrob(
+ label = title,
+ x = grid::unit(0, "lines"),
+ y = grid::unit(0, "lines"),
+ hjust = 0,
+ vjust = 0,
+ gp = grid::gpar(fontsize = title.text.size)
+ )
+ # end title
+
+ # drawing
+ grDevices::pdf(NULL)
+ grob.save <- NULL
+ main.plot <- base::eval(base::parse(text = base::paste(base::paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))
+ main.plot.output <- base::suppressMessages(ggplot2::ggplot_build(main.plot))
+ main.grob <- base::suppressMessages(base::suppressWarnings(gridExtra::arrangeGrob(
+ main.plot,
+ top = if(title == ""){" "}else{title.grob},
+ left = " ",
+ right = " "
+ ))) # , left = " ", right = " " : trick to add margins in the plot. padding = unit(0.5, "inch") is for top margin above the title
+ if( ! base::is.null(legend.width)){
+ grob.save <- base::suppressMessages(base::suppressWarnings(gridExtra::grid.arrange(main.grob, legend.plot, ncol=2, widths=base::c(1, legend.width)))) # assemble grobs, ggplot, gtable into a gtable that defines the positions of the different elements (as grobs)
+ }else{
+ grob.save <- base::suppressMessages(base::suppressWarnings(base::print(main.grob)))
+ }
+ grDevices::dev.off() # inactivate the pdf(NULL) above
+ if(plot == TRUE){
+ gridExtra::grid.arrange(grob.save) # plot a gtable (grob)
+ }else{
+ warn.count <- warn.count + 1
+ tempo.warn <- base::paste0("(", warn.count,") PLOT NOT SHOWN AS REQUESTED")
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
+ }
+ # end drawing
+
+ # output
+ if(warn.print == TRUE & ! base::is.null(warn)){
+ base::on.exit(base::warning(base::paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE))
+ }
+ base::on.exit(exp = base::options(warning.length = ini.warning.length), add = TRUE)
+ if(return == TRUE){
+ if(base::is.null(base::unlist(removed.row.nb))){
+ removed.row.nb <- NULL
+ removed.rows <- NULL
+ }
+ tempo <- main.plot.output$layout$panel_params[[1]]
+ output <- base::list(
+ data = data1,
+ removed.row.nb = removed.row.nb,
+ removed.rows = removed.rows,
+ plot.data = main.plot.output$data,
+ panel = facet.categ,
+ axes = base::list(
+ x.range = tempo$x.range,
+ x.labels = if(base::is.null(base::attributes(tempo$x$breaks))){tempo$x$breaks}else{tempo$x$scale$get_labels()}, # is.null(attributes(tempo$x$breaks)) test if it is number (TRUE) or character (FALSE)
+ x.positions = if(base::is.null(base::attributes(tempo$x$breaks))){tempo$x$breaks}else{base::unlist(base::attributes(tempo$x$breaks))},
+ y.range = tempo$y.range,
+ y.labels = if(base::is.null(base::attributes(tempo$y$breaks))){tempo$y$breaks}else{tempo$y$scale$get_labels()},
+ y.positions = if(base::is.null(base::attributes(tempo$y$breaks))){tempo$y$breaks}else{base::unlist(base::attributes(tempo$y$breaks))}
+ ),
+ warn = base::paste0("\n", warn, "\n\n"),
+ ggplot = if(return.ggplot == TRUE){main.plot}else{NULL}, # main plot -> plots the graph if return == TRUE
+ gtable = if(return.gtable == TRUE){grob.save}else{NULL} # gtable of the full graph (main + title + legend)
+ )
+ base::return(output) # this plots the graph if return.ggplot is TRUE and if no assignment
+ }
+ # end output
+ # end main code
+}
+
+
+
diff --git a/gg_empty.R b/gg_empty.R
new file mode 100644
index 0000000000000000000000000000000000000000..4d4f0ad58021ec21ecdd86a9790376e0f024ac43
--- /dev/null
+++ b/gg_empty.R
@@ -0,0 +1,158 @@
+#' @title gg_empty
+#' @description
+#' display an empty ggplot2 plot with a text in the middle of the window (for instance to specify that no plot can be drawn).
+#' @param text character string of the message to display.
+#' @param text.size numeric value of the text size (in points).
+#' @param title character string of the graph title.
+#' @param title.size numeric value of the title size (in points).
+#' @param lib.path character vector specifying the absolute pathways of the directories containing the required packages if not in the default directories. Ignored if NULL.
+#' @returns an empty plot.
+#' @examples
+#' ### simple example.
+#' gg_empty(text = "NO GRAPH")
+#' ### white page.
+#' gg_empty()
+#' ### all the arguments.
+#' gg_empty(text = "NO GRAPH", text.size = 8, title = "GRAPH1", title.size = 10, lib.path = NULL)
+#' @importFrom ggplot2 aes
+#' @importFrom ggplot2 element_rect
+#' @importFrom ggplot2 element_text
+#' @importFrom ggplot2 geom_text
+#' @importFrom ggplot2 ggplot
+#' @importFrom ggplot2 ggtitle
+#' @importFrom ggplot2 theme_void
+#' @importFrom utils find
+#' @export
+gg_empty <- function(
+ text = NULL,
+ text.size = 12,
+ title = NULL,
+ title.size = 8,
+ lib.path = NULL
+){
+ # DEBUGGING
+ # text = "NO GRAPH" ; text.size = 12 ; title = "GRAPH1" ; title.size = 8 ; lib.path = NULL
+ # package name
+ package.name <- "ggcute"
+ # end package name
+ # function name
+ function.name <- base::paste0(base::as.list(base::match.call(expand.dots = FALSE))[[1]], "()") # function name with "()" paste, which split into a vector of three: c("::()", "package()", "function()") if "package::function()" is used.
+ if(function.name[1] == "::()"){
+ function.name <- function.name[3]
+ }
+ arg.names <- base::names(base::formals(fun = base::sys.function(base::sys.parent(n = 2)))) # names of all the arguments
+ arg.user.setting <- base::as.list(base::match.call(expand.dots = FALSE))[-1] # list of the argument settings (excluding default values not provided by the user)
+ # end function name
+ # critical operator checking
+ .base_op_check(external.function.name = function.name)
+ # end critical operator checking
+ # package checking
+ # check of lib.path
+ if( ! base::is.null(lib.path)){
+ if( ! base::all(base::typeof(lib.path) == "character")){ # no na.rm = TRUE with typeof
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE: DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT MUST BE A VECTOR OF CHARACTERS:\n", base::paste(lib.path, collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else if( ! base::all(base::dir.exists(lib.path), na.rm = TRUE)){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE: DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", base::paste(lib.path, collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ base::.libPaths(new = base::sub(x = lib.path, pattern = "/$|\\\\$", replacement = "")) # .libPaths(new = ) add path to default path. BEWARE: .libPaths() does not support / at the end of a submitted path. Thus check and replace last / or \\ in path
+ lib.path <- base::.libPaths()
+ }
+ }else{
+ lib.path <- base::.libPaths() # .libPaths(new = lib.path) # or .libPaths(new = c(.libPaths(), lib.path))
+ }
+ # end check of lib.path
+ # check of the required function from the required packages
+ .pack_and_function_check(
+ fun = base::c(
+ "ggplot2::aes",
+ "ggplot2::element_rect",
+ "ggplot2::element_text",
+ "ggplot2::geom_text",
+ "ggplot2::ggplot",
+ "ggplot2::ggtitle",
+ "ggplot2::theme_void",
+ "saferDev::arg_check",
+ "utils::find"
+ ),
+ lib.path = lib.path,
+ external.function.name = function.name
+ )
+ # end check of the required function from the required packages
+ # end package checking
+
+ # argument primary checking
+ # arg with no default values
+ # end arg with no default values
+ # argument checking with arg_check()
+ # argument checking
+ argum.check <- NULL #
+ text.check <- NULL #
+ checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
+ ee <- base::expression(argum.check <- base::c(argum.check, tempo$problem) , text.check <- base::c(text.check, tempo$text) , checked.arg.names <- base::c(checked.arg.names, tempo$object.name))
+ if( ! base::is.null(text)){
+ tempo <- saferDev::arg_check(data = text, class = "vector", mode = "character", length = 1, fun.name = function.name) ; base::eval(ee)
+ }
+ tempo <- saferDev::arg_check(data = text.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; base::eval(ee)
+ if( ! base::is.null(title)){
+ tempo <- saferDev::arg_check(data = title, class = "vector", mode = "character", length = 1, fun.name = function.name) ; base::eval(ee)
+ }
+ tempo <- saferDev::arg_check(data = title.size, class = "vector", mode = "numeric", length = 1, fun.name = function.name) ; base::eval(ee)
+ if( ! base::is.null(argum.check)){
+ if(base::any(argum.check) == TRUE){
+ base::stop(base::paste0("\n\n================\n\n", base::paste(text.check[argum.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
+ }
+ }
+ # end argument checking with arg_check()
+ # check with r_debugging_tools
+ # 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_saferDev::arg_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 saferDev::arg_check()
+ # end check with r_debugging_tools
+ # end argument primary checking
+
+ # second round of checking and data preparation
+ # management of NA arguments
+ if( ! (base::all(base::class(arg.user.setting) == "list", na.rm = TRUE) & base::length(arg.user.setting) == 0)){
+ tempo.arg <- base::names(arg.user.setting) # values provided by the user
+ tempo.log <- base::suppressWarnings(base::sapply(base::lapply(base::lapply(tempo.arg, FUN = base::get, envir = base::sys.nframe(), inherits = FALSE), FUN = base::is.na), FUN = base::any)) & base::lapply(base::lapply(tempo.arg, FUN = base::get, envir = base::sys.nframe(), inherits = FALSE), FUN = base::length) == 1L # no argument provided by the user can be just NA
+ if(base::any(tempo.log) == TRUE){ # normally no NA because is.na() used here
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE\n", base::ifelse(base::sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT JUST BE NA:", base::paste0(tempo.arg[tempo.log], collapse = "\n"))
+ base::stop(base::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 <-base::c(
+ "text.size" ,
+ "title.size"
+ )
+ tempo.log <- base::sapply(base::lapply(tempo.arg, FUN = base::get, envir = base::sys.nframe(), inherits = FALSE), FUN = base::is.null)
+ if(base::any(tempo.log) == TRUE){# normally no NA with is.null()
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE:\n", base::ifelse(base::sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS\n", "THIS ARGUMENT\n"), base::paste0(tempo.arg[tempo.log], collapse = "\n"),"\nCANNOT BE NULL")
+ base::stop(base::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
+ # reserved words (to avoid bugs)
+ # end reserved words (to avoid bugs)
+ # end second round of checking and data preparation
+ # main code
+ tempo.gg.name <- "gg.indiv.plot."
+ tempo.gg.count <- 0
+ # no need loop part
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggplot())
+ if( ! base::is.null(text)){
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_text(data = base::data.frame(x = 1, y = 1, stringsAsFactors = TRUE), ggplot2::aes(x = x, y = y, label = text), size = text.size))
+ }
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::ggtitle(title))
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::theme_void())
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), m.gg <- ggplot2::theme(
+ panel.background = ggplot2::element_rect(fill = "white", color = NA),
+ plot.title = ggplot2::element_text(size = title.size) # stronger than text
+ ))
+ final <- base::suppressWarnings(base::eval(base::parse(text = base::paste(base::paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))
+ base::return(final)
+}
diff --git a/gg_get_legend.R b/gg_get_legend.R
new file mode 100644
index 0000000000000000000000000000000000000000..2292cc39519081820141de46ce4feb812d0023c3
--- /dev/null
+++ b/gg_get_legend.R
@@ -0,0 +1,142 @@
+#' @title gg_get_legend
+#' @description
+#' get legend of ggplot objects #from https://stackoverflow.com/questions/12539348/ggplot-separate-legend-and-plot
+#' @param ggplot_built a ggplot build object.
+#' @param fun.name single character string indicating the name of the function using gg_get_legend() for warning and error messages. Ignored if NULL.
+#' @param lib.path character vector specifying the absolute pathways of the directories containing the required packages if not in the default directories. Ignored if NULL.
+#' @returns a list of class c("gtable", "gTree", "grob", "gDesc"), providing legend information of ggplot_built objet, or NULL if the ggplot_built object has no legend.
+#' @examples
+#' # Simple example
+#' obs1 <- data.frame(time = 1:20, group = rep(c("CLASS_1", "CLASS_2"), times = 10), stringsAsFactors = TRUE) ; p <- ggplot2::ggplot() + ggplot2::geom_point(data = obs1, mapping = ggplot2::aes(x = group, y = time, fill = group)) ; gg_get_legend(ggplot_built = ggplot2::ggplot_build(p))
+#' #Error message because no legend in the ggplot
+#' obs1 <- data.frame(time = 1:20, group = rep(c("CLASS_1", "CLASS_2"), times = 10), stringsAsFactors = TRUE) ; p <- ggplot2::ggplot() + ggplot2::geom_point(data = obs1, mapping = ggplot2::aes(x = group, y = time)) ; gg_get_legend(ggplot_built = ggplot2::ggplot_build(p))
+#' @importFrom ggplot2 ggplot_gtable
+#' @importFrom saferDev arg_check
+#' @export
+gg_get_legend <- function(ggplot_built, fun.name = NULL, lib.path = NULL){
+ # DEBUGGING
+ # obs1 <- data.frame(time = 1:20, group = rep(c("CLASS_1", "CLASS_2"), times = 10), stringsAsFactors = TRUE) ; p <- ggplot2::ggplot() + ggplot2::geom_point(data = obs1, mapping = ggplot2::aes(x = group, y = time)) ; ggplot_built = ggplot2::ggplot_build(p) ; fun.name = NULL ; lib.path = NULL
+ # package name
+ package.name <- "ggcute"
+ # end package name
+ # function name
+ function.name <- base::paste0(base::as.list(base::match.call(expand.dots = FALSE))[[1]], "()") # function name with "()" paste, which split into a vector of three: c("::()", "package()", "function()") if "package::function()" is used.
+ if(function.name[1] == "::()"){
+ function.name <- function.name[3]
+ }
+ arg.names <- base::names(base::formals(fun = base::sys.function(base::sys.parent(n = 2)))) # names of all the arguments
+ arg.user.setting <- base::as.list(base::match.call(expand.dots = FALSE))[-1] # list of the argument settings (excluding default values not provided by the user)
+ # end function name
+ # critical operator checking
+ .base_op_check(external.function.name = function.name)
+ # end critical operator checking
+ # package checking
+ # check of lib.path
+ if( ! base::is.null(lib.path)){
+ if( ! base::all(base::typeof(lib.path) == "character")){ # no na.rm = TRUE with typeof
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE: DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT MUST BE A VECTOR OF CHARACTERS:\n", base::paste(lib.path, collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else if( ! base::all(base::dir.exists(lib.path), na.rm = TRUE)){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE: DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", base::paste(lib.path, collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ base::.libPaths(new = base::sub(x = lib.path, pattern = "/$|\\\\$", replacement = "")) # base::.libPaths(new = ) add path to default path. BEWARE: base::.libPaths() does not support / at the end of a submitted path. Thus check and replace last / or \\ in path
+ lib.path <- base::.libPaths()
+ }
+ }else{
+ lib.path <- base::.libPaths() # base::.libPaths(new = lib.path) # or base::.libPaths(new = c(base::.libPaths(), lib.path))
+ }
+ # end check of lib.path
+ # check of the required function from the required packages
+ .pack_and_function_check(
+ fun = base::c(
+ "ggplot2::ggplot_gtable",
+ "saferDev::arg_check"
+ ),
+ lib.path = lib.path,
+ external.function.name = function.name)
+ # end required function checking
+
+ # argument primary checking
+ # arg with no default values
+ mandat.args <- base::c(
+ "ggplot_built"
+ )
+ tempo <- base::eval(base::parse(text = base::paste0("base::missing(", base::paste0(mandat.args, collapse = ") | base::missing("), ")")))
+ if(base::any(tempo)){ # normally no NA for base::missing() output
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE\nFOLLOWING ARGUMENT", base::ifelse(base::sum(tempo, na.rm = TRUE) > 1, "S HAVE", "HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", base::paste0(mandat.args, collapse = "\n"))
+ base::stop(base::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 checking with arg_check()
+ # argument checking
+ argum.check<- NULL #
+ text.check <- NULL #
+ checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
+ ee <- base::expression(argum.check<- base::c(argum.check, tempo$problem) , text.check <- base::c(text.check, tempo$text) , checked.arg.names <- base::c(checked.arg.names, tempo$object.name))
+ tempo <- saferDev::arg_check(data = ggplot_built, class = "ggplot_built", mode = "list", fun.name = function.name) ; base::eval(ee)
+ if( ! base::is.null(fun.name)){
+ tempo <- saferDev::arg_check(data = fun.name, class = "vector", mode = "character", length = 1, fun.name = function.name) ; base::eval(ee)
+ }
+ if( ! base::is.null(lib.path)){
+ tempo <- saferDev::arg_check(data = lib.path, class = "vector", mode = "character", fun.name = function.name) ; base::eval(ee)
+ }
+ if( ! base::is.null(argum.check)){
+ if(base::any(argum.check) == TRUE){
+ base::stop(base::paste0("\n\n================\n\n", base::paste(text.check[argum.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
+ }
+ }
+ # end using saferDev::arg_check()
+ # check with r_debugging_tools
+ # source("C:/Users/yhan/Documents/Git_projects/debugging_tools_for_r_dev/r_debugging_tools.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 arg_check()
+ # end check with r_debugging_tools
+ # end argument primary checking
+
+ # second round of checking
+ # management of NA
+ if( ! (base::all(base::class(arg.user.setting) == "list", na.rm = TRUE) & base::length(arg.user.setting) == 0)){
+ tempo.arg <- base::names(arg.user.setting) # values provided by the user
+ tempo.log <- base::suppressWarnings(base::sapply(base::lapply(base::lapply(tempo.arg, FUN = base::get, envir = base::sys.nframe(), inherits = FALSE), FUN = base::is.na), FUN = base::any)) & base::lapply(base::lapply(tempo.arg, FUN = base::get, envir = base::sys.nframe(), inherits = FALSE), FUN = base::length) == 1L # no argument provided by the user can be just NA
+ if(base::any(tempo.log) == TRUE){ # normally no NA because is.na() used here
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE\n", base::ifelse(base::sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT JUST BE NA:", base::paste0(tempo.arg[tempo.log], collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ }
+ # management of NULL arguments
+ tempo.arg <-base::c(
+ "ggplot_built"
+ # 'fun.name' inactivated because can be null
+ )
+ tempo.log <- base::sapply(base::lapply(tempo.arg, FUN = base::get, envir = base::sys.nframe(), inherits = FALSE), FUN = base::is.null)
+ if(base::any(tempo.log) == TRUE){# normally no NA with is.null()
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE:\n", base::ifelse(base::sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS\n", "THIS ARGUMENT\n"), base::paste0(tempo.arg[tempo.log], collapse = "\n"),"\nCANNOT BE NULL")
+ base::stop(base::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
+ # end other checkings
+ # reserved words (to avoid bugs)
+ # end reserved words (to avoid bugs)
+ # end second round of checking and data preparation
+
+ # main code
+ win.nb <- grDevices::dev.cur()
+ grDevices::pdf(file = NULL)
+ tmp <- ggplot2::ggplot_gtable(ggplot_built)
+ # BEWARE with ggplot_gtable : open a blanck device https://stackoverflow.com/questions/17012518/why-does-this-r-ggplot2-code-bring-up-a-blank-display-device
+ base::invisible(grDevices::dev.off())
+ if(win.nb > 1){ # to go back to the previous active device, if == 1 means no opened device
+ grDevices::dev.set(win.nb)
+ }
+ leg <- base::which(base::sapply(tmp$grobs, function(x) x$name) == "guide-box")
+ if(base::length(leg) == 0L){
+ legend <- NULL
+ }else{
+ legend <- tmp$grobs[[leg]]
+ }
+ base::return(legend)
+}
diff --git a/gg_point_rast.R b/gg_point_rast.R
new file mode 100644
index 0000000000000000000000000000000000000000..570dfc4e7cfe6c0f7785f80bcba877c63fb87275
--- /dev/null
+++ b/gg_point_rast.R
@@ -0,0 +1,227 @@
+#' @title gg_point_rast
+#' @description
+#' equivalent to ggplot2::geom_point() but in raster mode use it like ggplot2::geom_point() with the main raster.dpi additional argument.
+#' @details
+#' can be long to generate the plot.
+#' use a square plot region. Otherwise, the dots will have ellipsoid shape.
+#' solve the transparency problems with some GUI.
+#' this function is derived from the geom_point_rast() function, created by Viktor Petukhov , and present in the ggrastr package (https://rdrr.io/github/VPetukhov/ggrastr/src/R/geom-point-rast.R, MIT License, Copyright (c) 2017 Viktor Petukhov). Has been placed here to minimize package dependencies.
+#' @param #classical arguments of geom_point(), shown here https://rdrr.io/github/VPetukhov/ggrastr/man/geom_point_rast.html
+#' @param raster.width width of the result image (in inches). Default: deterined by the current device parameters.
+#' @param raster.height height of the result image (in inches). Default: deterined by the current device parameters.
+#' @param raster.dpi resolution of the result image.
+#' @param inactivate logical. Inactivate the fun.name argument of the saferDev::arg_check() function? If TRUE, the name of the saferDev::arg_check() function in error messages coming from this function. Use TRUE if gg_point_rast() is used like this: eval(parse(text = "gg_point_rast")).
+#' @param lib.path: character vector specifying the absolute pathways of the directories containing the required packages if not in the default directories. Ignored if NULL.
+#' @returns a raster scatter plot.
+#' @examples
+#' # Two pdf in the current directory
+#' set.seed(1) ; data1 = data.frame(x = rnorm(100000), y = rnorm(100000), stringsAsFactors = TRUE) ; saferGraph::open2(pdf.name = "Raster") ; ggplot2::ggplot() + gg_point_rast(data = data1, mapping = ggplot2::aes(x = x, y = y)) ; saferGraph::open2(pdf.name = "Vectorial") ; ggplot2::ggplot() + ggplot2::geom_point(data = data1, mapping = ggplot2::aes(x = x, y = y)) ; dev.off();dev.off()
+#' @importFrom Cairo Cairo
+#' @importFrom ggplot2 ggproto
+#' @importFrom ggplot2 layer
+#' @importFrom ggplot2 GeomPoint
+#' @importFrom grid grid.cap
+#' @importFrom grid grid.points
+#' @importFrom grid popViewport
+#' @importFrom grid pushViewport
+#' @importFrom grid rasterGrob
+#' @importFrom grid viewport
+#' @importFrom saferDev arg_check
+#' @export
+gg_point_rast <- function(
+ data = NULL,
+ mapping = NULL,
+ stat = "identity",
+ position = "identity",
+ ...,
+ na.rm = FALSE,
+ show.legend = NA,
+ inherit.aes = TRUE,
+ raster.width = NULL,
+ raster.height = NULL,
+ raster.dpi = 300,
+ inactivate = TRUE,
+ lib.path = NULL
+){
+ # DEBUGGING
+ #
+ # package name
+ package.name <- "ggcute"
+ # end package name
+ # function name
+ if(base::all(inactivate == FALSE)){ # inactivate has to be used here but will be fully checked below
+ function.name <- base::paste0(base::as.list(base::match.call(expand.dots = FALSE))[[1]], "()") # function name with "()" paste, which split into a vector of three: c("::()", "package()", "function()") if "package::function()" is used.
+ if(function.name[1] == "::()"){
+ function.name <- function.name[3]
+ }
+ arg.names <- base::names(base::formals(fun = base::sys.function(base::sys.parent(n = 2)))) # names of all the arguments
+ arg.user.setting <- base::as.list(base::match.call(expand.dots = FALSE))[-1] # list of the argument settings (excluding default values not provided by the user)
+ }else if(base::all(inactivate == TRUE)){
+ function.name <- NULL
+ }else{
+ tempo.cat <- base::paste0("ERROR IN gg_point_rast(): CODE INCONSISTENCY 1")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ # end function name
+ # critical operator checking
+ .base_op_check(external.function.name = function.name)
+ # end critical operator checking
+ # package checking
+ # check of lib.path
+ if( ! base::is.null(lib.path)){
+ if( ! base::all(base::typeof(lib.path) == "character")){ # no na.rm = TRUE with typeof
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE: DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT MUST BE A VECTOR OF CHARACTERS:\n", base::paste(lib.path, collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else if( ! base::all(base::dir.exists(lib.path), na.rm = TRUE)){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE: DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", base::paste(lib.path, collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else{
+ base::.libPaths(new = base::sub(x = lib.path, pattern = "/$|\\\\$", replacement = "")) # .libPaths(new = ) add path to default path. BEWARE: .libPaths() does not support / at the end of a submitted path. Thus check and replace last / or \\ in path
+ lib.path <- base.libPaths()
+ }
+ }else{
+ lib.path <- base::.libPaths() # .libPaths(new = lib.path) # or .libPaths(new = c(.libPaths(), lib.path))
+ }
+ # end check of lib.path
+ # check of the required function from the required packages
+ .pack_and_function_check(
+ fun = base::c(
+ "Cairo::Cairo",
+ "ggplot2::ggproto",
+ "ggplot2::layer",
+ "ggplot2::GeomPoint",
+ "grid::grid.cap",
+ "grid::grid.points",
+ "grid::popViewport",
+ "grid::pushViewport",
+ "grid::rasterGrob",
+ "grid::viewport",
+ "saferDev::arg_check"
+ ),
+ lib.path = NULL,
+ external.function.name = function.name
+ )
+ # end check of the required function from the required packages
+ # end package checking
+
+ # argument primary checking
+ # arg with no default values
+ # end arg with no default values
+ # argument checking with arg_check()
+ # argument checking
+ argum.check <- NULL #
+ text.check <- NULL #
+ checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
+ ee <- base::expression(argum.check <- base::c(argum.check, tempo$problem) , text.check <- base::c(text.check, tempo$text) , checked.arg.names <- base::c(checked.arg.names, tempo$object.name))
+ if( ! base::is.null(data)){
+ tempo <- saferDev::arg_check(data = data, class = "data.frame", na.contain = TRUE, fun.name = function.name) ; base::eval(ee)
+ }
+ if( ! base::is.null(mapping)){
+ tempo <- saferDev::arg_check(data = mapping, class = "uneval", typeof = "list", fun.name = function.name) ; base::eval(ee) # aes() is tested
+ }
+ # stat and position not tested because too complicate
+ tempo <- saferDev::arg_check(data = na.rm, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = show.legend, class = "vector", mode = "logical", length = 1, na.contain = TRUE, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = inherit.aes, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; base::eval(ee)
+ if( ! base::is.null(raster.width)){
+ tempo <- saferDev::arg_check(data = raster.width, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; base::eval(ee)
+ }
+ if( ! base::is.null(raster.height)){
+ tempo <- saferDev::arg_check(data = raster.height, class = "vector", mode = "numeric", length = 1, neg.values = FALSE, fun.name = function.name) ; base::eval(ee)
+ }
+ tempo <- saferDev::arg_check(data = raster.dpi, class = "integer", length = 1, double.as.integer.allowed = TRUE, neg.values = FALSE, fun.name = function.name) ; base::eval(ee)
+ tempo <- saferDev::arg_check(data = inactivate, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; base::eval(ee)
+ if( ! base::is.null(lib.path)){
+ tempo <- saferDev::arg_check(data = lib.path, class = "vector", mode = "character", fun.name = function.name) ; base::eval(ee)
+ if(tempo$problem == FALSE){
+ if( ! base::all(base::dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
+ tempo.cat <- base::paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", base::paste(lib.path, collapse = "\n"))
+ text.check <- base::c(text.check, tempo.cat)
+ argum.check <- base::c(argum.check, TRUE)
+ }
+ }
+ }
+ if( ! base::is.null(argum.check)){
+ if(base::any(argum.check, na.rm = TRUE) == TRUE){
+ base::stop(base::paste0("\n\n================\n\n", base::paste(text.check[argum.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
+ }
+ }
+ # end argument checking with arg_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_saferDev::arg_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 saferDev::arg_check()
+ # end argument checking
+
+ # second round of checking and data preparation
+ # management of NA arguments
+ if( ! (base::all(base::class(arg.user.setting) == "list", na.rm = TRUE) & base::length(arg.user.setting) == 0)){
+ tempo.arg <- base::names(arg.user.setting) # values provided by the user
+ tempo.log <- base::suppressWarnings(base::sapply(base::lapply(base::lapply(tempo.arg, FUN = base::get, envir = base::sys.nframe(), inherits = FALSE), FUN = base::is.na), FUN = base::any)) & base::lapply(base::lapply(tempo.arg, FUN = base::get, envir = base::sys.nframe(), inherits = FALSE), FUN = base::length) == 1L # no argument provided by the user can be just NA
+ if(base::any(tempo.log) == TRUE){ # normally no NA because is.na() used here
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE\n", base::ifelse(base::sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT JUST BE NA:", base::paste0(tempo.arg[tempo.log], collapse = "\n"))
+ base::stop(base::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 <-base::c(
+ "stat",
+ "position",
+ "na.rm",
+ "show.legend",
+ "inherit.aes",
+ "raster.dpi",
+ "inactivate"
+ # "raster.width", # inactivated because can be null
+ # "raster.height", # inactivated because can be null
+ )
+ tempo.log <- base::sapply(base::lapply(tempo.arg, FUN = base::get, envir = base::sys.nframe(), inherits = FALSE), FUN = base::is.null)
+ if(base::any(tempo.log) == TRUE){# normally no NA with is.null()
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE:\n", base::ifelse(base::sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS\n", "THIS ARGUMENT\n"), base::paste0(tempo.arg[tempo.log], collapse = "\n"),"\nCANNOT BE NULL")
+ base::stop(base::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
+
+ # additional functions
+ DrawGeomPointRast <- function(data, panel_params, coord, na.rm = FALSE, raster.width = NULL, raster.height= NULL, raster.dpi = raster.dpi){
+ if (base::is.null(raster.width)){
+ raster.width <- base::par('fin')[1]
+ }
+ if (base::is.null(raster.height)){
+ raster.height <- base::par('fin')[2]
+ }
+ prev_dev_id <- base::dev.cur()
+ p <- ggplot2::GeomPoint$draw_panel(data, panel_params, coord)
+ dev_id <- Cairo::Cairo(type='raster', width = raster.width*raster.dpi, height = raster.height*raster.dpi, dpi = raster.dpi, units = 'px', bg = "transparent")[1]
+ grid::pushViewport(grid::viewport(width = 1, height = 1))
+ grid::grid.points(x = p$x, y = p$y, pch = p$pch, size = p$size,
+ name = p$name, gp = p$gp, vp = p$vp, draw = T)
+ grid::popViewport()
+ cap <- grid::grid.cap()
+ base::invisible(base::dev.off(dev_id))
+ base::invisible(base::dev.set(prev_dev_id))
+ grid::rasterGrob(cap, x = 0, y = 0, width = 1, height = 1, default.units = "native", just = base::c("left","bottom"))
+ }
+ # end additional functions
+ # main code
+ GeomPointRast <- ggplot2::ggproto("GeomPointRast", ggplot2::GeomPoint, draw_panel = DrawGeomPointRast)
+ ggplot2::layer(
+ data = data,
+ mapping = mapping,
+ stat = stat,
+ geom = GeomPointRast,
+ position = position,
+ show.legend = show.legend,
+ inherit.aes = inherit.aes,
+ params = base::list(
+ na.rm = na.rm,
+ raster.width = raster.width,
+ raster.height = raster.height,
+ raster.dpi = raster.dpi,
+ ...
+ )
+ )
+ # end main code
+}
diff --git a/ggbox.R b/ggbox.R
index 33598167121287994144fdb23bdf0c7fa0875b9e..199a795a706e66686081c25f0757136688b93e76 100755
--- a/ggbox.R
+++ b/ggbox.R
@@ -23,7 +23,7 @@ ggbox <- function(
box.mean = TRUE,
box.whisker.kind = "std",
box.whisker.width = 0,
- dot.color = grey(0.25),
+ dot.color = base::grey(0.25),
dot.categ = NULL,
dot.categ.class.order = NULL,
dot.legend.name = NULL,
@@ -202,31 +202,31 @@ ggbox <- function(
package.name <- "ggcute"
# end package name
# function name
- function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()") # function name with "()" paste, which split into a vector of three: c("::()", "package()", "function()") if "package::function()" is used.
+ function.name <- base::paste0(base::as.list(base::match.call(expand.dots = FALSE))[[1]], "()") # function name with "()" paste, which split into a vector of three: c("::()", "package()", "function()") if "package::function()" is used.
if(function.name[1] == "::()"){
function.name <- function.name[3]
}
- 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)
+ arg.names <- base::names(base::formals(fun = base::sys.function(base::sys.parent(n = 2)))) # names of all the arguments
+ arg.user.setting <- base::as.list(base::match.call(expand.dots = FALSE))[-1] # list of the argument settings (excluding default values not provided by the user)
# end function name
# critical operator checking
.base_op_check(external.function.name = function.name)
# end critical operator checking
# package checking
# check of lib.path
- if( ! is.null(lib.path)){
- if( ! all(typeof(lib.path) == "character")){ # no na.rm = TRUE with typeof
- tempo.cat <- paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE: DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT MUST BE A VECTOR OF CHARACTERS:\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 if( ! all(dir.exists(lib.path), na.rm = TRUE)){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
- tempo.cat <- paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE: 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) # == in stop() to be able to add several messages between ==
+ if( ! base::is.null(lib.path)){
+ if( ! base::all(base::typeof(lib.path) == "character")){ # no na.rm = TRUE with typeof
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE: DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT MUST BE A VECTOR OF CHARACTERS:\n", base::paste(lib.path, collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }else if( ! base::all(base::dir.exists(lib.path), na.rm = TRUE)){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
+ tempo.cat <- base::paste0("ERROR IN ", function.name, " OF THE ", package.name, " PACKAGE: DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", base::paste(lib.path, collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
}else{
- .libPaths(new = sub(x = lib.path, pattern = "/$|\\\\$", replacement = "")) # .libPaths(new = ) add path to default path. BEWARE: .libPaths() does not support / at the end of a submitted path. Thus check and replace last / or \\ in path
- lib.path <- .libPaths()
+ base::.libPaths(new = base::sub(x = lib.path, pattern = "/$|\\\\$", replacement = "")) # .libPaths(new = ) add path to default path. BEWARE: .libPaths() does not support / at the end of a submitted path. Thus check and replace last / or \\ in path
+ lib.path <- base::.libPaths()
}
}else{
- lib.path <- .libPaths() # .libPaths(new = lib.path) # or .libPaths(new = c(.libPaths(), lib.path))
+ lib.path <- base::.libPaths() # .libPaths(new = lib.path) # or .libPaths(new = c(.libPaths(), lib.path))
}
# end check of lib.path
# check of the required function from the required packages
@@ -297,7 +297,7 @@ ggbox <- function(
"y",
"categ"
)
- tempo <- base::eval(base::parse(text = base::paste0("missing(", base::paste0(mandat.args, collapse = ") | missing("), ")")))
+ tempo <- base::eval(base::parse(text = base::paste0("base::missing(", base::paste0(mandat.args, collapse = ") | base::missing("), ")")))
if(base::any(tempo)){ # normally no NA for missing() output
tempo.cat <-base:: paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", base::ifelse(base::sum(tempo, na.rm = TRUE) > 1, "S HAVE", "HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", base::paste0(mandat.args, collapse = "\n"))
base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
@@ -660,7 +660,7 @@ ggbox <- function(
base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}else{
tempo <- saferDev::arg_check(data = data1[, y], data.name = "y COLUMN OF data1", class = "vector", mode = "numeric", na.contain = TRUE, fun.name = function.name)
- base::if(tempo$problem == TRUE){
+ if(tempo$problem == TRUE){
tempo.cat <- base::paste0("ERROR IN ", function.name, "\ny ARGUMENT MUST BE NUMERIC COLUMN IN data1")
base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
@@ -684,7 +684,7 @@ ggbox <- function(
if(base::any(base::duplicated(base::names(data1)), na.rm = TRUE)){
tempo.cat <- base::paste0("ERROR IN ", function.name, "\nDUPLICATED COLUMN NAMES OF data1 ARGUMENT NOT ALLOWED:\n", base::paste(base::names(data1)[base::duplicated(base::names(data1))], collapse = " "))
base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
- }base::
+ }
if( ! base::is.null(dot.categ)){
if(dot.categ %in% categ){
reserved.words <- base::c(reserved.words, base::paste0(dot.categ, "_DOT")) # paste0(dot.categ, "_DOT") is added to the reserved words because in such situation, a new column will be added to data1 that is named paste0(dot.categ, "_DOT")
@@ -730,7 +730,7 @@ ggbox <- function(
if( ! (base::is.null(add))){
if(base::any(base::sapply(X = arg.names, FUN = grepl, x = add), na.rm = TRUE)){
warn.count <- warn.count + 1
- tempo.warn <- base::paste0("(", warn.count,") NAMES OF ", function.name, " ARGUMENTS DETECTED IN THE add STRING:\n", paste(arg.names[sapply(X = arg.names, FUN = grepl, x = add)], collapse = "\n"), "\nRISK OF WRONG OBJECT USAGE INSIDE ", function.name)
+ tempo.warn <- base::paste0("(", warn.count,") NAMES OF ", function.name, " ARGUMENTS DETECTED IN THE add STRING:\n", paste(arg.names[base::sapply(X = arg.names, FUN = grepl, x = add)], collapse = "\n"), "\nRISK OF WRONG OBJECT USAGE INSIDE ", function.name)
warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
}
}
@@ -780,7 +780,7 @@ ggbox <- function(
tempo2 <- saferDev::arg_check(data = data1[, categ[i1]], data.name = base::paste0("categ NUMBER ", i1, " OF data1"), class = "factor", na.contain = TRUE, fun.name = function.name)
if(tempo1$problem == TRUE & tempo2$problem == TRUE){
tempo.cat <- base::paste0("ERROR IN ", function.name, "\n", base::paste0("categ NUMBER ", i1, " OF data1"), " MUST BE A FACTOR OR CHARACTER VECTOR")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}else if(tempo1$problem == FALSE){ # character vector
if(box.alpha != 0){
warn.count <- warn.count + 1
@@ -900,8 +900,8 @@ ggbox <- function(
if( ! base::is.null(categ.class.order)){
if(base::length(categ.class.order) != base::length(categ)){
- tempo.cat <- base::paste0("ERROR IN ", function.name, "\ncateg.class.order ARGUMENT MUST BE A LIST OF LENGTH EQUAL TO LENGTH OF categ\nHERE IT IS LENGTH: ", length(categ.class.order), " VERSUS ", length(categ))
- base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\ncateg.class.order ARGUMENT MUST BE A LIST OF LENGTH EQUAL TO LENGTH OF categ\nHERE IT IS LENGTH: ", base::length(categ.class.order), " VERSUS ", base::length(categ))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}else{
for(i3 in 1:base::length(categ.class.order)){
if(base::is.null(categ.class.order[[i3]])){
@@ -930,7 +930,7 @@ ggbox <- function(
}
}
}else{
- categ.class.order <- base::vector("list", length = length(categ))
+ categ.class.order <- base::vector("list", length = base::length(categ))
tempo.categ.class.order <- NULL
for(i2 in 1:base::length(categ.class.order)){
categ.class.order[[i2]] <- base::levels(data1[, categ[i2]])
@@ -989,7 +989,7 @@ ggbox <- function(
}
}else if(base::length(categ.color) == base::length(data1[, categ[categ.len]])){# here length(categ.color) is equal to nrow(data1) -> Modif to have length(categ.color) equal to the different number of categ (length(categ.color) == length(levels(data1[, categ[categ.len]])))
data1 <- base::data.frame(data1, categ.color = categ.color, stringsAsFactors = TRUE)
- tempo.check <- base::unique(data1[ , c(categ[categ.len], "categ.color")])
+ tempo.check <- base::unique(data1[ , base::c(categ[categ.len], "categ.color")])
if( ! (base::nrow(tempo.check) == base::length(base::unique(categ.color)) & base::nrow(tempo.check) == base::length(base::unique(data1[ , categ[categ.len]])))){
tempo.cat <- base::paste0("ERROR IN ", function.name, "\ncateg.color ARGUMENT HAS THE LENGTH OF data1 ROW NUMBER\nBUT IS INCORRECTLY ASSOCIATED TO EACH CLASS OF categ ", categ[categ.len], ":\n", base::paste(base::unique(base::mapply(FUN = "paste", data1[ ,categ[categ.len]], data1[ ,"categ.color"])), collapse = "\n"))
base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
@@ -1056,32 +1056,32 @@ ggbox <- function(
tempo2 <- saferDev::arg_check(data = data1[, dot.categ], data.name = base::paste0(dot.categ, " COLUMN OF data1"), class = "factor", na.contain = TRUE, fun.name = function.name)
if(tempo1$problem == TRUE & tempo2$problem == TRUE){
tempo.cat <- base::paste0("ERROR IN ", function.name, "\ndot.categ COLUMN MUST BE A FACTOR OR CHARACTER VECTOR") #
- base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
data1[, dot.categ] <- base::factor(data1[, dot.categ]) # if already a factor, change nothing, if characters, levels according to alphabetical order
# dot.categ column of data1 is factor from here
if( ! base::is.null(dot.categ.class.order)){
if(base::any(base::duplicated(dot.categ.class.order), na.rm = TRUE)){
tempo.cat <- base::paste0("ERROR IN ", function.name, "\ndot.categ.class.order ARGUMENT CANNOT HAVE DUPLICATED CLASSES: ", base::paste(dot.categ.class.order, collapse = " "))
- base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}else if( ! (base::all(dot.categ.class.order %in% base::levels(data1[, dot.categ])) & base::all(base::levels(data1[, dot.categ]) %in% dot.categ.class.order, na.rm = TRUE))){
tempo.cat <- base::paste0("ERROR IN ", function.name, "\ndot.categ.class.order ARGUMENT MUST BE CLASSES OF dot.categ ARGUMENT\nHERE IT IS:\n", base::paste(dot.categ.class.order, collapse = " "), "\nFOR dot.categ.class.order AND IT IS:\n", base::paste(base::levels(data1[, dot.categ]), collapse = " "), "\nFOR dot.categ COLUMN (", ini.dot.categ, ") OF data1")
- base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}else{
data1[, dot.categ] <- base::factor(data1[, dot.categ], levels = dot.categ.class.order) # reorder the factor
}
}else{
if(base::all(dot.color == "same") & base::length(dot.color)== 1L){ # all() without na.rm -> ok because dot.color cannot be NA (tested above)
- dot.categ.class.order <-base:: unlist(categ.class.order[base::length(categ)])
+ dot.categ.class.order <-base::unlist(categ.class.order[base::length(categ)])
data1[, dot.categ] <- base::factor(data1[, dot.categ], levels = dot.categ.class.order) # reorder the factor
warn.count <- warn.count + 1
- tempo.warn <- base::paste0("(", warn.count,") THE dot.categ.class.order SETTING IS NULL AND dot.color IS \"same\". ORDER OF categ.class.order WILL BE APPLIED FOR LEGEND DISPLAY: ", paste(dot.categ.class.order, collapse = " "))
+ tempo.warn <- base::paste0("(", warn.count,") THE dot.categ.class.order SETTING IS NULL AND dot.color IS \"same\". ORDER OF categ.class.order WILL BE APPLIED FOR LEGEND DISPLAY: ", base::paste(dot.categ.class.order, collapse = " "))
warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
}else{
dot.categ.class.order <- base::sort(base::levels(data1[, dot.categ]))
data1[, dot.categ] <- base::factor(data1[, dot.categ], levels = dot.categ.class.order) # reorder the factor
warn.count <- warn.count + 1
- tempo.warn <- base::paste0("(", warn.count,") THE dot.categ.class.order SETTING IS NULL. ALPHABETICAL ORDER WILL BE APPLIED FOR LEGEND DISPLAY: ", paste(dot.categ.class.order, collapse = " "))
+ tempo.warn <- base::paste0("(", warn.count,") THE dot.categ.class.order SETTING IS NULL. ALPHABETICAL ORDER WILL BE APPLIED FOR LEGEND DISPLAY: ", base::paste(dot.categ.class.order, collapse = " "))
warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
}
}
@@ -1089,10 +1089,10 @@ ggbox <- function(
if(base::all(dot.color == "same") & base::length(dot.color)== 1L){ # all() without na.rm -> ok because dot.color cannot be NA (tested above)
if( ! base::identical(ini.dot.categ, categ[base::length(categ)])){
tempo.cat <- base::paste0("ERROR IN ", function.name, "\nWHEN dot.color ARGUMENT IS \"same\", THE COLUMN NAME IN dot.categ ARGUMENT MUST BE IDENTICAL TO THE LAST COLUMN NAME IN categ ARGUMENT. HERE IT IS:\ndot.categ: ", base::paste(ini.dot.categ, collapse = " "), "\ncateg: ", base::paste(categ, collapse = " "))
- base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}else if( ! fun_comp_1d(base::unlist(categ.class.order[base::length(categ)]), dot.categ.class.order)$identical.content){
- tempo.cat <- base::paste0("ERROR IN ", function.name, "\nWHEN dot.color ARGUMENT IS \"same\",\nLAST COMPARTMENT OF categ.class.order ARGUMENT AND dot.categ.class.order ARGUMENT CANNOT BE DIFFERENT:\nLAST COMPARTMENT OF categ.class.order: ", base::paste(base::unlist(categ.class.order[base::length(categ)]), collapse = " "), "\ndot.categ.class.order: ", paste(dot.categ.class.order, collapse = " "))
- base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::(is.null(warn), "", paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nWHEN dot.color ARGUMENT IS \"same\",\nLAST COMPARTMENT OF categ.class.order ARGUMENT AND dot.categ.class.order ARGUMENT CANNOT BE DIFFERENT:\nLAST COMPARTMENT OF categ.class.order: ", base::paste(base::unlist(categ.class.order[base::length(categ)]), collapse = " "), "\ndot.categ.class.order: ", base::paste(dot.categ.class.order, collapse = " "))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
}
for(i3 in 1:base::length(categ)){
@@ -1337,7 +1337,7 @@ ggbox <- function(
base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, color = categ[2]), stroke = dot.border.size, size = dot.size, alpha = dot.alpha, shape = 21))
base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = box.legend.name, values = if(base::is.null(categ.color)){base::rep(NA, base::length(base::unique(data1[, categ[2]])))}else if(base::length(categ.color)== 1L){base::rep(categ.color, base::length(base::unique(data1[, categ[2]])))}else{categ.color})) # categ.color used for dot colors because at that stage, we do not care about colors
base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, fill = categ[2]), coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf})) # fill because this is what is used with geom_box # to easily have the equivalent of the grouped boxes
- base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = box.legend.name, values = if(length(categ.color)== 1L){base::rep(categ.color, base::length(base::unique(data1[, categ[2]])))}else{categ.color}))
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = box.legend.name, values = if(base::length(categ.color)== 1L){base::rep(categ.color, base::length(base::unique(data1[, categ[2]])))}else{categ.color}))
# end per box dots coordinates recovery
}else{
tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 1")
@@ -1447,13 +1447,13 @@ ggbox <- function(
# normally this control is not necessary anymore
if(base::any( ! base::is.finite(y.lim))){ # normally no NA with is.finite
tempo.cat <- base::paste0("ERROR IN ", function.name, "\ny.lim ARGUMENT CANNOT HAVE ZERO OR NEGATIVE VALUES WITH THE y.log ARGUMENT SET TO ", y.log, ":\n", base::paste(y.lim, collapse = " "), "\nPLEASE, CHECK DATA VALUES (PRESENCE OF ZERO OR INF VALUES)")
- base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
}
if(base::suppressWarnings(base::all(y.lim %in% c(Inf, -Inf)))){ # all() without na.rm -> ok because y.lim cannot be NA (tested above)
# normally this control is not necessary anymore
tempo.cat <- base::paste0("ERROR IN ", function.name, " y.lim CONTAINS Inf VALUES, MAYBE BECAUSE VALUES FROM data1 ARGUMENTS ARE NA OR Inf ONLY OR BECAUSE OF LOG SCALE REQUIREMENT")
- base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
if(base::suppressWarnings(base::any(base::is.na(y.lim)))){ # normally no NA with is.na
# normally this control is not necessary anymore
@@ -1629,51 +1629,51 @@ ggbox <- function(
# tempo.mean[colnames(tempo.mean) != "MEAN"], # already added above
stringsAsFactors = TRUE
)
- stat$COLOR <- factor(stat$COLOR, levels = unique(categ.color))
- if( ! all(stat$NOTCH_SUP < stat$BOX_SUP & stat$NOTCH_INF > stat$BOX_INF, na.rm = TRUE) & box.notch == TRUE){
+ stat$COLOR <- base::factor(stat$COLOR, levels = base::unique(categ.color))
+ if( ! base::all(stat$NOTCH_SUP < stat$BOX_SUP & stat$NOTCH_INF > stat$BOX_INF, na.rm = TRUE) & box.notch == TRUE){
warn.count <- warn.count + 1
- tempo.warn <- paste0("(", warn.count,") SOME NOTCHES ARE BEYOND BOX HINGES. TRY ARGUMENT box.notch = FALSE")
- warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ tempo.warn <- base::paste0("(", warn.count,") SOME NOTCHES ARE BEYOND BOX HINGES. TRY ARGUMENT box.notch = FALSE")
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
}
}
- dot.jitter <- c((box.coord$xmax - width.correct) - (box.coord$xmin + width.correct))[1] * dot.jitter # real dot.jitter. (box.coord$xmin + width.correct) - (box.coord$xmax - width.correct))[1] is the width of the box. Is equivalent to (box.coord$x - (box.coord$xmin + width.correct))[1] * 2
+ dot.jitter <- base::c((box.coord$xmax - width.correct) - (box.coord$xmin + width.correct))[1] * dot.jitter # real dot.jitter. (box.coord$xmin + width.correct) - (box.coord$xmax - width.correct))[1] is the width of the box. Is equivalent to (box.coord$x - (box.coord$xmin + width.correct))[1] * 2
# end width commputations
- if( ! is.null(dot.color)){
+ if( ! base::is.null(dot.color)){
# random dots
if(dot.tidy == FALSE){
- dot.coord.rd1 <- merge(dot.coord, box.coord[c("fill", "PANEL", "group", "x")], by = c("PANEL", "group"), sort = FALSE) # rd for random. Send the coord of the boxes into the coord data.frame of the dots (in the column x.y). WARNING: by = c("PANEL", "group") without fill column because PANEL & group columns are enough as only one value of x column per group number in box.coord. Thus, no need to consider fill column
- if(nrow(dot.coord.rd1) != nrow(dot.coord)){
- tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nTHE merge() FUNCTION DID NOT RETURN A CORRECT dot.coord.rd1 DATA FRAME. CODE HAS TO BE MODIFIED")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ dot.coord.rd1 <- base::merge(dot.coord, box.coord[base::c("fill", "PANEL", "group", "x")], by = base::c("PANEL", "group"), sort = FALSE) # rd for random. Send the coord of the boxes into the coord data.frame of the dots (in the column x.y). WARNING: by = c("PANEL", "group") without fill column because PANEL & group columns are enough as only one value of x column per group number in box.coord. Thus, no need to consider fill column
+ if(base::nrow(dot.coord.rd1) != base::nrow(dot.coord)){
+ tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nTHE merge() FUNCTION DID NOT RETURN A CORRECT dot.coord.rd1 DATA FRAME. CODE HAS TO BE MODIFIED")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
- sampled.dot.jitter <- if(nrow(dot.coord.rd1)== 1L){runif(n = nrow(dot.coord.rd1), min = - dot.jitter / 2, max = dot.jitter / 2)}else{sample(x = runif(n = nrow(dot.coord.rd1), min = - dot.jitter / 2, max = dot.jitter / 2), size = nrow(dot.coord.rd1), replace = FALSE)}
- dot.coord.rd2 <- data.frame(dot.coord.rd1, dot.x = dot.coord.rd1$x.y + sampled.dot.jitter, stringsAsFactors = TRUE) # set the dot.jitter thanks to runif and dot.jitter range. Then, send the coord of the boxes into the coord data.frame of the dots (in the column x.y)
- if(length(categ)== 1L){
- tempo.data1 <- unique(data.frame(data1[categ[1]], group = as.integer(data1[, categ[1]]), stringsAsFactors = TRUE)) # categ[1] is factor
- names(tempo.data1)[names(tempo.data1) == categ[1]] <- paste0(categ[1], ".check")
- verif <- paste0(categ[1], ".check")
- }else if(length(categ) == 2L){
- tempo.data1 <- unique(
- data.frame(
- data1[c(categ[1], categ[2])],
- group = as.integer(factor(paste0(
- formatC(as.integer(data1[, categ[2]]), width = nchar(max(as.integer(data1[, categ[2]]), na.rm = TRUE)), flag = "0"), # convert factor into numeric with leading zero for proper ranking
+ sampled.dot.jitter <- if(base::nrow(dot.coord.rd1)== 1L){base::runif(n = base::nrow(dot.coord.rd1), min = - dot.jitter / 2, max = dot.jitter / 2)}else{base::sample(x = base::runif(n = base::nrow(dot.coord.rd1), min = - dot.jitter / 2, max = dot.jitter / 2), size = base::nrow(dot.coord.rd1), replace = FALSE)}
+ dot.coord.rd2 <- base::data.frame(dot.coord.rd1, dot.x = dot.coord.rd1$x.y + sampled.dot.jitter, stringsAsFactors = TRUE) # set the dot.jitter thanks to runif and dot.jitter range. Then, send the coord of the boxes into the coord data.frame of the dots (in the column x.y)
+ if(base::length(categ)== 1L){
+ tempo.data1 <- base::unique(base::data.frame(data1[categ[1]], group = base::as.integer(data1[, categ[1]]), stringsAsFactors = TRUE)) # categ[1] is factor
+ base::names(tempo.data1)[base::names(tempo.data1) == categ[1]] <- base::paste0(categ[1], ".check")
+ verif <- base::paste0(categ[1], ".check")
+ }else if(base::length(categ) == 2L){
+ tempo.data1 <- base::unique(
+ base::data.frame(
+ data1[base::c(categ[1], categ[2])],
+ group = base::as.integer(base::factor(base::paste0(
+ base::formatC(base::as.integer(data1[, categ[2]]), width = base::nchar(base::max(base::as.integer(data1[, categ[2]]), na.rm = TRUE)), flag = "0"), # convert factor into numeric with leading zero for proper ranking
".",
- formatC(as.integer(data1[, categ[1]]), width = nchar(max(as.integer(data1[, categ[1]]), na.rm = TRUE)), flag = "0")# convert factor into numeric with leading zero for proper ranking
+ base::formatC(base::as.integer(data1[, categ[1]]), width = base::nchar(base::max(base::as.integer(data1[, categ[1]]), na.rm = TRUE)), flag = "0")# convert factor into numeric with leading zero for proper ranking
)), stringsAsFactors = TRUE) # merge the 2 formatC() to create a new factor. The convertion to integer should recreate the correct group number
)
) # categ[2] first if categ[2] is used to make the categories in ggplot and categ[1] is used to make the x-axis
- names(tempo.data1)[names(tempo.data1) == categ[1]] <- paste0(categ[1], ".check")
- names(tempo.data1)[names(tempo.data1) == categ[2]] <- paste0(categ[2], ".check")
- verif <- c(paste0(categ[1], ".check"), paste0(categ[2], ".check"))
+ base::names(tempo.data1)[base::names(tempo.data1) == categ[1]] <- base::paste0(categ[1], ".check")
+ base::names(tempo.data1)[base::names(tempo.data1) == categ[2]] <- base::paste0(categ[2], ".check")
+ verif <- base::c(base::paste0(categ[1], ".check"), base::paste0(categ[2], ".check"))
}else{
- tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 3")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 3")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
- dot.coord.rd3 <- merge(dot.coord.rd2, tempo.data1, by = intersect("group", "group"), sort = FALSE) # send the factors of data1 into coord. WARNING: I have replaced by = "group" by intersect("group", "group") because of an error due to wrong group group merging in dot.coord.rd3
- if(nrow(dot.coord.rd3) != nrow(dot.coord) | ( ! saferTool::comp_2d(dot.coord.rd3[categ], dot.coord.rd3[verif])$identical.content)){
- tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nTHE merge() FUNCTION DID NOT RETURN A CORRECT dot.coord.rd3 DATA FRAME. CODE HAS TO BE MODIFIED")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ dot.coord.rd3 <- base::merge(dot.coord.rd2, tempo.data1, by = base::intersect("group", "group"), sort = FALSE) # send the factors of data1 into coord. WARNING: I have replaced by = "group" by intersect("group", "group") because of an error due to wrong group group merging in dot.coord.rd3
+ if(base::nrow(dot.coord.rd3) != base::nrow(dot.coord) | ( ! saferTool::comp_2d(dot.coord.rd3[categ], dot.coord.rd3[verif])$identical.content)){
+ tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nTHE merge() FUNCTION DID NOT RETURN A CORRECT dot.coord.rd3 DATA FRAME. CODE HAS TO BE MODIFIED")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
# end random dots
}
@@ -1691,94 +1691,94 @@ ggbox <- function(
coord.names <- NULL
# creation of the data frame for (main box + legend) and data frame for means
if(box.notch == FALSE){
- for(i3 in 1:length(categ)){
+ for(i3 in 1:base::length(categ)){
if(i3== 1L){
- tempo.polygon <- data.frame(GROUPX = c(t(stat[, rep(categ[i3], 5)])), stringsAsFactors = TRUE)
+ tempo.polygon <- base::data.frame(GROUPX = base::c(base::t(stat[, base::rep(categ[i3], 5)])), stringsAsFactors = TRUE)
}else{
- tempo.polygon <- cbind(tempo.polygon, c(t(stat[, rep(categ[i3], 5)])), stringsAsFactors = TRUE)
+ tempo.polygon <- base::cbind(tempo.polygon, base::c(base::t(stat[, base::rep(categ[i3], 5)])), stringsAsFactors = TRUE)
}
}
- names(tempo.polygon) <- categ
- tempo.polygon <- data.frame(X = c(t(stat[, c("X_BOX_INF", "X_BOX_SUP", "X_BOX_SUP", "X_BOX_INF", "X_BOX_INF")])), Y = c(t(stat[, c("BOX_INF", "BOX_INF", "BOX_SUP", "BOX_SUP", "BOX_INF")])), COLOR = c(t(stat[, c("COLOR", "COLOR", "COLOR", "COLOR", "COLOR")])), BOX = as.character(c(t(stat[, c("BOX", "BOX", "BOX", "BOX", "BOX")]))), tempo.polygon, stringsAsFactors = TRUE)
- if( ! is.null(facet.categ)){
- for(i4 in 1:length(facet.categ)){
- tempo.polygon <- data.frame(tempo.polygon, c(t(stat[, c(facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4])])), stringsAsFactors = TRUE)
- names(tempo.polygon)[length(names(tempo.polygon))] <- facet.categ[i4]
+ base::names(tempo.polygon) <- categ
+ tempo.polygon <- base::data.frame(X = base::c(t(stat[, base::c("X_BOX_INF", "X_BOX_SUP", "X_BOX_SUP", "X_BOX_INF", "X_BOX_INF")])), Y = base::c(t(stat[, c("BOX_INF", "BOX_INF", "BOX_SUP", "BOX_SUP", "BOX_INF")])), COLOR = c(t(stat[, base::c("COLOR", "COLOR", "COLOR", "COLOR", "COLOR")])), BOX = base::as.character(c(t(stat[, base::c("BOX", "BOX", "BOX", "BOX", "BOX")]))), tempo.polygon, stringsAsFactors = TRUE)
+ if( ! base::is.null(facet.categ)){
+ for(i4 in 1:base::length(facet.categ)){
+ tempo.polygon <- base::data.frame(tempo.polygon, base::c(base::t(stat[, base::c(facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4])])), stringsAsFactors = TRUE)
+ base::names(tempo.polygon)[base::length(base::names(tempo.polygon))] <- facet.categ[i4]
}
}
}else{
- for(i3 in 1:length(categ)){
+ for(i3 in 1:base::length(categ)){
if(i3== 1L){
- tempo.polygon <- data.frame(GROUPX = c(t(stat[, rep(categ[i3], 11)])), stringsAsFactors = TRUE)
+ tempo.polygon <- base::data.frame(GROUPX = base::c(base::t(stat[, base::rep(categ[i3], 11)])), stringsAsFactors = TRUE)
}else{
- tempo.polygon <- cbind(tempo.polygon, c(t(stat[, rep(categ[i3], 11)])), stringsAsFactors = TRUE)
+ tempo.polygon <- base::cbind(tempo.polygon, base::c(base::t(stat[, base::rep(categ[i3], 11)])), stringsAsFactors = TRUE)
}
}
- names(tempo.polygon) <- categ
- tempo.polygon <- data.frame(X = c(t(stat[, c("X_BOX_INF", "X_BOX_SUP", "X_BOX_SUP", "X_NOTCH_SUP", "X_BOX_SUP", "X_BOX_SUP", "X_BOX_INF", "X_BOX_INF", "X_NOTCH_INF", "X_BOX_INF", "X_BOX_INF")])), Y = c(t(stat[, c("BOX_INF", "BOX_INF", "NOTCH_INF", "MEDIAN", "NOTCH_SUP", "BOX_SUP", "BOX_SUP", "NOTCH_SUP", "MEDIAN", "NOTCH_INF", "BOX_INF")])), COLOR = c(t(stat[, c("COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR")])), BOX = as.character(c(t(stat[, c("BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX")]))), tempo.polygon, stringsAsFactors = TRUE)
- if( ! is.null(facet.categ)){
- for(i4 in 1:length(facet.categ)){
- tempo.polygon <- data.frame(tempo.polygon, c(t(stat[, c(facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4])])), stringsAsFactors = TRUE)
- names(tempo.polygon)[length(names(tempo.polygon))] <- facet.categ[i4]
+ base::names(tempo.polygon) <- categ
+ tempo.polygon <- base::data.frame(X = base::c(base::t(stat[, base::c("X_BOX_INF", "X_BOX_SUP", "X_BOX_SUP", "X_NOTCH_SUP", "X_BOX_SUP", "X_BOX_SUP", "X_BOX_INF", "X_BOX_INF", "X_NOTCH_INF", "X_BOX_INF", "X_BOX_INF")])), Y = base::c(base::t(stat[, base::c("BOX_INF", "BOX_INF", "NOTCH_INF", "MEDIAN", "NOTCH_SUP", "BOX_SUP", "BOX_SUP", "NOTCH_SUP", "MEDIAN", "NOTCH_INF", "BOX_INF")])), COLOR = base::c(base::t(stat[, base::c("COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR", "COLOR")])), BOX = base::as.character(c(t(stat[, base::c("BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX", "BOX")]))), tempo.polygon, stringsAsFactors = TRUE)
+ if( ! base::is.null(facet.categ)){
+ for(i4 in 1:base::length(facet.categ)){
+ tempo.polygon <- base::data.frame(tempo.polygon, base::c(base::t(stat[, base::c(facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4], facet.categ[i4])])), stringsAsFactors = TRUE)
+ base::names(tempo.polygon)[base::length(base::names(tempo.polygon))] <- facet.categ[i4]
}
}
}
- tempo.polygon$COLOR <- factor(tempo.polygon$COLOR, levels = unique(categ.color))
- if( ! is.null(categ.class.order)){
- for(i3 in 1:length(categ)){
- tempo.polygon[, categ[i3]] <- factor(tempo.polygon[, categ[i3]], levels = categ.class.order[[i3]])
+ tempo.polygon$COLOR <- base::factor(tempo.polygon$COLOR, levels = base::unique(categ.color))
+ if( ! base::is.null(categ.class.order)){
+ for(i3 in 1:base::length(categ)){
+ tempo.polygon[, categ[i3]] <- base::factor(tempo.polygon[, categ[i3]], levels = categ.class.order[[i3]])
}
}
# modified name of dot.categ column (e.g., "Categ1_DOT") must be included for boxplot using ridy dots
- if( ! is.null(dot.color) & ! is.null(dot.categ)){
+ if( ! base::is.null(dot.color) & ! base::is.null(dot.categ)){
if(dot.categ != ini.dot.categ){
- tempo.polygon <- data.frame(tempo.polygon, GROUPX = tempo.polygon[, ini.dot.categ], stringsAsFactors = TRUE)
- names(tempo.polygon)[names(tempo.polygon) == "GROUPX"] <- dot.categ
+ tempo.polygon <- base::data.frame(tempo.polygon, GROUPX = tempo.polygon[, ini.dot.categ], stringsAsFactors = TRUE)
+ base::names(tempo.polygon)[base::names(tempo.polygon) == "GROUPX"] <- dot.categ
}
}
- tempo.diamon.mean <- data.frame(X = c(t(stat[, c("X", "X_NOTCH_INF", "X", "X_NOTCH_SUP", "X")])), Y = c(t(cbind(stat["MEAN"] - (stat[, "X"] - stat[, "X_NOTCH_INF"]) * tempo.yx.ratio, stat["MEAN"], stat["MEAN"] + (stat[, "X"] - stat[, "X_NOTCH_INF"]) * tempo.yx.ratio, stat["MEAN"], stat["MEAN"] - (stat[, "X"] - stat[, "X_NOTCH_INF"]) * tempo.yx.ratio, stringsAsFactors = TRUE))), COLOR = c(t(stat[, c("COLOR", "COLOR", "COLOR", "COLOR", "COLOR")])), GROUP = c(t(stat[, c("BOX", "BOX", "BOX", "BOX", "BOX")])), stringsAsFactors = TRUE) # stringsAsFactors = TRUE for cbind() because stat["MEAN"] is a data frame. Otherwise, stringsAsFactors is not an argument for cbind() on vectors
- if( ! is.null(facet.categ)){
- for(i3 in 1:length(facet.categ)){
- tempo.diamon.mean <- data.frame(tempo.diamon.mean, c(t(stat[, c(facet.categ[i3], facet.categ[i3], facet.categ[i3], facet.categ[i3], facet.categ[i3])])), stringsAsFactors = TRUE)
- names(tempo.diamon.mean)[length(names(tempo.diamon.mean))] <- facet.categ[i3]
+ tempo.diamon.mean <- base::data.frame(X = base::c(base::t(stat[, base::c("X", "X_NOTCH_INF", "X", "X_NOTCH_SUP", "X")])), Y = base::c(base::t(base::cbind(stat["MEAN"] - (stat[, "X"] - stat[, "X_NOTCH_INF"]) * tempo.yx.ratio, stat["MEAN"], stat["MEAN"] + (stat[, "X"] - stat[, "X_NOTCH_INF"]) * tempo.yx.ratio, stat["MEAN"], stat["MEAN"] - (stat[, "X"] - stat[, "X_NOTCH_INF"]) * tempo.yx.ratio, stringsAsFactors = TRUE))), COLOR = base::c(base::t(stat[, base::c("COLOR", "COLOR", "COLOR", "COLOR", "COLOR")])), GROUP = base::c(base::t(stat[, base::c("BOX", "BOX", "BOX", "BOX", "BOX")])), stringsAsFactors = TRUE) # stringsAsFactors = TRUE for cbind() because stat["MEAN"] is a data frame. Otherwise, stringsAsFactors is not an argument for cbind() on vectors
+ if( ! base::is.null(facet.categ)){
+ for(i3 in 1:base::length(facet.categ)){
+ tempo.diamon.mean <- base::data.frame(tempo.diamon.mean, base::c(base::t(stat[, base::c(facet.categ[i3], facet.categ[i3], facet.categ[i3], facet.categ[i3], facet.categ[i3])])), stringsAsFactors = TRUE)
+ base::names(tempo.diamon.mean)[base::length(base::names(tempo.diamon.mean))] <- facet.categ[i3]
}
}
- tempo.diamon.mean$COLOR <- factor(tempo.diamon.mean$COLOR, levels = unique(categ.color))
+ tempo.diamon.mean$COLOR <- base::factor(tempo.diamon.mean$COLOR, levels = base::unique(categ.color))
# end creation of the data frame for (main box + legend) and data frame for means
if(box.fill == TRUE){
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, color = categ[length(categ)], fill = categ[length(categ)]), position = ggplot2::position_dodge(width = NULL), width = box.width, size = box.line.size, notch = box.notch, coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf}, alpha = box.alpha, outlier.shape = if( ! is.null(dot.color)){NA}else{21}, outlier.color = if( ! is.null(dot.color)){NA}else{dot.border.color}, outlier.fill = if( ! is.null(dot.color)){NA}else{NULL}, outlier.size = if( ! is.null(dot.color)){NA}else{dot.size}, outlier.stroke = if( ! is.null(dot.color)){NA}else{dot.border.size}, outlier.alpha = if( ! is.null(dot.color)){NA}else{dot.alpha})) # the color, size, etc. of the outliers are dealt here. outlier.color = NA to do not plot outliers when dots are already plotted. Finally, boxplot redrawn (see below)
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_polygon(
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_polygon(
data = tempo.polygon,
- mapping = ggplot2::aes_string(x = "X", y = "Y", group = "BOX", fill = categ[length(categ)], color = categ[length(categ)]),
+ mapping = ggplot2::aes_string(x = "X", y = "Y", group = "BOX", fill = categ[base::length(categ)], color = categ[base::length(categ)]),
size = box.line.size,
alpha = box.alpha # works only for fill, not for color
))
- coord.names <- c(coord.names, "main.box")
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X, xend = X, y = BOX_SUP, yend = WHISK_SUP, group = categ[length(categ)]), color = "black", size = box.line.size, alpha = box.alpha)) #
- coord.names <- c(coord.names, "sup.whisker")
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X, xend = X, y = BOX_INF, yend = WHISK_INF, group = categ[length(categ)]), color = "black", size = box.line.size, alpha = box.alpha)) #
- coord.names <- c(coord.names, "inf.whisker")
+ coord.names <- base::c(coord.names, "main.box")
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X, xend = X, y = BOX_SUP, yend = WHISK_SUP, group = categ[base::length(categ)]), color = "black", size = box.line.size, alpha = box.alpha)) #
+ coord.names <- base::c(coord.names, "sup.whisker")
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X, xend = X, y = BOX_INF, yend = WHISK_INF, group = categ[length(categ)]), color = "black", size = box.line.size, alpha = box.alpha)) #
+ coord.names <- base::c(coord.names, "inf.whisker")
if(box.whisker.width > 0){
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X_WHISK_INF, xend = X_WHISK_SUP, y = WHISK_SUP, yend = WHISK_SUP, group = categ[length(categ)]), color = "black", size = box.line.size, alpha = box.alpha, lineend = "round")) #
- coord.names <- c(coord.names, "sup.whisker.edge")
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X_WHISK_INF, xend = X_WHISK_SUP, y = WHISK_INF, yend = WHISK_INF, group = categ[length(categ)]), color = "black", size = box.line.size, alpha = box.alpha, lineend = "round")) #
- coord.names <- c(coord.names, "inf.whisker.edge")
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X_WHISK_INF, xend = X_WHISK_SUP, y = WHISK_SUP, yend = WHISK_SUP, group = categ[base::length(categ)]), color = "black", size = box.line.size, alpha = box.alpha, lineend = "round")) #
+ coord.names <- base::c(coord.names, "sup.whisker.edge")
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X_WHISK_INF, xend = X_WHISK_SUP, y = WHISK_INF, yend = WHISK_INF, group = categ[base::length(categ)]), color = "black", size = box.line.size, alpha = box.alpha, lineend = "round")) #
+ coord.names <- base::c(coord.names, "inf.whisker.edge")
}
if(box.mean == TRUE){
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(data = stat, mapping = ggplot2::aes_string(x = "X", y = "MEAN", group = categ[length(categ)]), shape = 23, stroke = box.line.size * 2, fill = stat$COLOR, size = box.mean.size, color = "black", alpha = box.alpha)) # group used in aesthetic to do not have it in the legend
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_polygon(
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_polygon(
data = tempo.diamon.mean,
mapping = ggplot2::aes(x = X, y = Y, group = GROUP),
fill = tempo.diamon.mean[, "COLOR"],
- color = hsv(0, 0, 0, alpha = box.alpha), # outline of the polygon in black but with alpha
+ color = base::hsv(0, 0, 0, alpha = box.alpha), # outline of the polygon in black but with alpha
size = box.line.size,
alpha = box.alpha
))
- coord.names <- c(coord.names, "mean")
+ coord.names <- base::c(coord.names, "mean")
}
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = if(box.notch == FALSE){X_BOX_INF}else{X_NOTCH_INF}, xend = if(box.notch == FALSE){X_BOX_SUP}else{X_NOTCH_SUP}, y = MEDIAN, yend = MEDIAN, group = categ[length(categ)]), color = "black", size = box.line.size * 2, alpha = box.alpha)) #
- coord.names <- c(coord.names, "median")
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = if(box.notch == FALSE){X_BOX_INF}else{X_NOTCH_INF}, xend = if(box.notch == FALSE){X_BOX_SUP}else{X_NOTCH_SUP}, y = MEDIAN, yend = MEDIAN, group = categ[base::length(categ)]), color = "black", size = box.line.size * 2, alpha = box.alpha)) #
+ coord.names <- base::c(coord.names, "median")
}
# end boxplot display before dot display if box.fill = TRUE
@@ -1788,25 +1788,25 @@ ggbox <- function(
# dot display
- if( ! is.null(dot.color)){
+ if( ! base::is.null(dot.color)){
if(dot.tidy == FALSE){
- if(is.null(dot.categ)){
+ if(base::is.null(dot.categ)){
if(dot.border.size == 0){
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(
data = dot.coord.rd3,
- mapping = ggplot2::aes_string(x = "dot.x", y = "y", group = categ[length(categ)]),
+ mapping = ggplot2::aes_string(x = "dot.x", y = "y", group = categ[base::length(categ)]),
size = dot.size,
shape = 19,
color = dot.coord.rd3$dot.color,
alpha = dot.alpha
)) # group used in aesthetic to do not have it in the legend. Here ggplot2::scale_discrete_manual() cannot be used because of the group easthetic
}else{
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(
data = dot.coord.rd3,
- mapping = ggplot2::aes_string(x = "dot.x", y = "y", group = categ[length(categ)]),
+ mapping = ggplot2::aes_string(x = "dot.x", y = "y", group = categ[base::length(categ)]),
shape = 21,
stroke = dot.border.size,
- color = if(is.null(dot.border.color)){dot.coord.rd3$dot.color}else{rep(dot.border.color, nrow(dot.coord.rd3))},
+ color = if(base::is.null(dot.border.color)){dot.coord.rd3$dot.color}else{base::rep(dot.border.color, base::nrow(dot.coord.rd3))},
size = dot.size,
fill = dot.coord.rd3$dot.color,
alpha = dot.alpha
@@ -1814,7 +1814,7 @@ ggbox <- function(
}
}else{
if(dot.border.size == 0){
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(
data = dot.coord.rd3,
mapping = ggplot2::aes_string(x = "dot.x", y = "y", alpha = dot.categ),
size = dot.size,
@@ -1822,22 +1822,22 @@ ggbox <- function(
color = dot.coord.rd3$dot.color
)) # group used in aesthetic to do not have it in the legend. Here ggplot2::scale_discrete_manual() cannot be used because of the group easthetic
}else{
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(
data = dot.coord.rd3,
mapping = ggplot2::aes_string(x = "dot.x", y = "y", alpha = dot.categ),
size = dot.size,
shape = 21,
stroke = dot.border.size,
- color = if(is.null(dot.border.color)){dot.coord.rd3$dot.color}else{rep(dot.border.color, nrow(dot.coord.rd3))},
+ color = if(base::is.null(dot.border.color)){dot.coord.rd3$dot.color}else{base::rep(dot.border.color, base::nrow(dot.coord.rd3))},
fill = dot.coord.rd3$dot.color
)) # group used in aesthetic to do not have it in the legend. Here ggplot2::scale_discrete_manual() cannot be used because of the group easthetic
}
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "alpha", name = dot.legend.name, values = rep(dot.alpha, length(dot.categ.class.order)), guide = ggplot2::guide_legend(override.aes = list(fill = dot.color, color = if(is.null(dot.border.color)){dot.color}else{dot.border.color}, stroke = dot.border.size, alpha = dot.alpha)))) # values are the values of color (which is the border color in geom_box. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "alpha", name = dot.legend.name, values = base::rep(dot.alpha, base::length(dot.categ.class.order)), guide = ggplot2::guide_legend(override.aes = base::list(fill = dot.color, color = if(base::is.null(dot.border.color)){dot.color}else{dot.border.color}, stroke = dot.border.size, alpha = dot.alpha)))) # values are the values of color (which is the border color in geom_box. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor
}
coord.names <- c(coord.names, "dots")
}else if(dot.tidy == TRUE){
# here plot using group -> no scale
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_dotplot(
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_dotplot(
data = dot.coord,
mapping = ggplot2::aes_string(x = categ[1], y = "y", group = "group"), # not dot.categ here because the classes of dot.categ create new separations
position = ggplot2::position_dodge(width = box.width),
@@ -1847,13 +1847,13 @@ ggbox <- function(
alpha = dot.alpha,
fill = dot.coord$dot.color,
stroke = dot.border.size,
- color = if(is.null(dot.border.color)){dot.coord$dot.color}else{rep(dot.border.color, nrow(dot.coord))},
+ color = if(base::is.null(dot.border.color)){dot.coord$dot.color}else{base::rep(dot.border.color, base::nrow(dot.coord))},
show.legend = FALSE, # WARNING: do not use show.legend = TRUE because it uses the arguments outside aes() as aesthetics (here color and fill). Thus I must find a way using ggplot2::scale_discrete_manual()
binwidth = (y.lim[2] - y.lim[1]) / dot.tidy.bin.nb
)) # geom_dotplot ggplot2 v3.3.0: I had to remove rev() in fill and color # very weird behavior of geom_dotplot ggplot2 v3.2.1, (1) because with aes group = (to avoid legend), the dot plotting is not good in term of coordinates, and (2) because data1 seems reorderer according to x = categ[1] before plotting. Thus, I have to use fill = dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"] to have the good corresponding colors # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.)
coord.names <- c(coord.names, "dots")
- if( ! is.null(dot.categ)){
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_dotplot(
+ if( ! base::is.null(dot.categ)){
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_dotplot(
data = dot.coord,
mapping = ggplot2::aes_string(x = categ[1], y = "y", alpha = dot.categ), # not dot.categ here because the classes of dot.categ create new separations
position = ggplot2::position_dodge(width = box.width),
@@ -1867,20 +1867,20 @@ ggbox <- function(
binwidth = (y.lim[2] - y.lim[1]) / dot.tidy.bin.nb
)) # geom_dotplot ggplot2 v3.3.0: I had to remove rev() in fill and color # very weird behavior of geom_dotplot ggplot2 v3.2.1, (1) because with aes group = (to avoid legend), the dot plotting is not good in term of coordinates, and (2) because data1 seems reorderer according to x = categ[1] before plotting. Thus, I have to use fill = dot.coord[rev(order(dot.coord[, categ[1]], decreasing = TRUE)), "dot.color"] to have the good corresponding colors # show.legend option do not remove the legend, only the aesthetic of the legend (dot, line, etc.)
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "linetype", name = dot.legend.name, values = rep(1, length(categ.color)))) # values = rep("black", length(categ.color)) are the values of color (which is the border color of dots), and this modify the border color on the plot. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor
- coord.names <- c(coord.names, "bad_remove")
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "alpha", name = dot.legend.name, values = rep(dot.alpha, length(dot.categ.class.order)), labels = dot.categ.class.order, guide = ggplot2::guide_legend(title = if(ini.dot.categ == categ[length(categ)]){dot.categ}else{ini.dot.categ}, override.aes = list(fill = levels(dot.coord$dot.color), color = if(is.null(dot.border.color)){levels(dot.coord$dot.color)}else{dot.border.color}, stroke = dot.border.size, alpha = dot.alpha)))) # values are the values of color (which is the border color in geom_box. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor
+ coord.names <- base::c(coord.names, "bad_remove")
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "alpha", name = dot.legend.name, values = base::rep(dot.alpha, base::length(dot.categ.class.order)), labels = dot.categ.class.order, guide = ggplot2::guide_legend(title = if(ini.dot.categ == categ[base::length(categ)]){dot.categ}else{ini.dot.categ}, override.aes = base::list(fill = base::levels(dot.coord$dot.color), color = if(base::is.null(dot.border.color)){base::levels(dot.coord$dot.color)}else{dot.border.color}, stroke = dot.border.size, alpha = dot.alpha)))) # values are the values of color (which is the border color in geom_box. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor
}
# coordinates of tidy dots
- tempo.coord <- ggplot2::ggplot_build(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$data # to have the tidy dot coordinates
- if(length(which(sapply(X = tempo.coord, FUN = function(X){any(names(X) == "binwidth", na.rm = TRUE)}))) != 1){ # detect the compartment of tempo.coord which is the binned data frame
+ tempo.coord <- ggplot2::ggplot_build(base::eval(base::parse(text = base::paste(base::paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "))))$data # to have the tidy dot coordinates
+ if(base::length(base::which(base::sapply(X = tempo.coord, FUN = function(X){base::any(base::names(X) == "binwidth", na.rm = TRUE)}))) != 1){ # detect the compartment of tempo.coord which is the binned data frame
# if(length(which(sapply(tempo.coord, FUN = nrow) == nrow(data1))) > if(is.null(dot.categ)){1}else{2}){ # this does not work if only one dot per class, thus replaced by above # if(is.null(dot.categ)){1}else{2} because 1 dotplot if dot.categ is NULL and 2 dotplots if not, with the second being a blank dotplot with wrong coordinates. Thus take the first in that situation
- tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nEITHER MORE THAN 1 OR NO COMPARTMENT HAVING A DATA FRAME WITH binwidth AS COLUMN NAME IN THE tempo.coord LIST (FOR TIDY DOT COORDINATES). CODE HAS TO BE MODIFIED")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nEITHER MORE THAN 1 OR NO COMPARTMENT HAVING A DATA FRAME WITH binwidth AS COLUMN NAME IN THE tempo.coord LIST (FOR TIDY DOT COORDINATES). CODE HAS TO BE MODIFIED")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}else{
# dot.coord.tidy1 <- tempo.coord[[which(sapply(tempo.coord, FUN = nrow) == nrow(data1))[1]]] # this does not work if only one dot per class, thus replaced by above # the second being a blank dotplot with wrong coordinates. Thus take the first whatever situation
- dot.coord.tidy1 <- tempo.coord[[which(sapply(X = tempo.coord, FUN = function(X){any(names(X) == "binwidth", na.rm = TRUE)}))]] # detect the compartment of tempo.coord which is the binned data frame
- dot.coord.tidy1$x <- as.numeric(dot.coord.tidy1$x) # because weird class
- dot.coord.tidy1$PANEL <- as.numeric(dot.coord.tidy1$PANEL) # because numbers as levels. But may be a problem is facet are reordered ?
+ dot.coord.tidy1 <- tempo.coord[[base::which(base::sapply(X = tempo.coord, FUN = function(X){base::any(base::names(X) == "binwidth", na.rm = TRUE)}))]] # detect the compartment of tempo.coord which is the binned data frame
+ dot.coord.tidy1$x <- base::as.numeric(dot.coord.tidy1$x) # because weird class
+ dot.coord.tidy1$PANEL <- base::as.numeric(dot.coord.tidy1$PANEL) # because numbers as levels. But may be a problem is facet are reordered ?
}
# tempo.box.coord <- merge(box.coord, unique(dot.coord[, c("PANEL", "group", categ)]), by = c("PANEL", "group"), sort = FALSE) # not required anymore because box.coord already contains categ do not add dot.categ and tidy_group_coord here because the coordinates are for stats. Add the categ in box.coord. WARNING: by = c("PANEL", "group") without fill column because PANEL & group columns are enough as only one value of x column per group number in box.coord. Thus, no need to consider fill column
# below inactivated because not true when dealing with dot.categ different from categ
@@ -1888,38 +1888,38 @@ ggbox <- function(
# tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nTHE merge() FUNCTION DID NOT RETURN A CORRECT tempo.box.coord DATA FRAME. 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 ==
# }
- dot.coord.tidy2 <- merge(dot.coord.tidy1, box.coord[c("fill", "PANEL", "group", "x", categ)], by = c("PANEL", "group"), sort = FALSE) # send the coord of the boxes into the coord data.frame of the dots (in the column x.y).WARNING: by = c("PANEL", "group") without fill column because PANEL & group columns are enough as only one value of x column per group number in tempo.box.coord. Thus, no need to consider fill colum # DANGER: from here the fill.y and x.y (from tempo.box.coord) are not good in dot.coord.tidy2. It is ok because Categ1 Categ2 from tempo.box.coord are ok with the group column from dot.coord.tidy1. This is due to the fact that dot.coord.tidy resulting from geom_dotplot does not make the same groups as the other functions
- if(nrow(dot.coord.tidy2) != nrow(dot.coord)){
- tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nTHE merge() FUNCTION DID NOT RETURN A CORRECT dot.coord.tidy2 DATA FRAME. CODE HAS TO BE MODIFIED")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ dot.coord.tidy2 <- base::merge(dot.coord.tidy1, box.coord[base::c("fill", "PANEL", "group", "x", categ)], by = base::c("PANEL", "group"), sort = FALSE) # send the coord of the boxes into the coord data.frame of the dots (in the column x.y).WARNING: by = c("PANEL", "group") without fill column because PANEL & group columns are enough as only one value of x column per group number in tempo.box.coord. Thus, no need to consider fill colum # DANGER: from here the fill.y and x.y (from tempo.box.coord) are not good in dot.coord.tidy2. It is ok because Categ1 Categ2 from tempo.box.coord are ok with the group column from dot.coord.tidy1. This is due to the fact that dot.coord.tidy resulting from geom_dotplot does not make the same groups as the other functions
+ if(base::nrow(dot.coord.tidy2) != base::nrow(dot.coord)){
+ tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nTHE merge() FUNCTION DID NOT RETURN A CORRECT dot.coord.tidy2 DATA FRAME. CODE HAS TO BE MODIFIED")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
# From here, check for dot.coord.tidy3 which wil be important for stat over the plot. WARNING: dot.categ has nothing to do here for stat coordinates. Thus, not in tempo.data1
- if(length(categ)== 1L){
- tempo.data1 <- unique(data.frame(data1[categ[1]], group = as.integer(data1[, categ[1]]), stringsAsFactors = TRUE)) # categ[1] is factor
- names(tempo.data1)[names(tempo.data1) == categ[1]] <- paste0(categ[1], ".check")
- verif <- paste0(categ[1], ".check")
- }else if(length(categ) == 2L){
- tempo.data1 <- unique(
- data.frame(
- data1[c(categ[1], categ[2])],
- group = as.integer(factor(paste0(
- formatC(as.integer(data1[, categ[2]]), width = nchar(max(as.integer(data1[, categ[2]]), na.rm = TRUE)), flag = "0"), # convert factor into numeric with leading zero for proper ranking
+ if(base::length(categ)== 1L){
+ tempo.data1 <- base::unique(base::data.frame(data1[categ[1]], group = base::as.integer(data1[, categ[1]]), stringsAsFactors = TRUE)) # categ[1] is factor
+ base::names(tempo.data1)[base::names(tempo.data1) == categ[1]] <- base::paste0(categ[1], ".check")
+ verif <- base::paste0(categ[1], ".check")
+ }else if(base::length(categ) == 2L){
+ tempo.data1 <- base::unique(
+ base::data.frame(
+ data1[base::c(categ[1], categ[2])],
+ group = base::as.integer(base::factor(base::paste0(
+ base::formatC(base::as.integer(data1[, categ[2]]), width = base::nchar(base::max(base::as.integer(data1[, categ[2]]), na.rm = TRUE)), flag = "0"), # convert factor into numeric with leading zero for proper ranking
".",
- formatC(as.integer(data1[, categ[1]]), width = nchar(max(as.integer(data1[, categ[1]]), na.rm = TRUE)), flag = "0")# convert factor into numeric with leading zero for proper ranking
+ base::formatC(base::as.integer(data1[, categ[1]]), width = base::nchar(base::max(base::as.integer(data1[, categ[1]]), na.rm = TRUE)), flag = "0")# convert factor into numeric with leading zero for proper ranking
)), stringsAsFactors = TRUE) # merge the 2 formatC() to create a new factor. The convertion to integer should recreate the correct group number
)
) # categ[2] first if categ[2] is used to make the categories in ggplot and categ[1] is used to make the x-axis
- names(tempo.data1)[names(tempo.data1) == categ[1]] <- paste0(categ[1], ".check")
- names(tempo.data1)[names(tempo.data1) == categ[2]] <- paste0(categ[2], ".check")
- verif <- c(paste0(categ[1], ".check"), paste0(categ[2], ".check"))
+ base::names(tempo.data1)[base::names(tempo.data1) == categ[1]] <- base::paste0(categ[1], ".check")
+ base::names(tempo.data1)[base::names(tempo.data1) == categ[2]] <- base::paste0(categ[2], ".check")
+ verif <- base::c(base::paste0(categ[1], ".check"), base::paste0(categ[2], ".check"))
}else{
- tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 4")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 4")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
- dot.coord.tidy3 <- merge(dot.coord.tidy2, tempo.data1, by = intersect("group", "group"), sort = FALSE) # send the factors of data1 into coord. WARNING: I have tested intersect("group", "group") instead of by = "group". May be come back to by = "group" in case of error. But I did this because of an error in dot.coord.rd3 above
- if(nrow(dot.coord.tidy3) != nrow(dot.coord) | ( ! saferTool::comp_2d(dot.coord.tidy3[categ], dot.coord.tidy3[verif])$identical.content)){
- tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nTHE merge() FUNCTION DID NOT RETURN A CORRECT dot.coord.tidy3 DATA FRAME. CODE HAS TO BE MODIFIED")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ dot.coord.tidy3 <- base::merge(dot.coord.tidy2, tempo.data1, by = base::intersect("group", "group"), sort = FALSE) # send the factors of data1 into coord. WARNING: I have tested intersect("group", "group") instead of by = "group". May be come back to by = "group" in case of error. But I did this because of an error in dot.coord.rd3 above
+ if(base::nrow(dot.coord.tidy3) != base::nrow(dot.coord) | ( ! saferTool::comp_2d(dot.coord.tidy3[categ], dot.coord.tidy3[verif])$identical.content)){
+ tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nTHE merge() FUNCTION DID NOT RETURN A CORRECT dot.coord.tidy3 DATA FRAME. CODE HAS TO BE MODIFIED")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
# end coordinates of tidy dots
}
@@ -1931,34 +1931,34 @@ ggbox <- function(
# boxplot display (if box.fill = FALSE, otherwise, already plotted above)
if(box.fill == TRUE){
# overcome "work only for the filling of boxes, not for the frame. See https://github.com/tidyverse/ggplot2/issues/252"
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = box.legend.name, values = if(length(categ.color)== 1L){rep(categ.color, length(unique(data1[, categ[length(categ)]])))}else{categ.color}, guide = ggplot2::guide_legend(order = 1))) #, guide = ggplot2::guide_legend(override.aes = list(fill = levels(tempo.polygon$COLOR), color = "black")))) # values are the values of color (which is the border color in geom_box. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = box.legend.name, values = rep(hsv(0, 0, 0, alpha = box.alpha), length(unique(data1[, categ[length(categ)]]))), guide = ggplot2::guide_legend(order = 1))) # , guide = ggplot2::guide_legend(override.aes = list(color = "black", alpha = box.alpha)))) # values are the values of color (which is the border color in geom_box. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor # outline of the polygon in black but with alpha
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = box.legend.name, values = if(base::length(categ.color)== 1L){rep(categ.color, base::length(base::unique(data1[, categ[base::length(categ)]])))}else{categ.color}, guide = ggplot2::guide_legend(order = 1))) #, guide = ggplot2::guide_legend(override.aes = list(fill = levels(tempo.polygon$COLOR), color = "black")))) # values are the values of color (which is the border color in geom_box. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = box.legend.name, values = base::rep(base::hsv(0, 0, 0, alpha = box.alpha), base::length(base::unique(data1[, categ[base::length(categ)]]))), guide = ggplot2::guide_legend(order = 1))) # , guide = ggplot2::guide_legend(override.aes = list(color = "black", alpha = box.alpha)))) # values are the values of color (which is the border color in geom_box. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor # outline of the polygon in black but with alpha
}else{
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_boxplot(data = data1, mapping = ggplot2::aes_string(x = categ[1], y = y, color = categ[length(categ)], fill = categ[length(categ)]), position = ggplot2::position_dodge(width = NULL), width = box.width, size = box.line.size, notch = box.notch, alpha = box.alpha, coef = if(box.whisker.kind == "no"){0}else if(box.whisker.kind == "std"){1.5}else if(box.whisker.kind == "max"){Inf}, outlier.shape = if( ! is.null(dot.color)){NA}else{21}, outlier.color = if( ! is.null(dot.color)){NA}else{if(dot.border.size == 0){NA}else{dot.border.color}}, outlier.fill = if( ! is.null(dot.color)){NA}else{NULL}, outlier.size = if( ! is.null(dot.color)){NA}else{dot.size}, outlier.stroke = if( ! is.null(dot.color)){NA}else{dot.border.size}, outlier.alpha = if( ! is.null(dot.color)){NA}else{dot.alpha})) # the color, size, etc. of the outliers are dealt here. outlier.color = NA to do not plot outliers when dots are already plotted
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_path(
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_path(
data = tempo.polygon,
- mapping = ggplot2::aes_string(x = "X", y = "Y", group = "BOX", color = categ[length(categ)]),
+ mapping = ggplot2::aes_string(x = "X", y = "Y", group = "BOX", color = categ[base::length(categ)]),
size = box.line.size,
alpha = box.alpha,
lineend = "round",
linejoin = "round"
))
- coord.names <- c(coord.names, "main.box")
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = if(box.notch == FALSE){X_BOX_INF}else{X_NOTCH_INF}, xend = if(box.notch == FALSE){X_BOX_SUP}else{X_NOTCH_SUP}, y = MEDIAN, yend = MEDIAN, group = categ[length(categ)]), color = stat$COLOR, size = box.line.size * 2, alpha = box.alpha)) #
- coord.names <- c(coord.names, "median")
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X, xend = X, y = BOX_SUP, yend = WHISK_SUP, group = categ[length(categ)]), color = stat$COLOR, size = box.line.size, alpha = box.alpha)) #
- coord.names <- c(coord.names, "sup.whisker")
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X, xend = X, y = BOX_INF, yend = WHISK_INF, group = categ[length(categ)]), color = stat$COLOR, size = box.line.size, alpha = box.alpha)) #
- coord.names <- c(coord.names, "inf.whisker")
+ coord.names <- base::c(coord.names, "main.box")
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = if(box.notch == FALSE){X_BOX_INF}else{X_NOTCH_INF}, xend = if(box.notch == FALSE){X_BOX_SUP}else{X_NOTCH_SUP}, y = MEDIAN, yend = MEDIAN, group = categ[base::length(categ)]), color = stat$COLOR, size = box.line.size * 2, alpha = box.alpha)) #
+ coord.names <- base::c(coord.names, "median")
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X, xend = X, y = BOX_SUP, yend = WHISK_SUP, group = categ[base::length(categ)]), color = stat$COLOR, size = box.line.size, alpha = box.alpha)) #
+ coord.names <- base::c(coord.names, "sup.whisker")
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X, xend = X, y = BOX_INF, yend = WHISK_INF, group = categ[base::length(categ)]), color = stat$COLOR, size = box.line.size, alpha = box.alpha)) #
+ coord.names <- base::c(coord.names, "inf.whisker")
if(box.whisker.width > 0){
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X_WHISK_INF, xend = X_WHISK_SUP, y = WHISK_SUP, yend = WHISK_SUP, group = categ[length(categ)]), color = stat$COLOR, size = box.line.size, alpha = box.alpha, lineend = "round")) #
- coord.names <- c(coord.names, "sup.whisker.edge")
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X_WHISK_INF, xend = X_WHISK_SUP, y = WHISK_INF, yend = WHISK_INF, group = categ[length(categ)]), color = stat$COLOR, size = box.line.size, alpha = box.alpha, lineend = "round")) #
+ base:: assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X_WHISK_INF, xend = X_WHISK_SUP, y = WHISK_SUP, yend = WHISK_SUP, group = categ[base::length(categ)]), color = stat$COLOR, size = box.line.size, alpha = box.alpha, lineend = "round")) #
+ coord.names <- base::c(coord.names, "sup.whisker.edge")
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_segment(data = stat, mapping = ggplot2::aes(x = X_WHISK_INF, xend = X_WHISK_SUP, y = WHISK_INF, yend = WHISK_INF, group = categ[base::length(categ)]), color = stat$COLOR, size = box.line.size, alpha = box.alpha, lineend = "round")) #
coord.names <- c(coord.names, "inf.whisker.edge")
}
if(box.mean == TRUE){
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_point(data = stat, mapping = ggplot2::aes_string(x = "X", y = "MEAN", group = categ[length(categ)]), shape = 23, stroke = box.line.size * 2, color = stat$COLOR, size = box.mean.size, fill = NA, alpha = box.alpha)) # group used in aesthetic to do not have it in the legend. Here ggplot2::scale_discrete_manual() cannot be used because of the group easthetic
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_path(
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_path(
data = tempo.diamon.mean,
mapping = ggplot2::aes(x = X, y = Y, group = GROUP),
color = tempo.diamon.mean[, "COLOR"],
@@ -1969,18 +1969,18 @@ ggbox <- function(
))
coord.names <- c(coord.names, "mean")
}
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = box.legend.name, values = rep(NA, length(unique(data1[, categ[length(categ)]]))))) #, guide = ggplot2::guide_legend(override.aes = list(color = categ.color)))) # values are the values of color (which is the border color in geom_box. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = box.legend.name, values = if(length(categ.color)== 1L){rep(categ.color, length(unique(data1[, categ[length(categ)]])))}else{categ.color}, guide = ggplot2::guide_legend(override.aes = list(alpha = if(plot == TRUE & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list()) == 0L & Sys.info()["sysname"] == "Windows"))){1}else{box.alpha})))) # , guide = ggplot2::guide_legend(override.aes = list(color = as.character(categ.color))))) # values are the values of color (which is the border color in geom_box. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor
- if(plot == TRUE & ((length(dev.list()) > 0 & names(dev.cur()) == "windows") | (length(dev.list()) == 0L & Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "fill", name = box.legend.name, values = base::rep(NA, base::length(base::unique(data1[, categ[base::length(categ)]]))))) #, guide = ggplot2::guide_legend(override.aes = list(color = categ.color)))) # values are the values of color (which is the border color in geom_box. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_discrete_manual(aesthetics = "color", name = box.legend.name, values = if(base::length(categ.color)== 1L){base::rep(categ.color, base::length(base::unique(data1[, categ[base::length(categ)]])))}else{categ.color}, guide = ggplot2::guide_legend(override.aes = base::list(alpha = if(plot == TRUE & ((base::length(base::dev.list()) > 0 & base::names(base::dev.cur()) == "windows") | (base::length(base::dev.list()) == 0L & base::Sys.info()["sysname"] == "Windows"))){1}else{box.alpha})))) # , guide = ggplot2::guide_legend(override.aes = list(color = as.character(categ.color))))) # values are the values of color (which is the border color in geom_box. WARNING: values = categ.color takes the numbers to make the colors if categ.color is a factor
+ if(plot == TRUE & ((base::length(base::dev.list()) > 0 & base::names(base::dev.cur()) == "windows") | (base::length(base::dev.list()) == 0L & base::Sys.info()["sysname"] == "Windows"))){ # if any Graph device already open and this device is "windows", or if no Graph device opened yet and we are on windows system -> prevention of alpha legend bug on windows using value 1
# to avoid a bug on windows: if alpha argument is different from 1 for lines (transparency), then lines are not correctly displayed in the legend when using the R GUI (bug https://github.com/tidyverse/ggplot2/issues/2452). No bug when using a pdf
warn.count <- warn.count + 1
- tempo.warn <- paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE LINES IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
- warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ tempo.warn <- base::paste0("(", warn.count,") GRAPHIC DEVICE USED ON A WINDOWS SYSTEM ->\nTRANSPARENCY OF THE LINES IS INACTIVATED IN THE LEGEND TO PREVENT A WINDOWS DEPENDENT BUG (SEE https://github.com/tidyverse/ggplot2/issues/2452)\nTO OVERCOME THIS ON WINDOWS, USE ANOTHER DEVICE (pdf() FOR INSTANCE)")
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
}
}
if(box.alpha == 0){ # remove box legend because no boxes drawn
# add this after the scale_xxx_manual() for boxplots
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(fill = "none", color = "none")) # inactivate the legend
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(fill = "none", color = "none")) # inactivate the legend
}
# end boxplot display (if box.fill = FALSE, otherwise, already plotted above)
@@ -1989,16 +1989,16 @@ ggbox <- function(
# stat display
# layer after dots but ok, behind dots on the plot
- if( ! is.null(stat.pos)){
+ if( ! base::is.null(stat.pos)){
warn.count <- warn.count + 1
- tempo.warn <- paste0("(", warn.count,") NUMBERS DISPLAYED ARE ", ifelse(stat.mean == FALSE, "MEDIANS", "MEANS"))
- warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ tempo.warn <- base::paste0("(", warn.count,") NUMBERS DISPLAYED ARE ", base::ifelse(stat.mean == FALSE, "MEDIANS", "MEANS"))
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
if(stat.pos == "top"){
- tempo.stat <- data.frame(stat, Y = y.lim[2], stringsAsFactors = TRUE) # I had to create a data frame for geom_tex() so that facet is taken into account, (ggplot2::annotate() does not deal with facet because no data and mapping arguments). Of note, facet.categ is in tempo.stat, via tempo.mean, via dot.coord
- if(stat.mean == FALSE){tempo.stat$MEDIAN <- formatC(stat.nolog$MEDIAN, digit = 2, drop0trailing = TRUE, format = "f")}else{tempo.stat$MEAN <- formatC(stat.nolog$MEAN, digit = 2, drop0trailing = TRUE, format = "f")}
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_text(
+ tempo.stat <- base::data.frame(stat, Y = y.lim[2], stringsAsFactors = TRUE) # I had to create a data frame for geom_tex() so that facet is taken into account, (ggplot2::annotate() does not deal with facet because no data and mapping arguments). Of note, facet.categ is in tempo.stat, via tempo.mean, via dot.coord
+ if(stat.mean == FALSE){tempo.stat$MEDIAN <- base::formatC(stat.nolog$MEDIAN, digit = 2, drop0trailing = TRUE, format = "f")}else{tempo.stat$MEAN <- base::formatC(stat.nolog$MEAN, digit = 2, drop0trailing = TRUE, format = "f")}
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_text(
data = tempo.stat,
- mapping = ggplot2::aes_string(x = "X", y = "Y", label = ifelse(stat.mean == FALSE, "MEDIAN", "MEAN")),
+ mapping = ggplot2::aes_string(x = "X", y = "Y", label = base::ifelse(stat.mean == FALSE, "MEDIAN", "MEAN")),
size = stat.size,
color = "black",
angle = stat.angle,
@@ -2008,42 +2008,42 @@ ggbox <- function(
coord.names <- c(coord.names, "stat.pos")
}else if(stat.pos == "above"){
# stat coordinates
- if( ! is.null(dot.color)){ # for text just above max dot
+ if( ! base::is.null(dot.color)){ # for text just above max dot
if(dot.tidy == FALSE){
tempo.stat.ini <- dot.coord.rd3
}else if(dot.tidy == TRUE){
tempo.stat.ini <- dot.coord.tidy3
tempo.stat.ini$x.y <- tempo.stat.ini$x.x # this is just to be able to use tempo.stat.ini$x.y for untidy or tidy dots (remember that dot.coord.tidy3$x.y is not good, see above)
}
- stat.coord1 <- aggregate(x = tempo.stat.ini["y"], by = {x.env <- if(length(categ)== 1L){list(tempo.stat.ini$group, tempo.stat.ini$PANEL, tempo.stat.ini$x.y, tempo.stat.ini[, categ[1]])}else if(length(categ) == 2L){list(tempo.stat.ini$group, tempo.stat.ini$PANEL, tempo.stat.ini$x.y, tempo.stat.ini[, categ[1]], tempo.stat.ini[, categ[2]])} ; names(x.env) <- if(length(categ)== 1L){c("group", "PANEL", "x.y", categ[1])}else if(length(categ) == 2L){c("group", "PANEL", "x.y", categ[1], categ[2])} ; x.env}, FUN = min, na.rm = TRUE)
- names(stat.coord1)[names(stat.coord1) == "y"] <- "dot.min"
- stat.coord2 <- aggregate(x = tempo.stat.ini["y"], by = {x.env <- if(length(categ)== 1L){list(tempo.stat.ini$group, tempo.stat.ini$PANEL, tempo.stat.ini$x.y, tempo.stat.ini[, categ[1]])}else if(length(categ) == 2L){list(tempo.stat.ini$group, tempo.stat.ini$PANEL, tempo.stat.ini$x.y, tempo.stat.ini[, categ[1]], tempo.stat.ini[, categ[2]])} ; names(x.env) <- if(length(categ)== 1L){c("group", "PANEL", "x.y", categ[1])}else if(length(categ) == 2L){c("group", "PANEL", "x.y", categ[1], categ[2])} ; x.env}, FUN = max, na.rm = TRUE)
- names(stat.coord2) <- paste0(names(stat.coord2), "_from.dot.max")
- names(stat.coord2)[names(stat.coord2) == "y_from.dot.max"] <- "dot.max"
- stat.coord3 <- cbind(box.coord[order(box.coord$group, box.coord$PANEL), ], stat.coord1[order(stat.coord1$group, stat.coord1$x.y), ], stat.coord2[order(stat.coord2$group, stat.coord2$x.y), ], stringsAsFactors = TRUE) #
- if( ! all(identical(round(stat.coord3$x, 9), round(as.numeric(stat.coord3$x.y), 9)), na.rm = TRUE)){ # as.numeric() because stat.coord3$x is class "mapped_discrete" "numeric"
- tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nFUSION OF box.coord, stat.coord1 AND stat.coord2 ACCORDING TO box.coord$x, stat.coord1$x.y AND stat.coord2$x.y IS NOT CORRECT. CODE HAS TO BE MODIFIED")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ stat.coord1 <- base::aggregate(x = tempo.stat.ini["y"], by = {x.env <- if(base::length(categ)== 1L){base::list(tempo.stat.ini$group, tempo.stat.ini$PANEL, tempo.stat.ini$x.y, tempo.stat.ini[, categ[1]])}else if(base::length(categ) == 2L){base::list(tempo.stat.ini$group, tempo.stat.ini$PANEL, tempo.stat.ini$x.y, tempo.stat.ini[, categ[1]], tempo.stat.ini[, categ[2]])} ;base::names(x.env) <- if(base::length(categ)== 1L){base::c("group", "PANEL", "x.y", categ[1])}else if(base::length(categ) == 2L){base::c("group", "PANEL", "x.y", categ[1], categ[2])} ; x.env}, FUN = min, na.rm = TRUE)
+ base::names(stat.coord1)[base::names(stat.coord1) == "y"] <- "dot.min"
+ stat.coord2 <- base::aggregate(x = tempo.stat.ini["y"], by = {x.env <- if(base::length(categ)== 1L){base::list(tempo.stat.ini$group, tempo.stat.ini$PANEL, tempo.stat.ini$x.y, tempo.stat.ini[, categ[1]])}else if(base::length(categ) == 2L){base::list(tempo.stat.ini$group, tempo.stat.ini$PANEL, tempo.stat.ini$x.y, tempo.stat.ini[, categ[1]], tempo.stat.ini[, categ[2]])} ; base::names(x.env) <- if(base::length(categ)== 1L){base::c("group", "PANEL", "x.y", categ[1])}else if(length(categ) == 2L){base::c("group", "PANEL", "x.y", categ[1], categ[2])} ; x.env}, FUN = max, na.rm = TRUE)
+ base::names(stat.coord2) <- base::paste0(base::names(stat.coord2), "_from.dot.max")
+ base::names(stat.coord2)[base::names(stat.coord2) == "y_from.dot.max"] <- "dot.max"
+ stat.coord3 <- base::cbind(box.coord[base::order(box.coord$group, box.coord$PANEL), ], stat.coord1[base::order(stat.coord1$group, stat.coord1$x.y), ], stat.coord2[base::order(stat.coord2$group, stat.coord2$x.y), ], stringsAsFactors = TRUE) #
+ if( ! base::all(base::identical(base::round(stat.coord3$x, 9), base::round(base::as.numeric(stat.coord3$x.y), 9)), na.rm = TRUE)){ # as.numeric() because stat.coord3$x is class "mapped_discrete" "numeric"
+ tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nFUSION OF box.coord, stat.coord1 AND stat.coord2 ACCORDING TO box.coord$x, stat.coord1$x.y AND stat.coord2$x.y IS NOT CORRECT. CODE HAS TO BE MODIFIED")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
# text.coord <- stat.coord3[, c("x", "group", "dot.min", "dot.max")]
# names(text.coord)[names(text.coord) == "dot.min"] <- "text.min.pos"
#names(text.coord)[names(text.coord) == "dot.max"] <- "text.max.pos"
- box.coord <- box.coord[order(box.coord$x, box.coord$group, box.coord$PANEL), ]
+ box.coord <- box.coord[base::order(box.coord$x, box.coord$group, box.coord$PANEL), ]
# text.coord <- text.coord[order(text.coord$x), ] # to be sure to have the two objects in the same order for x. WARNING: cannot add identical(as.integer(text.coord$group), as.integer(box.coord$group)) because with error, the correspondence between x and group is not the same
- stat.coord3 <- stat.coord3[order(stat.coord3$x, stat.coord3$group, stat.coord3$PANEL), ] # to be sure to have the two objects in the same order for x. WARNING: cannot add identical(as.integer(text.coord$group), as.integer(box.coord$group)) because with error, the correspondence between x and group is not the same
- if( ! (identical(box.coord$x, stat.coord3$x) & identical(box.coord$group, stat.coord3$group) & identical(box.coord$PANEL, stat.coord3$PANEL))){
- tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\ntext.coord AND box.coord DO NOT HAVE THE SAME x, group AND PANEL COLUMN CONTENT")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ stat.coord3 <- stat.coord3[base::order(stat.coord3$x, stat.coord3$group, stat.coord3$PANEL), ] # to be sure to have the two objects in the same order for x. WARNING: cannot add identical(as.integer(text.coord$group), as.integer(box.coord$group)) because with error, the correspondence between x and group is not the same
+ if( ! (base::identical(box.coord$x, stat.coord3$x) & base::identical(box.coord$group, stat.coord3$group) & base::identical(box.coord$PANEL, stat.coord3$PANEL))){
+ tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\ntext.coord AND box.coord DO NOT HAVE THE SAME x, group AND PANEL COLUMN CONTENT")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
}else{
stat.coord3 <- box.coord
}
- stat.coord3 <- data.frame(
+ stat.coord3 <- base::data.frame(
stat.coord3,
- Y = stat.coord3[, ifelse(
- is.null(dot.color),
- ifelse(diff(y.lim) > 0, "ymax", "ymin"),
- ifelse(diff(y.lim) > 0, "ymax_final", "ymin_final")
+ Y = stat.coord3[, base::ifelse(
+ base::is.null(dot.color),
+ base::ifelse(base::diff(y.lim) > 0, "ymax", "ymin"),
+ base::ifelse(base::diff(y.lim) > 0, "ymax_final", "ymin_final")
)],
stringsAsFactors = TRUE
) # ymax is top whisker, ymax_final is top dot
@@ -2073,13 +2073,13 @@ ggbox <- function(
# end add distance
# correct median or mean text format
if(y.log != "no"){
- stat.coord3[, tempo.center.ref] <- ifelse(y.log == "log2", 2, 10)^(stat.coord3[, tempo.center.ref])
+ stat.coord3[, tempo.center.ref] <- base::ifelse(y.log == "log2", 2, 10)^(stat.coord3[, tempo.center.ref])
}
- stat.coord3[, tempo.center.ref] <- formatC(stat.coord3[, tempo.center.ref], digit = 2, drop0trailing = TRUE, format = "f")
+ stat.coord3[, tempo.center.ref] <- base::formatC(stat.coord3[, tempo.center.ref], digit = 2, drop0trailing = TRUE, format = "f")
# end correct median or mean text format
# if(any(tempo.log.high) == TRUE){
# tempo.stat <- stat.coord3[tempo.log.high,]
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_text(
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::geom_text(
data = stat.coord3,
mapping = ggplot2::aes_string(x = "x", y = "Y", label = tempo.center.ref),
size = stat.size,
@@ -2088,7 +2088,7 @@ ggbox <- function(
hjust = stat.just$hjust,
vjust = stat.just$vjust
)) # WARNING: no need of order() for labels because box.coord$x set the order
- coord.names <- c(coord.names, "stat.pos")
+ coord.names <- base::c(coord.names, "stat.pos")
# }
# if(any(tempo.log.low) == TRUE){
# tempo.stat <- stat.coord3[tempo.log.low,]
@@ -2104,14 +2104,14 @@ ggbox <- function(
# }
# end stat display
}else{
- tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 5")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 5")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
}
# end stat display
# legend management
if(legend.show == FALSE){ # must be here because must be before bef.final.plot <-
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(fill = "none", color = "none", alpha = "none")) # inactivate the initial legend
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(fill = "none", color = "none", alpha = "none")) # inactivate the initial legend
}
# end legend management
@@ -2123,18 +2123,18 @@ ggbox <- function(
# the oob argument of scale_y_continuous() https://ggplot2.tidyverse.org/reference/scale_continuous.html
# see also https://github.com/rstudio/cheatsheets/blob/master/data-visualization-2.1.pdf
# secondary ticks
- bef.final.plot <- ggplot2::ggplot_build(eval(parse(text = paste(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), ' + if(vertical == TRUE){ggplot2::scale_y_continuous(expand = c(0, 0), limits = sort(y.lim), oob = scales::rescale_none)}else{ggplot2::coord_flip(ylim = y.lim)}')))) # here I do not need the x-axis and y-axis orientation, I just need the number of main ticks and the legend. I DI NOT UNDERSTAND THE COMMENT HERE BECAUSE WE NEED COORD_FLiP
+ bef.final.plot <- ggplot2::ggplot_build(base::eval(base::parse(text = base::paste(base::paste(base::paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), ' + if(vertical == TRUE){ggplot2::scale_y_continuous(expand = c(0, 0), limits = sort(y.lim), oob = scales::rescale_none)}else{ggplot2::coord_flip(ylim = y.lim)}')))) # here I do not need the x-axis and y-axis orientation, I just need the number of main ticks and the legend. I DI NOT UNDERSTAND THE COMMENT HERE BECAUSE WE NEED COORD_FLiP
tempo.coord <- bef.final.plot$layout$panel_params[[1]]
# y.second.tick.positions: coordinates of secondary ticks (only if y.second.tick.nb argument is non NULL or if y.log argument is different from "no")
if(y.log != "no"){ # integer main ticks for log2 and log10
- tempo.scale <- (as.integer(min(y.lim, na.rm = TRUE)) - 1):(as.integer(max(y.lim, na.rm = TRUE)) + 1)
+ tempo.scale <- (base::as.integer(base::min(y.lim, na.rm = TRUE)) - 1):(base::as.integer(base::max(y.lim, na.rm = TRUE)) + 1)
}else{
- tempo <- if(is.null(attributes(tempo.coord$y$breaks))){tempo.coord$y$breaks}else{unlist(attributes(tempo.coord$y$breaks))}
- if(all(is.na(tempo))){# all() without na.rm -> ok because is.na() cannot be NA
- tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nONLY NA IN tempo.coord$y$breaks")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ tempo <- if(base::is.null(base::attributes(tempo.coord$y$breaks))){tempo.coord$y$breaks}else{base::unlist(base::ttributes(tempo.coord$y$breaks))}
+ if(base::all(base::is.na(tempo))){# all() without na.rm -> ok because is.na() cannot be NA
+ tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nONLY NA IN tempo.coord$y$breaks")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}
- tempo.scale <- saferGraph::scale2(lim = y.lim, n = ifelse(is.null(y.tick.nb), length(tempo[ ! is.na(tempo)]), y.tick.nb)) # in ggplot 3.3.0, tempo.coord$y.major_source replaced by tempo.coord$y$breaks. If fact: n = ifelse(is.null(y.tick.nb), length(tempo[ ! is.na(tempo)]), y.tick.nb)) replaced by n = ifelse(is.null(y.tick.nb), 4, y.tick.nb))
+ tempo.scale <- saferGraph::scale2(lim = y.lim, n = base::ifelse(base::is.null(y.tick.nb), base::length(tempo[ ! base::is.na(tempo)]), y.tick.nb)) # in ggplot 3.3.0, tempo.coord$y.major_source replaced by tempo.coord$y$breaks. If fact: n = ifelse(is.null(y.tick.nb), length(tempo[ ! is.na(tempo)]), y.tick.nb)) replaced by n = ifelse(is.null(y.tick.nb), 4, y.tick.nb))
}
y.second.tick.values <- NULL
y.second.tick.pos <- NULL
@@ -2143,69 +2143,69 @@ ggbox <- function(
y.second.tick.values <- tempo$values
y.second.tick.pos <- tempo$coordinates
# if(vertical == TRUE){ # do not remove in case the bug is fixed
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(geom = "segment", y = y.second.tick.pos, yend = y.second.tick.pos, x = tempo.coord$x.range[1], xend = tempo.coord$x.range[1] + diff(tempo.coord$x.range) / 80))
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(geom = "segment", y = y.second.tick.pos, yend = y.second.tick.pos, x = tempo.coord$x.range[1], xend = tempo.coord$x.range[1] + base::diff(tempo.coord$x.range) / 80))
# }else{ # not working because of the ggplot2 bug
# assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(geom = "segment", x = y.second.tick.pos, xend = y.second.tick.pos, y = tempo.coord$y.range[1], yend = tempo.coord$y.range[1] + diff(tempo.coord$y.range) / 80))
# }
- coord.names <- c(coord.names, "y.second.tick.positions")
- }else if(( ! is.null(y.second.tick.nb)) & y.log == "no"){
+ coord.names <- base::c(coord.names, "y.second.tick.positions")
+ }else if(( ! base::is.null(y.second.tick.nb)) & y.log == "no"){
# if(y.second.tick.nb > 0){ #inactivated because already checked before
- if(length(tempo.scale) < 2){
- tempo.cat1 <- c("y.tick.nb", "y.second.tick.nb")
- tempo.cat2 <- sapply(list(y.tick.nb, y.second.tick.nb), FUN = paste0, collapse = " ")
- tempo.sep <- sapply(mapply(" ", max(nchar(tempo.cat1)) - nchar(tempo.cat1) + 3, FUN = rep, SIMPLIFY = FALSE), FUN = paste0, collapse = "")
- tempo.cat <- paste0("ERROR IN ", function.name, "\nTHE NUMBER OF GENERATED TICKS FOR THE Y-AXIS IS NOT CORRECT: ", length(tempo.scale), "\nUSING THESE ARGUMENT SETTINGS (NO DISPLAY MEANS NULL VALUE):\n", paste0(tempo.cat1, tempo.sep, tempo.cat2, collapse = "\n"), "\nPLEASE, TEST OTHER VALUES")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ if(base::length(tempo.scale) < 2){
+ tempo.cat1 <- base::c("y.tick.nb", "y.second.tick.nb")
+ tempo.cat2 <- base::sapply(base::list(y.tick.nb, y.second.tick.nb), FUN = base::paste0, collapse = " ")
+ tempo.sep <- base::sapply(base::mapply(" ", base::max(base::nchar(tempo.cat1)) - base::nchar(tempo.cat1) + 3, FUN = rep, SIMPLIFY = FALSE), FUN = base::paste0, collapse = "")
+ tempo.cat <- base::paste0("ERROR IN ", function.name, "\nTHE NUMBER OF GENERATED TICKS FOR THE Y-AXIS IS NOT CORRECT: ", base::length(tempo.scale), "\nUSING THESE ARGUMENT SETTINGS (NO DISPLAY MEANS NULL VALUE):\n", base::paste0(tempo.cat1, tempo.sep, tempo.cat2, collapse = "\n"), "\nPLEASE, TEST OTHER VALUES")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}else{
tempo <- saferGraph::inter_ticks(lim = y.lim, log = y.log, breaks = tempo.scale, n = y.second.tick.nb)
}
y.second.tick.values <- tempo$values
y.second.tick.pos <- tempo$coordinates
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::annotate(
geom = "segment",
y = y.second.tick.pos,
yend = y.second.tick.pos,
x = if(vertical == TRUE){tempo.coord$x.range[1]}else{tempo.coord$y.range[1]},
- xend = if(vertical == TRUE){tempo.coord$x.range[1] + diff(tempo.coord$x.range) / 80}else{tempo.coord$y.range[1] + diff(tempo.coord$y.range) / 80}
+ xend = if(vertical == TRUE){tempo.coord$x.range[1] + base::diff(tempo.coord$x.range) / 80}else{tempo.coord$y.range[1] + base::diff(tempo.coord$y.range) / 80}
))
- coord.names <- c(coord.names, "y.second.tick.positions")
+ coord.names <- base::c(coord.names, "y.second.tick.positions")
}
# end y.second.tick.positions
# for the ggplot2 bug with y.log, this does not work: eval(parse(text = ifelse(vertical == FALSE & y.log == "log10", "ggplot2::scale_x_continuous", "ggplot2::scale_y_continuous")))
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_y_continuous(
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::scale_y_continuous(
breaks = tempo.scale,
minor_breaks = y.second.tick.pos,
- labels = if(y.log == "log10"){scales::trans_format("identity", scales::math_format(10^.x))}else if(y.log == "log2"){scales::trans_format("identity", scales::math_format(2^.x))}else if(y.log == "no"){ggplot2::waiver()}else{tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 6") ; stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)}, # == in stop() to be able to add several messages between ==
- expand = c(0, 0), # remove space after after axis limits
- limits = sort(y.lim), # NA indicate that limits must correspond to data limits but ylim() already used
+ labels = if(y.log == "log10"){scales::trans_format("identity", scales::math_format(10^.x))}else if(y.log == "log2"){scales::trans_format("identity", scales::math_format(2^.x))}else if(y.log == "no"){ggplot2::waiver()}else{tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nCODE INCONSISTENCY 6") ; base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(is.base::null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE)}, # == in stop() to be able to add several messages between ==
+ expand = base::c(0, 0), # remove space after after axis limits
+ limits = base::sort(y.lim), # NA indicate that limits must correspond to data limits but ylim() already used
oob = scales::rescale_none,
- trans = ifelse(diff(y.lim) < 0, "reverse", "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
+ trans = base::ifelse(base::diff(y.lim) < 0, "reverse", "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
))
if(vertical == TRUE){
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_cartesian(ylim = y.lim)) # problem of ggplot2::ylim() is that it redraws new breaks # coord_cartesian(ylim = y.lim)) not used because bug -> y-axis label disappearance with y.lim decreasing I DO NOT UNDERSTAND THIS MESSAGE WHILE I USE COORD_CARTESIAN # clip = "off" to have secondary ticks outside plot region does not work
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_cartesian(ylim = y.lim)) # problem of ggplot2::ylim() is that it redraws new breaks # coord_cartesian(ylim = y.lim)) not used because bug -> y-axis label disappearance with y.lim decreasing I DO NOT UNDERSTAND THIS MESSAGE WHILE I USE COORD_CARTESIAN # clip = "off" to have secondary ticks outside plot region does not work
}else{
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_flip(ylim = y.lim)) # clip = "off" to have secondary ticks outside plot region does not work # create the problem of y-axis label disappearance with y.lim decreasing. IDEM ABOVE
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::coord_flip(ylim = y.lim)) # clip = "off" to have secondary ticks outside plot region does not work # create the problem of y-axis label disappearance with y.lim decreasing. IDEM ABOVE
}
# end y scale management (cannot be before dot plot management)
# legend management
- if( ! is.null(legend.width)){
+ if( ! base::is.null(legend.width)){
legend.final <- fun_gg_get_legend(ggplot_built = bef.final.plot, fun.name = function.name, lib.path = lib.path) # get legend
- assign(paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(fill = "none", color = "none", alpha = "none")) # inactivate the initial legend
- if(is.null(legend.final) & plot == TRUE){ # even if any(unlist(legend.disp)) is TRUE
+ base::assign(base::paste0(tempo.gg.name, tempo.gg.count <- tempo.gg.count + 1), ggplot2::guides(fill = "none", color = "none", alpha = "none")) # inactivate the initial legend
+ if(base::is.null(legend.final) & plot == TRUE){ # even if any(unlist(legend.disp)) is TRUE
legend.final <- ggplot2::ggplot()+ggplot2::theme_void() # empty graph instead of legend
warn.count <- warn.count + 1
- tempo.warn <- paste0("(", warn.count,") LEGEND REQUESTED (NON NULL categ ARGUMENT OR legend.show ARGUMENT SET TO TRUE)\nBUT IT SEEMS THAT THE PLOT HAS NO LEGEND -> EMPTY LEGEND SPACE CREATED BECAUSE OF THE NON NULL legend.width ARGUMENT\n")
- warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ tempo.warn <- base::paste0("(", warn.count,") LEGEND REQUESTED (NON NULL categ ARGUMENT OR legend.show ARGUMENT SET TO TRUE)\nBUT IT SEEMS THAT THE PLOT HAS NO LEGEND -> EMPTY LEGEND SPACE CREATED BECAUSE OF THE NON NULL legend.width ARGUMENT\n")
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
}
}
# end legend management
# drawing
- fin.plot <- suppressMessages(suppressWarnings(eval(parse(text = paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))))
+ fin.plot <- base::suppressMessages(base::suppressWarnings(base::eval(base::parse(text = base::paste(base::paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + ")))))
grob.save <- NULL
if(plot == TRUE){
# following lines inactivated because of problem in warn.recov and message.recov
@@ -2217,10 +2217,10 @@ ggbox <- function(
# warn.recov <- fun_get_message(paste(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), if(is.null(add)){NULL}else{add}), kind = "warning", header = FALSE, print.no = FALSE, env = env_fun_get_message) # for recovering warnings printed by ggplot() functions
# message.recov <- fun_get_message('print(eval(parse(text = paste(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), if(is.null(add)){NULL}else{add}))))', kind = "message", header = FALSE, print.no = FALSE, env = env_fun_get_message) # for recovering messages printed by ggplot() functions
# if( ! (return == TRUE & return.ggplot == TRUE)){ # because return() plots when return.ggplot is TRUE # finally not used -> see return.ggplot description
- if(is.null(legend.width)){
- grob.save <- suppressMessages(suppressWarnings(gridExtra::grid.arrange(fin.plot)))
+ if(base::is.null(legend.width)){
+ grob.save <- base::suppressMessages(base::suppressWarnings(gridExtra::grid.arrange(fin.plot)))
}else{
- grob.save <-suppressMessages(suppressWarnings(gridExtra::grid.arrange(fin.plot, legend.final, ncol=2, widths=c(1, legend.width))))
+ grob.save <-base::suppressMessages(base::suppressWarnings(gridExtra::grid.arrange(fin.plot, legend.final, ncol=2, widths=c(1, legend.width))))
}
# }
# suppressMessages(suppressWarnings(print(eval(parse(text = paste(paste(paste0(tempo.gg.name, 1:tempo.gg.count), collapse = " + "), if(is.null(add)){NULL}else{add}))))))
@@ -2229,8 +2229,8 @@ ggbox <- function(
# message.recov <- NULL
# warn.recov <- NULL
warn.count <- warn.count + 1
- tempo.warn <- paste0("(", warn.count,") PLOT NOT SHOWN AS REQUESTED")
- warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
+ tempo.warn <- base::paste0("(", warn.count,") PLOT NOT SHOWN AS REQUESTED")
+ warn <- base::paste0(base::ifelse(base::is.null(warn), tempo.warn, base::paste0(warn, "\n\n", tempo.warn)))
}
# end drawing
@@ -2245,41 +2245,41 @@ ggbox <- function(
# }else if( ! (is.null(warn) & is.null(message.recov)) & is.null(warn.recov)){
# warn <- paste0(warn, "\n\n", if(length(message.recov) > 0){paste0(paste0("MESSAGES FROM ggplot2 FUNCTIONS: ", unique(message.recov), collapse = "\n\n"), "\n\n")})
# }
- if(warn.print == TRUE & ! is.null(warn)){
- on.exit(warning(paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE))
+ if(warn.print == TRUE & ! base::is.null(warn)){
+ base::on.exit(base::warning(base::paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE))
}
- on.exit(exp = options(warning.length = ini.warning.length), add = TRUE)
+ base::on.exit(exp = base::options(warning.length = ini.warning.length), add = TRUE)
if(return == TRUE){
tempo.output <- ggplot2::ggplot_build(fin.plot)
tempo.output$data <- tempo.output$data[-1] # remove the first data because corresponds to the initial empty boxplot
- if(length(tempo.output$data) != length(coord.names)){
- tempo.cat <- paste0("INTERNAL CODE ERROR IN ", function.name, "\nlength(tempo.output$data) AND length(coord.names) MUST BE IDENTICAL. CODE HAS TO BE MODIFIED")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", ifelse(is.null(warn), "", paste0("IN ADDITION\nWARNING", ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
+ if(base::length(tempo.output$data) != base::length(coord.names)){
+ tempo.cat <- base::paste0("INTERNAL CODE ERROR IN ", function.name, "\nlength(tempo.output$data) AND length(coord.names) MUST BE IDENTICAL. CODE HAS TO BE MODIFIED")
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n", base::ifelse(base::is.null(warn), "", base::paste0("IN ADDITION\nWARNING", base::ifelse(warn.count > 1, "S", ""), ":\n\n", warn))), call. = FALSE) # == in stop() to be able to add several messages between ==
}else{
- names(tempo.output$data) <- coord.names
+ base::names(tempo.output$data) <- coord.names
tempo.output$data <- tempo.output$data[coord.names != "bad_remove"]
}
tempo <- tempo.output$layout$panel_params[[1]]
- output <- list(
+ output <- base::list(
data = data1.ini,
stat = stat.nolog,
removed.row.nb = removed.row.nb,
removed.rows = removed.rows,
- plot = c(tempo.output$data, y.second.tick.values = list(y.second.tick.values)),
+ plot = base::c(tempo.output$data, y.second.tick.values = list(y.second.tick.values)),
panel = facet.categ,
- axes = list(
+ axes = base::list(
x.range = tempo$x.range,
- x.labels = if(is.null(attributes(tempo$x$breaks))){tempo$x$breaks}else{tempo$x$scale$get_labels()}, # is.null(attributes(tempo$x$breaks)) test if it is number (TRUE) or character (FALSE)
- x.positions = if(is.null(attributes(tempo$x$breaks))){tempo$x$breaks}else{unlist(attributes(tempo$x$breaks))},
+ x.labels = if(base::is.null(base::attributes(tempo$x$breaks))){tempo$x$breaks}else{tempo$x$scale$get_labels()}, # is.null(attributes(tempo$x$breaks)) test if it is number (TRUE) or character (FALSE)
+ x.positions = if(base::is.null(base::attributes(tempo$x$breaks))){tempo$x$breaks}else{base::unlist(base::attributes(tempo$x$breaks))},
y.range = tempo$y.range,
- y.labels = if(is.null(attributes(tempo$y$breaks))){tempo$y$breaks}else{tempo$y$scale$get_labels()},
- y.positions = if(is.null(attributes(tempo$y$breaks))){tempo$y$breaks}else{unlist(attributes(tempo$y$breaks))}
+ y.labels = if(base::is.null(base::attributes(tempo$y$breaks))){tempo$y$breaks}else{tempo$y$scale$get_labels()},
+ y.positions = if(base::is.null(base::attributes(tempo$y$breaks))){tempo$y$breaks}else{base::unlist(base::attributes(tempo$y$breaks))}
),
- warn = paste0("\n", warn, "\n\n"),
+ warn = base::paste0("\n", warn, "\n\n"),
ggplot = if(return.ggplot == TRUE){fin.plot}else{NULL}, # fin.plot plots the graph if return == TRUE
gtable = if(return.gtable == TRUE){grob.save}else{NULL}
)
- return(output) # this plots the graph if return.ggplot is TRUE and if no assignment
+ base::return(output) # this plots the graph if return.ggplot is TRUE and if no assignment
}
# end output
# end main code
diff --git a/internal_functions.R b/internal_functions.R
new file mode 100644
index 0000000000000000000000000000000000000000..ac127adfb187d975fefc854818daf1cb50817a03
--- /dev/null
+++ b/internal_functions.R
@@ -0,0 +1,154 @@
+#' @title .pack_and_function_check
+#' @description
+#' Check if 1) required functions are present in required packages and 2) required packages are installed locally.
+#' @param fun Character vector of the names of the required functions, preceded by the name of the package they belong to and a double colon. Example: c("ggplot2::geom_point", "grid::gpar").
+#' @param lib.path Character vector specifying the absolute pathways of the directories containing the listed packages in the fun argument, if not in the default directories. If NULL, the function checks only in the .libPaths() default R library folders.
+#' @param external.function.name Name of the function using the .pack_and_function_check() function.
+#' @returns An error message if at least one of the checked packages is missing in lib.path, or if at least one of the checked functions is missing in the required package, nothing otherwise.
+#' @examples
+#' # .pack_and_function_check(fun = "ggplot2::notgood", lib.path = .libPaths(), external.function.name = "fun1") # commented because this example returns an error
+#' \dontrun{
+#' # Example that shouldn't be run because this is an internal function
+#' .pack_and_function_check(fun = c("ggplot2::geom_point", "grid::gpar"), lib.path = .libPaths(), external.function.name = "fun1")
+#' }
+#' @keywords internal
+#' @rdname internal_function
+.pack_and_function_check <- function(
+ fun,
+ lib.path,
+ external.function.name
+){
+ # WARNING
+ # arguments of the .pack_and_function_check() function are not checked, so use carefully inside other functions
+ # DEBUGGING
+ # fun = "ggplot2::geom_point" ; lib.path = "C:/Program Files/R/R-4.3.1/library" ; external.function.name = "fun1"
+ # check of lib.path
+ # already done in the main function
+ if(is.null(lib.path)){
+ lib.path <- .libPaths() # .libPaths(new = lib.path) # or .libPaths(new = c(.libPaths(), lib.path))
+ }
+ # end check of lib.path
+ # main code
+ tempo.log <- base::grepl(x = fun, pattern = "^.+::.+$")
+ if( ! base::all(tempo.log)){
+ tempo.cat <- base::paste0("ERROR IN THE CODE OF THE ", external.function.name, " OF THE saferDev PACKAGE.\nTHE STRING IN fun ARGUMENT MUST CONTAIN \"::\":\n", base::paste(fun[ ! tempo.log], collapse = "\n"))
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ pkg.fun.name.list <- base::strsplit(fun, "::") # package in 1 and function in 2
+ pkg.name <- base::sapply(X = pkg.fun.name.list, FUN = function(x){x[1]})
+ pkg.log <- pkg.name %in% base::rownames(utils::installed.packages(lib.loc = lib.path))
+ if( ! base::all(pkg.log)){
+ tempo <- pkg.name[ ! pkg.log]
+ tempo.cat <- base::paste0(
+ "ERROR IN ",
+ external.function.name,
+ " OF THE saferDev PACKAGE. REQUIRED PACKAGE",
+ ifelse(base::length(tempo) == 1L, base::paste0(":\n", tempo), base::paste0("S:\n", base::paste(tempo, collapse = "\n"))),
+ "\nMUST BE INSTALLED IN",
+ ifelse(base::length(lib.path) == 1L, "", " ONE OF THESE FOLDERS"),
+ ":\n",
+ base::paste(lib.path, collapse = "\n")
+ )
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ fun.log <- base::sapply(X = pkg.fun.name.list, FUN = function(x){base::exists(x[2], envir = base::asNamespace(x[1]))})
+ if( ! base::all(fun.log)){
+ tempo <- fun[ ! fun.log]
+ tempo.cat <- base::paste0(
+ "ERROR IN ",
+ external.function.name,
+ " OF THE saferDev PACKAGE. REQUIRED FUNCTION",
+ ifelse(base::length(tempo) == 1L, " IS ", "S ARE "),
+ "MISSING IN THE INSTALLED PACKAGE",
+ ifelse(base::length(tempo) == 1L, base::paste0(":\n", tempo), base::paste0("S:\n", base::paste(tempo, collapse = "\n")))
+ )
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ # end main code
+}
+
+
+#' @title .base_op_check
+#' @description
+#' Check if critical operators of R are not present in other packages or in the global env.
+#' @param external.function.name Name of the function using the .pack_and_function_check() function.
+#' @returns An error message if at least one of the checked operator is present in the R scope, nothing otherwise.
+#' @examples
+#' \dontrun{
+#' # Example that shouldn't be run because this is an internal function
+#' assign("!", 1) ; .base_op_check(external.function.name = "fun1") # commented because this example returns an error
+#' }
+#' @keywords internal
+#' @rdname internal_function
+.base_op_check <- function(
+ external.function.name
+){
+ # WARNING
+ # arguments of the .base_op_check() function are not checked, so use carefully inside other functions
+ # DEBUGGING
+ # external.function.name = "test"
+ # main code
+ reserved.objects <- c(
+ "-",
+ "!",
+ "!=",
+ "$",
+ "%%",
+ "%*%",
+ "%/%",
+ "%in%",
+ "&",
+ "&&",
+ "(",
+ "*",
+ "/",
+ ":",
+ "::",
+ ":::",
+ "@",
+ "[",
+ "[[",
+ "^",
+ "{",
+ "|",
+ "||",
+ "~",
+ "+",
+ "<",
+ "<-",
+ "<<-",
+ "<=",
+ "=",
+ "==",
+ ">",
+ ">=",
+ "\\",
+ "if",
+ "else",
+ "function",
+ "for",
+ "while",
+ "repeat"
+ )
+ tempo.log <- base::sapply(X = reserved.objects, FUN = function(x){
+ if( ! base::all(utils::find(x) == "package:base")){
+ return(TRUE)
+ }else{
+ return(FALSE)
+ }
+ })
+ if(base::any(tempo.log)){
+ tempo.name <- reserved.objects[tempo.log]
+ tempo.pos <- base::sapply(X = tempo.name, FUN = function(x){base::paste(utils::find(x), collapse = " ")})
+ tempo.cat <- base::paste0(
+ "ERROR IN ",
+ external.function.name,
+ " OF THE saferDev PACKAGE.\nCRITICAL R OBJECT",
+ ifelse(base::length(tempo.log) == 1L, " ", "S "),
+ "CANNOT BE PRESENT SOMEWHERE ELSE IN THE R SCOPE THAN IN \"package::base\":\n",
+ base::paste(base::paste(tempo.name, tempo.pos, sep = "\t"), collapse = "\n")
+ )
+ base::stop(base::paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
+ }
+ # end main code
+}
\ No newline at end of file