diff --git a/gg_get_legend.R b/gg_get_legend.R index 0bdd9e028ba30a41614c22815abb3695f2f4efae..2292cc39519081820141de46ce4feb812d0023c3 100755 --- a/gg_get_legend.R +++ b/gg_get_legend.R @@ -40,11 +40,11 @@ gg_get_legend <- function(ggplot_built, fun.name = NULL, lib.path = NULL){ 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 = 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 <- .libPaths() + 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 <- .libPaths() # .libPaths(new = lib.path) # or .libPaths(new = c(.libPaths(), lib.path)) + 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 @@ -62,8 +62,8 @@ gg_get_legend <- function(ggplot_built, fun.name = NULL, lib.path = NULL){ mandat.args <- base::c( "ggplot_built" ) - tempo <- base::eval(base::parse(text = base::paste0("missing(", base::paste0(mandat.args, collapse = ") | missing("), ")"))) - if(base::any(tempo)){ # normally no NA for missing() output + 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 == } @@ -124,19 +124,19 @@ gg_get_legend <- function(ggplot_built, fun.name = NULL, lib.path = NULL){ # end second round of checking and data preparation # main code - win.nb <- dev.cur() - pdf(file = NULL) + 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 - invisible(dev.off()) + base::invisible(grDevices::dev.off()) if(win.nb > 1){ # to go back to the previous active device, if == 1 means no opened device - dev.set(win.nb) + grDevices::dev.set(win.nb) } - leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box") - if(length(leg) == 0L){ + 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]] } - return(legend) + base::return(legend) } diff --git a/gg_point_rast.R b/gg_point_rast.R new file mode 100755 index 0000000000000000000000000000000000000000..89e789cbee2272e8aeebf52ec72864641a3daed3 --- /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", 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() + } + }else{ + lib.path <- .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( ! 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(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", 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 +}