cute_little_R_functions.R 562 KB
Newer Older
Gael  MILLOT's avatar
Gael MILLOT committed
8001
8002
8003
8004
8005
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)
Gael  MILLOT's avatar
Gael MILLOT committed
8006
8007
8008
}
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
8009
8010
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
Gael  MILLOT's avatar
Gael MILLOT committed
8011
}
Gael  MILLOT's avatar
Gael MILLOT committed
8012
8013
8014
8015
8016
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.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
# main code
if(is.null(lib.path)){
lib.path <- .libPaths() # .libPaths(new = lib.path) # or .libPaths(new = c(.libPaths(), lib.path))
Gael  MILLOT's avatar
Gael MILLOT committed
8017
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
8018
8019
8020
8021
8022
8023
8024
8025
8026
.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
}
for(i1 in 1:length(req.package)){
if( ! req.package[i1] %in% rownames(utils::installed.packages(lib.loc = lib.path))){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": PACKAGE ", req.package[i1], " MUST BE INSTALLED IN:\n", paste(lib.path, collapse = "\n"), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}else{
if(load == TRUE){
suppressWarnings(suppressPackageStartupMessages(library(req.package[i1], lib.loc = lib.path, quietly = TRUE, character.only = TRUE)))
Gael  MILLOT's avatar
Gael MILLOT committed
8027
8028
8029
8030
8031
8032
}
}
}
}


Gael  MILLOT's avatar
Gael MILLOT committed
8033
######## fun_python_pack() #### check if python packages are present
Gael  MILLOT's avatar
Gael MILLOT committed
8034
8035


Gael  MILLOT's avatar
Gael MILLOT committed
8036
8037
8038
8039
8040
8041
8042
8043
8044
8045
8046
8047
8048
8049
8050
8051
8052
8053
8054
8055
8056
8057
8058
8059
8060
8061
8062
8063
8064
8065
8066
8067
8068
8069
8070
# Check OK: clear to go Apollo
fun_python_pack <- function(req.package, python.exec.path = NULL, lib.path = NULL, R.lib.path = NULL){
# AIM
# check if the specified python packages are present in the computer (no import)
# WARNINGS
# for python 3.7. Previous versions return an error "Error in sys$stdout$flush() : attempt to apply non-function"
# ARGUMENTS
# req.package: character vector of package names to import
# python.exec.path: optional character vector specifying the absolute pathways of the executable python file to use (associated to the packages to use). If NULL, the reticulate::import_from_path() function used in fun_python_pack() seeks for an available version of python.exe, and then uses python_config(python_version, required_module, python_versions). But might not be the correct one for the lib.path parameter specified. Thus, it is recommanded to do not leave NULL, notably when using computing clusters
# lib.path: optional character vector specifying the absolute pathways of the directories containing some of the listed packages in the req.package argument
# R.lib.path: absolute path of the reticulate packages, if not in the default folders
# REQUIRED PACKAGES
# reticulate
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# fun_pack()
# RETURN
# nothing
# EXAMPLES
# example of error message
# fun_python_pack(req.package = "nopackage")
# example without error message (require the installation of the python serpentine package from https://github.com/koszullab/serpentine
# fun_python_pack(req.package = "serpentine", python.exec.path = "C:/ProgramData/Anaconda3/python.exe", lib.path = "c:/programdata/anaconda3/lib/site-packages/")
# another example of error message
# fun_python_pack(req.package = "serpentine", lib.path = "blablabla")
# DEBUGGING
# req.package = "serpentine" ; python.exec.path = "C:/ProgramData/Anaconda3/python.exe" ; lib.path = "c:/programdata/anaconda3/lib/site-packages/" ; R.lib.path = NULL
# req.package = "bad" ; lib.path = NULL ; R.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")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
8071
}
Gael  MILLOT's avatar
Gael MILLOT committed
8072
8073
8074
if(length(utils::find("fun_pack", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_pack() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
8075
}
Gael  MILLOT's avatar
Gael MILLOT committed
8076
8077
8078
8079
8080
8081
8082
8083
8084
8085
8086
8087
8088
8089
# 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$fun.name))
tempo <- fun_check(data = req.package, class = "character", fun.name = function.name) ; eval(ee)
if( ! is.null(python.exec.path)){
tempo <- fun_check(data = python.exec.path, class = "character", length = 1, fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE){
if( ! all(file.exists(python.exec.path))){ # separation to avoid the problem of tempo$problem == FALSE and python.exec.path == NA
tempo.cat <- paste0("ERROR IN ", function.name, ": FILE PATH INDICATED IN THE python.exec.path ARGUMENT DOES NOT EXISTS:\n", paste(python.exec.path, collapse = "\n"))
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
8090
}
Gael  MILLOT's avatar
Gael MILLOT committed
8091
8092
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
8093
8094
8095
8096
8097
8098
8099
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)
8100
8101
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
8102
}
Gael  MILLOT's avatar
Gael MILLOT committed
8103
8104
8105
8106
8107
8108
8109
if( ! is.null(R.lib.path)){
tempo <- fun_check(data = R.lib.path, class = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE){
if( ! all(dir.exists(R.lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and R.lib.path == NA
tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE R.lib.path ARGUMENT DOES NOT EXISTS:\n", paste(R.lib.path, collapse = "\n"))
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
8110
8111
8112
}
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
8113
8114
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
Gael  MILLOT's avatar
Gael MILLOT committed
8115
}
Gael  MILLOT's avatar
Gael MILLOT committed
8116
8117
8118
8119
8120
8121
8122
8123
8124
8125
8126
8127
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.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 = "reticulate", lib.path = R.lib.path)
# end package checking
# main code
if(is.null(python.exec.path)){
python.exec.path <- reticulate::py_run_string("
import sys ;
path_lib = sys.path
") # python string
python.exec.path <- python.exec.path$path_lib
8128
}
Gael  MILLOT's avatar
Gael MILLOT committed
8129
8130
8131
8132
8133
8134
if(is.null(lib.path)){
lib.path <- reticulate::py_run_string("
import sys ;
path_lib = sys.path
") # python string
lib.path <- lib.path$path_lib
8135
}
Gael  MILLOT's avatar
Gael MILLOT committed
8136
8137
8138
8139
8140
8141
reticulate::use_python(Sys.which(python.exec.path), required = TRUE) # required to avoid the use of erratic python exec by reticulate::import_from_path()
for(i1 in 1:length(req.package)){
tempo.try <- vector("list", length = length(lib.path))
for(i2 in 1:length(lib.path)){
tempo.try[[i2]] <- suppressWarnings(try(reticulate::import_from_path(req.package[i1], path = lib.path[i2]), silent = TRUE))
tempo.try[[i2]] <- suppressWarnings(try(reticulate::import_from_path(req.package[i1], path = lib.path[i2]), silent = TRUE)) # done twice to avoid the error message  about flushing present the first time but not the second time. see https://stackoverflow.com/questions/57357001/reticulate-1-13-error-in-sysstdoutflush-attempt-to-apply-non-function
Gael  MILLOT's avatar
Gael MILLOT committed
8142
}
Gael  MILLOT's avatar
Gael MILLOT committed
8143
8144
8145
8146
8147
8148
8149
if(all(sapply(tempo.try, FUN = grepl, pattern = "[Ee]rror"))){
print(tempo.try)
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": PACKAGE ", req.package[i1], " MUST BE INSTALLED IN THE MENTIONNED DIRECTORY:\n", paste(lib.path, collapse = "\n"), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
} # else{
# suppressWarnings(suppressPackageStartupMessages(assign(req.package[i1], reticulate::import(req.package[i1])))) # not required because try() already evaluates
# }
Gael  MILLOT's avatar
Gael MILLOT committed
8150
8151
8152
8153
}
}


Gael  MILLOT's avatar
Gael MILLOT committed
8154
################ Print / Exporting results (text & tables)
Gael  MILLOT's avatar
Gael MILLOT committed
8155
8156


Gael  MILLOT's avatar
Gael MILLOT committed
8157
######## fun_report() #### print string or data object into output file
Gael  MILLOT's avatar
Gael MILLOT committed
8158
8159


Gael  MILLOT's avatar
Gael MILLOT committed
8160
8161
8162
8163
# Check OK: clear to go Apollo
fun_report <- function(data, output = "results.txt", path = "C:/Users/Gael/Desktop/", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, noquote = TRUE, sep = 2){
# AIM
# log file function: print a character string or a data object into a same output file
8164
8165
# REQUIRED PACKAGES
# utils
Gael  MILLOT's avatar
Gael MILLOT committed
8166
8167
8168
8169
8170
8171
8172
8173
8174
8175
8176
8177
8178
8179
8180
8181
8182
8183
8184
8185
8186
8187
8188
8189
8190
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# ARGUMENTS
# data: object to print in the output file. If NULL, nothing is done, with no warning
# output: name of the output file
# path: location of the output file
# no.overwrite: (logical) if output file already exists, defines if the printing is appended (default TRUE) or if the output file content is erased before printing (FALSE)
# rownames.kept: (logical) defines whether row names have to be removed or not in small tables (less than length.rows rows)
# vector.cat (logical). If TRUE print a vector of length > 1 using cat() instead of capture.output(). Otherwise (default FALSE) the opposite
# noquote: (logical). If TRUE no quote are present for the characters
# sep: number of separating lines after printed data (must be integer)
# RETURN
# nothing
# EXAMPLES
# fun_report()
# fun_report(data = 1:3, output = "results.txt", path = "C:/Users/Gael/Desktop", no.overwrite = TRUE, rownames.kept = FALSE, vector.cat = FALSE, noquote = FALSE, sep = 2)
# DEBUGGING
# data = 1:3 ; output = "results.txt" ; path = "C:/Users/Gael/Desktop" ; no.overwrite = TRUE ; rownames.kept = FALSE ; vector.cat = FALSE ; noquote = FALSE ; sep = 2 # for function debugging
# 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")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
8191
}
Gael  MILLOT's avatar
Gael MILLOT committed
8192
8193
8194
8195
8196
8197
8198
8199
8200
8201
8202
# 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$fun.name))
tempo <- fun_check(data = output, class = "character", length = 1, fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE & output == ""){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": output ARGUMENT AS \"\" DOES NOT CORRESPOND TO A VALID FILE NAME\n\n================\n\n")
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
8203
}
Gael  MILLOT's avatar
Gael MILLOT committed
8204
8205
8206
8207
8208
8209
tempo <- fun_check(data = path, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
if(tempo$problem == FALSE){
if( ! all(dir.exists(path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": path ARGUMENT DOES NOT CORRESPOND TO EXISTING DIRECTORY\n", paste(path, collapse = "\n"),"\n\n================\n\n")
text.check <- c(text.check, tempo.cat)
arg.check <- c(arg.check, TRUE)
Gael  MILLOT's avatar
Gael MILLOT committed
8210
8211
}
}
Gael  MILLOT's avatar
Gael MILLOT committed
8212
8213
8214
8215
8216
8217
8218
tempo <- fun_check(data = no.overwrite, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = rownames.kept, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = vector.cat, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = noquote, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = sep, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
Gael  MILLOT's avatar
Gael MILLOT committed
8219
}
Gael  MILLOT's avatar
Gael MILLOT committed
8220
8221
8222
8223
8224
8225
8226
8227
8228
8229
8230
8231
8232
8233
8234
8235
8236
8237
8238
# end argument checking
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.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()
# the 4 next lines are inactivated but kept because at a time, I might have a problem with data (solved with data = NULL). These 4 lines are just to know how to detect a missing argument. Important here because if data is not provided, print the code of the data function
# arg.user.list <- as.list(match.call(expand.dots=FALSE))[-1] # recover all the arguments provided by the function user (excluding the argument with defaults values not provided by the user. Thus, it is really the list indicated by the user)
# default.arg.list <- formals(fun = sys.function(sys.parent())) # list of all the arguments of the function with their default values (not the values of the user !). It seems that ls() as first line of the function provide the names of the arguments (empty, called, etc., or not)
# arg.without.default.value <- sapply(default.arg.list, is.symbol) & sapply(sapply(default.arg.list, as.character), identical, "") # logical to detect argument without default values (these are typeof "symbol" and class "name" and empty character
# if( ! all(names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list))){ # test that the arguments with no null values are provided by the user
# tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": VALUE REQUIRED FOR THESE ARGUMENTS WITH NO DEFAULTS VALUES: ", paste(names(default.arg.list)[arg.without.default.value][ ! names(default.arg.list)[arg.without.default.value] %in% names(arg.user.list)], collapse = " "), "\n\n================\n\n")
#stop(tempo.cat, call. = FALSE)
# }
# end argument checking
# main code
if( ! is.null(data)){
if(all(class(data) %in% c("matrix", "data.frame", "table"))){
if(rownames.kept == FALSE & all(class(data) == "data.frame") & nrow(data) != 0 & nrow(data) <= 4){ # for data frames with nrows <= 4
rownames.output.tables <- ""
length.rows <- nrow(data)
for(i in 1:length.rows){ # replace the rownames of the first 4 rows by increasing number of spaces (because identical row names not allowed in data frames). This method cannot be extended to more rows as the printed data frame is shifted on the right because of "big empty rownames"
rownames.output.tables <- c(rownames.output.tables, paste0(rownames.output.tables[i]," ", collapse=""))
Gael  MILLOT's avatar
Gael MILLOT committed
8239
}
Gael  MILLOT's avatar
Gael MILLOT committed
8240
8241
8242
row.names(data) <- rownames.output.tables[1:length.rows]
}else if(rownames.kept == FALSE & all(class(data) %in% c("matrix", "table"))){
rownames(data) <- rep("", nrow(data)) # identical row names allowed in matrices and tables
Gael  MILLOT's avatar
Gael MILLOT committed
8243
}
Gael  MILLOT's avatar
Gael MILLOT committed
8244
8245
8246
8247
if(noquote == TRUE){
utils::capture.output(noquote(data), file=paste0(path, "/", output), append = no.overwrite)
}else{
utils::capture.output(data, file=paste0(path, "/", output), append = no.overwrite)
Gael  MILLOT's avatar
Gael MILLOT committed
8248
}
Gael  MILLOT's avatar
Gael MILLOT committed
8249
8250
8251
}else if(is.vector(data) & all(class(data) != "list") & (length(data) == 1 | vector.cat == TRUE)){
if(noquote == TRUE){
cat(noquote(data), file= paste0(path, "/", output), append = no.overwrite)
Gael  MILLOT's avatar
Gael MILLOT committed
8252
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
8253
cat(data, file= paste0(path, "/", output), append = no.overwrite)
Gael  MILLOT's avatar
Gael MILLOT committed
8254
}
8255
}else if(all(mode(data) == "character")){ # characters (array, list, factor or vector with vector.cat = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
8256
8257
8258
8259
if(noquote == TRUE){
utils::capture.output(noquote(data), file=paste0(path, "/", output), append = no.overwrite)
}else{
utils::capture.output(data, file=paste0(path, "/", output), append = no.overwrite)
Gael  MILLOT's avatar
Gael MILLOT committed
8260
}
8261
8262
}else{ # other object (S4 for instance, which do not like noquote()
utils::capture.output(data, file=paste0(path, "/", output), append = no.overwrite)
Gael  MILLOT's avatar
Gael MILLOT committed
8263
8264
8265
}
sep.final <- paste0(rep("\n", sep), collapse = "")
write(sep.final, file= paste0(path, "/", output), append = TRUE) # add a sep
Gael  MILLOT's avatar
Gael MILLOT committed
8266
8267
8268
8269
}
}


Gael  MILLOT's avatar
Gael MILLOT committed
8270
######## fun_get_message() #### return messages of an expression (that can be exported)
Gael  MILLOT's avatar
Gael MILLOT committed
8271
8272


Gael  MILLOT's avatar
Gael MILLOT committed
8273
8274
8275
8276
8277
8278
8279
8280
8281
8282
8283
8284
8285
8286
8287
8288
8289
8290
8291
8292
8293
8294
8295
8296
8297
8298
8299
8300
8301
8302
8303
8304
8305
8306
8307
8308
8309
8310
8311
8312
8313
8314
# Check OK: clear to go Apollo
fun_get_message <- function(data, kind = "error", header = TRUE, print.no = FALSE, text = NULL, env = NULL){
# AIM
# evaluate an instruction written between "" and return the first of the error, or warning or standard (non error non warning) messages if ever exist
# using argument print.no = FALSE, return NULL if no message, which is convenient in some cases
# WARNING
# Only the first message is returned
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# ARGUMENTS
# data: character string to evaluate
# kind: character string. Either "error" to get error messages, or "warning" to get warning messages, or "message" to get non error and non warning messages
# header: logical. Add a header in the returned message?
# print.no: logical. Print a message saying that no message reported?
# text: character string added to the output message (even if no message exists and print.no is TRUE). Inactivated if header is FALSE
# env: the name of an existing environment. NULL if not required
# RETURN
# the message or NULL if no message and print.no is FALSE
# EXAMPLES
# fun_get_message(data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)", kind = "error", print.no = TRUE, text = "IN A")
# fun_get_message(data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)", kind = "warning", print.no = TRUE, text = "IN A")
# fun_get_message(data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)", kind = "message", print.no = TRUE, text = "IN A")
# fun_get_message(data = "wilcox.test()", kind = "error", print.no = TRUE, text = "IN A")
# fun_get_message(data = "sum(1)", kind = "error", print.no = TRUE, text = "IN A")
# fun_get_message(data = "message('ahah')", kind = "error", print.no = TRUE, text = "IN A")
# fun_get_message(data = "message('ahah')", kind = "message", print.no = TRUE, text = "IN A")
# fun_get_message(data = "ggplot2::ggplot(data = data.frame(X = 1:10), mapping = ggplot2::aes(x = X)) + ggplot2::geom_histogram()", kind = "message", print.no = TRUE, text = "IN FUNCTION 1")
# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10)) ; fun_get_message(data = 'fun_gg_boxplot(data = obs1, y = "Time", categ = "Group1")', kind = "message", print.no = TRUE, text = "IN FUNCTION 1")
# DEBUGGING
# data = "wilcox.test(c(1,1,3), c(1, 2, 4), paired = TRUE)" ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL ; env = NULL # for function debugging
# data = "sum(1)" ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL ; env = NULL  # for function debugging
# set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10)) ; data = 'fun_gg_boxplot(data1 = obs1, y = "Time", categ = "Group1")' ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL ; env = NULL  # for function debugging
# data = "message('ahah')" ; kind = "error" ; header = TRUE ; print.no = TRUE ; text = "IN A" ; env = NULL 
# data = 'ggplot2::ggplot(data = data.frame(X = "a"), mapping = ggplot2::aes(x = X)) + ggplot2::geom_histogram()' ; kind = "message" ; header = TRUE ; print.no = FALSE ; text = NULL # for function debugging
# data = 'ggplot2::ggplot(data = data.frame(X = "a"), mapping = ggplot2::aes(x = X)) + ggplot2::geom_histogram()' ; kind = "warning" ; header = TRUE ; print.no = FALSE ; text = NULL # for function debugging
# 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")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
Gael  MILLOT's avatar
Gael MILLOT committed
8315
}
Gael  MILLOT's avatar
Gael MILLOT committed
8316
8317
8318
8319
8320
8321
8322
8323
8324
8325
8326
8327
8328
8329
# end required function checking
# no need to use reserved words to avoid bugs, because it is local, and  exists("tempo.warning", inherit = FALSE), never use the scope
# argument checking
# argument checking with 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$fun.name))
tempo <- fun_check(data = data, class = "character", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = kind, options = c("error", "warning", "message"), length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = print.no, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = header, class = "logical", length = 1, fun.name = function.name) ; eval(ee)
if( ! is.null(text)){
tempo <- fun_check(data = text, class = "character", length = 1, fun.name = function.name) ; eval(ee)
Gael  MILLOT's avatar
Gael MILLOT committed
8330
}
Gael  MILLOT's avatar
Gael MILLOT committed
8331
8332
if( ! is.null(env)){
tempo <- fun_check(data = env, class = "environment", fun.name = function.name) ; eval(ee) #
Gael  MILLOT's avatar
Gael MILLOT committed
8333
}
Gael  MILLOT's avatar
Gael MILLOT committed
8334
8335
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
Gael  MILLOT's avatar
Gael MILLOT committed
8336
}
Gael  MILLOT's avatar
Gael MILLOT committed
8337
8338
8339
8340
8341
8342
8343
8344
8345
8346
8347
8348
# end argument checking with fun_check()
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.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
# main code
pdf(file = NULL) # send plots into a NULL file, no pdf file created
window.nb <- dev.cur()
dev.set(window.nb)
# last warning cannot be used because suppressWarnings() does not modify last.warning present in the base evironment (created at first warning in a new R session), or warnings() # to reset the warning history : unlockBinding("last.warning", baseenv()) ; assign("last.warning", NULL, envir = baseenv())
output <- NULL
tempo.error <- try(suppressMessages(suppressWarnings(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))), silent = TRUE) # get error message, not warning or messages
if(any(class(tempo.error) %in% c("gg", "ggplot"))){
tempo.error <- try(suppressMessages(suppressWarnings(ggplot2::ggplot_build(tempo.error))), silent = TRUE)[1]
Gael  MILLOT's avatar
Gael MILLOT committed
8349
}
Gael  MILLOT's avatar
Gael MILLOT committed
8350
if(exists("tempo.error", inherit = FALSE) == TRUE){ # inherit = FALSE avoid the portee lexical and thus the declared word
8351
if( ! all(class(tempo.error) == "try-error")){ # deal with NULL and S4 objects. Old code:  ! (all(class(tempo.error) == "try-error") & any(grepl(x = tempo.error, pattern = "^Error|^error|^ERROR"))) but problem with S4 objects. Old code : if((length(tempo.error) > 0 & ! any(grepl(x = tempo.error, pattern = "^Error|^error|^ERROR"))) | (length(tempo.error) == 0) ){ but problem when tempo.error is a list but added this did not work: | ! all(class(tempo.error) == "character")
Gael  MILLOT's avatar
Gael MILLOT committed
8352
tempo.error <- NULL
Gael  MILLOT's avatar
Gael MILLOT committed
8353
}
8354
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
8355
tempo.error <- NULL
8356
}
Gael  MILLOT's avatar
Gael MILLOT committed
8357
8358
8359
8360
if(kind == "error" & ! is.null(tempo.error)){ # 
if(header == TRUE){
tempo.error[1] <- gsub(x = tempo.error[1], pattern = "^Error i|^error i|^ERROR I", replacement = "I")
output <- paste0("ERROR MESSAGE REPORTED", ifelse(is.null(text), "", " "), text, ":\n", tempo.error[1]) #
Gael  MILLOT's avatar
Gael MILLOT committed
8361
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
8362
output <- tempo.error[1] #
Gael  MILLOT's avatar
Gael MILLOT committed
8363
}
Gael  MILLOT's avatar
Gael MILLOT committed
8364
8365
8366
8367
8368
8369
8370
8371
8372
8373
8374
8375
8376
8377
}else if(kind == "error" & is.null(tempo.error) & print.no == TRUE){
output <- paste0("NO ERROR MESSAGE REPORTED", ifelse(is.null(text), "", " "), text)
}else if(kind != "error" & ( ! is.null(tempo.error)) & print.no == TRUE){
output <- paste0("NO ", ifelse(kind == "warning", "WARNING", "STANDARD (NON ERROR AND NON WARNING)"), " MESSAGE BECAUSE OF ERROR MESSAGE REPORTED", ifelse(is.null(text), "", " "), text)
}else if(is.null(tempo.error)){
fun.warning.capture <- function(expr){
# from demo(error.catching) typed in the R console, coming from ?tryCatch
# see also http://mazamascience.com/WorkingWithData/?p=912
# return a character string or NULL
# expr <- wilcox.test.default(c(1, 1, 3), c(1, 2, 4), paired = TRUE)
W <- NULL
w.handler <- function(w){ # warning handler
W <<- w # send to the above env, i.e., the inside of the fun.warning.capture function
invokeRestart("muffleWarning") # here w.handler() muffles all the warnings. See http://romainfrancois.blog.free.fr/index.php?post/2009/05/20/Disable-specific-warnings to muffle specific warnings and print others
8378
}
Gael  MILLOT's avatar
Gael MILLOT committed
8379
8380
8381
8382
8383
output <- list(
value = suppressMessages(withCallingHandlers(tryCatch(expr, error = function(e){e}), warning = w.handler)), # BEWARE: w.handler is a function written without (), like in other functions with FUN argument
warning = W # processed by w.handler()
)
return(if(is.null(output$warning)){NULL}else{as.character(output$warning)})
Gael  MILLOT's avatar
Gael MILLOT committed
8384
}
Gael  MILLOT's avatar
Gael MILLOT committed
8385
8386
8387
8388
8389
8390
8391
8392
tempo.warn <- fun.warning.capture(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))
# warn.options.ini <- options()$warn ; options(warn = 1) ; tempo.warn <- utils::capture.output({tempo <- suppressMessages(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))}, type = "message") ; options(warn = warn.options.ini) # this recover warnings not messages and not errors but does not work in all enviroments
tempo.message <- utils::capture.output({
tempo <- suppressMessages(suppressWarnings(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env})))
if(any(class(tempo) %in% c("gg", "ggplot"))){
tempo <- ggplot2::ggplot_build(tempo)
}else{
tempo <- suppressWarnings(eval(parse(text = data), envir = if(is.null(env)){parent.frame()}else{env}))
Gael  MILLOT's avatar
Gael MILLOT committed
8393
}
Gael  MILLOT's avatar
Gael MILLOT committed
8394
8395
8396
8397
8398
}, type = "message") # recover messages not warnings and not errors
if(kind == "warning" & ! is.null(tempo.warn)){
if(length(tempo.warn) > 0){ # to avoid character(0)
if( ! any(sapply(tempo.warn, FUN = "grepl", pattern = "() FUNCTION:$"))){
tempo.warn <- paste(unique(tempo.warn), collapse = "\n") # if FALSE, means that the tested data is a special function. If TRUE, means that the data is a standard function. In that case, the output of capture.output() is two strings per warning messages: if several warning messages -> identical first string, which is removed in next messages by unique()
Gael  MILLOT's avatar
Gael MILLOT committed
8399
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
8400
tempo.warn <- paste(tempo.warn, collapse = "\n")
Gael  MILLOT's avatar
Gael MILLOT committed
8401
}
Gael  MILLOT's avatar
Gael MILLOT committed
8402
8403
8404
if(header == TRUE){
if(any(grepl(x = tempo.warn[[1]], pattern = "^simpleWarning i"))){
tempo.warn[[1]] <- gsub(x = tempo.warn[[1]], pattern = "^Warning i", replacement = "I")
Gael  MILLOT's avatar
Gael MILLOT committed
8405
}
Gael  MILLOT's avatar
Gael MILLOT committed
8406
8407
if(any(grepl(x = tempo.warn[[1]], pattern = "^Warning i"))){
tempo.warn[[1]] <- gsub(x = tempo.warn[[1]], pattern = "^Warning i", replacement = "I")
Gael  MILLOT's avatar
Gael MILLOT committed
8408
}
Gael  MILLOT's avatar
Gael MILLOT committed
8409
output <- paste0("WARNING MESSAGE REPORTED", ifelse(is.null(text), "", " "), text, ":\n", tempo.warn) #
Gael  MILLOT's avatar
Gael MILLOT committed
8410
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
8411
output <- tempo.warn #
Gael  MILLOT's avatar
Gael MILLOT committed
8412
}
Gael  MILLOT's avatar
Gael MILLOT committed
8413
8414
}else if(print.no == TRUE){
output <- paste0("NO WARNING MESSAGE REPORTED", ifelse(is.null(text), "", " "), text)
Gael  MILLOT's avatar
Gael MILLOT committed
8415
}
Gael  MILLOT's avatar
Gael MILLOT committed
8416
8417
8418
8419
8420
8421
}else if(kind == "warning" & is.null(tempo.warn) & print.no == TRUE){
output <- paste0("NO WARNING MESSAGE REPORTED", ifelse(is.null(text), "", " "), text)
}else if(kind == "message" & exists("tempo.message", inherit = FALSE) == TRUE){ # inherit = FALSE avoid the portee lexical and thus the declared word
if(length(tempo.message) > 0){ # if something is returned by capture.ouptput() (only in this env) with a length more than 1
if(header == TRUE){
output <- paste0("STANDARD (NON ERROR AND NON WARNING) MESSAGE REPORTED", ifelse(is.null(text), "", " "), text, ":\n", tempo.message) #
Gael  MILLOT's avatar
Gael MILLOT committed
8422
}else{
Gael  MILLOT's avatar
Gael MILLOT committed
8423
output <- tempo.message #
Gael  MILLOT's avatar
Gael MILLOT committed
8424
}
Gael  MILLOT's avatar
Gael MILLOT committed
8425
8426
}else if(print.no == TRUE){
output <- paste0("NO STANDARD (NON ERROR AND NON WARNING) MESSAGE REPORTED", ifelse(is.null(text), "", " "), text)
Gael  MILLOT's avatar
Gael MILLOT committed
8427
}
Gael  MILLOT's avatar
Gael MILLOT committed
8428
8429
8430
8431
8432
8433
}else if(kind == "message" & exists("tempo.message", inherit = FALSE) == FALSE & print.no == TRUE){
output <- paste0("NO STANDARD (NON ERROR AND NON WARNING) MESSAGE REPORTED", ifelse(is.null(text), "", " "), text)
}
}
invisible(dev.off(window.nb)) # end send plots into a NULL file
return(output) # do not use cat() because the idea is to reuse the message
Gael  MILLOT's avatar
Gael MILLOT committed
8434
8435
}

8436
8437