diff --git a/examples_check.R b/examples_check.R
deleted file mode 100644
index 2f6c1f3f437d19a5bc31f7ce315ced4b791c4db3..0000000000000000000000000000000000000000
--- a/examples_check.R
+++ /dev/null
@@ -1,160 +0,0 @@
-
-
-######## check() #### check class, type, length, etc., of objects
-
-### Datasets
-vec1 <- -1:3 # vector of integers
-vec2 <- 1:3 / 3 # vector of proportions
-vec3 <- c(1, 2, 3) # vector of integers but stored as "double"
-vec4 <- "pearson" # vector of characters
-vec5 <- c("a", "b","a", "b") # vector of characters
-mat1 <- matrix(vec1) # matrix of integers
-mat2 <- matrix(c(1:3 / 3, NA)) # matrix of proportions with NA
-
-
-### Datasets info
-vec1 # vector of integers
-vec2 # vector of proportions
-vec3 # vector of integers but stored as "double"
-vec4 # vector of characters
-vec5 # vector of characters
-mat1 # matrix of integers
-mat2 # matrix of proportions with NA
-
-
-### Simple examples
-# Check that vec1 is of class integer (means that it is also a vector) -> ok
-check(data = vec1, class = "integer")
-# Check that vec1 is a numeric vector -> error because vec1 is a vector of integers
-check(data = vec1, class = "numeric")
-# Check that vec1 is an integer vector of length 3 without negative values and without NA -> error because of length 5 and negative values inside vec1
-check(data = vec1, class = "vector", typeof = "integer", length = 3, neg.values = FALSE, na.contain = FALSE)
-# No result displayed because the output list is assigned into res (see below the print argument)
-res <- check(data = vec1, class = "integer")
-
-# with data = NULL, the function systematically report a checking problem
-check(data = NULL, class = "integer")
-
-### Argument class, typeof, mode and length are the same as the corresponding R function, except class which 1) has also "vector" and 2) remains "matrix" for matrices and not "matrix" "array"
-# Example
-check(data = vec1,
- class = "vector",
- typeof = "integer",
- mode = "numeric",
- length = 5,
-)
-# Warning: the function does not check for inconsistencies between arguments. It just checks if everything is ok between arguments values and data
-check(data = vec1,
- typeof = "integer",
- mode = "character", # the mode "character" exists but is inconsistant with typeof "integer". However, this aspect is not signaled by the function
-)
-# Error message due to wrong value in the class and length arguments
-check(data = vec1,
- mode = "integer", # the mode "integer" does not exist in the mode() function of R
-)
-
-### Argument prop
-check(data = mat2,
- prop = TRUE # Check for values between 0 and 1 only
-)
-
-### Argument double.as.integer.allowed
-check(data = vec3, typeof = "integer",
- double.as.integer.allowed = TRUE # with TRUE, integers stored as double are accepted
-)
-
-### Argument options
-check(data = vec4,
- options = c("pearson", "spearman", "kendall")
-)
-
-### Argument all.options.in.data
-# No error
-check(data = vec5,
- options = c("a", "b"),
- all.options.in.data = TRUE
-)
-# No error
-check(data = vec5,
- options = c("a", "b", "c"),
- all.options.in.data = FALSE
-)
-# Error
-check(data = vec5,
- options = c("a", "b", "c"),
- all.options.in.data = TRUE
-)
-
-### Argument na.contain
-check(data = mat2, class = "matrix", prop = TRUE,
- na.contain = FALSE # with TRUE, integers stored as double are accepted
-)
-
-### Argument neg.values
-# Warning: only considered if set to FALSE, to check for non negative values when class is set to "vector", "numeric", "matrix", "array", "data.frame", "table", or typeof is set to "double", "integer", or mode is set to "numeric"
-check(data = mat1, class = "matrix",
- neg.values = FALSE # with TRUE, integers stored as double are accepted
-)
-
-### Argument inf.values
-# Warning: only considered if set to FALSE, to check for non infinite values when class is set to "vector", "numeric", "matrix", "array", "data.frame", "table", or typeof is set to "double", "integer", or mode is set to "numeric"
-check(data = mat1, class = "matrix",
- inf.values = FALSE
-)
-
-### Argument print
-# No error message printed because print is FALSE
-res <- check(data = mat1, class = "data.frame",
- print = FALSE
-)
-# Error message printed
-res <- check(data = mat1, class = "data.frame",
- print = TRUE
-)
-# Even if print is TRUE, no error message printed because no error
-res <- check(data = mat1, class = "matrix",
- print = TRUE
-)
-
-
-### Arguments data.name and fun.name
-# Example
-tempo <- check(data = vec1, class = "integer",
- data.name = "OBSERVATION_1",
- fun.name = "FUNCTION_1"
-)
-tempo$text
-# In fact, these two arguments are interesting when check() is used inside functions
-fun1 <- function(arg1){
- tempo <- check(data = arg1, class = "integer",
- data.name = NULL, # if NULL, the name displayed is arg1
- fun.name = NULL # if NULL, no name displayed
- )
- if(tempo$problem == TRUE){
- cat(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n"))
- }
-}
-fun1(arg1 = vec4) # error message because arg1 requires a vector of integers
-
-
-
-### All the arguments
-# See the examples of fun_info() to test different classes of objects
-check(
- data = vec1,
- class = "integer",
- typeof = NULL,
- mode = NULL,
- length = NULL,
- prop = FALSE,
- double.as.integer.allowed = FALSE,
- options = NULL,
- all.options.in.data = FALSE,
- na.contain = FALSE,
- neg.values = TRUE,
- inf.values = TRUE,
- print = FALSE,
- data.name = NULL,
- fun.name = NULL
-)
-
diff --git a/examples_fun_head.R b/examples_fun_head.R
deleted file mode 100755
index fc31fcfcb9ab8c178d6db6606615b92912eb7aa4..0000000000000000000000000000000000000000
--- a/examples_fun_head.R
+++ /dev/null
@@ -1,39 +0,0 @@
-
-
-
-######### fun_head() #### head of the left or right of big 2D objects
-
-### Datasets
-vec1 <- 1:100 # vector of integers
-mat1 <- diag(1:20) ; dimnames(mat1) <- list(letters[1:20], LETTERS[1:20]) # diagonal matrix 20 * 20 with row names and column names
-
-
-### Datasets info
-vec1 # vector of integers
-mat1 # diagonal matrix 20 * 20 with row names and column names
-
-
-### Simple example
-fun_head(data1 = vec1) # fun_head() works like head() on non 2D objects
-fun_head(data1 = mat1)
-
-
-### Argument n
-fun_head(data1 = mat1, n = 5) # number of dimension to print (5 means 5 rows and columns)
-
-
-### Argument side
-fun_head(data1 = mat1, side = "r") # left or right side of the 2D object (only for matrix, data frame or table)
-
-
-### All the arguments
-fun_head(
- data1 = mat1,
- n = 6,
- side = "l"
-)
-
-
-
-
-
diff --git a/examples_fun_tail.R b/examples_fun_tail.R
deleted file mode 100755
index 79237a9e98c4ed634a500a78b0ef24859e227098..0000000000000000000000000000000000000000
--- a/examples_fun_tail.R
+++ /dev/null
@@ -1,39 +0,0 @@
-
-
-
-######### fun_tail() #### tail of the left or right of big 2D objects
-
-### Datasets
-vec1 <- 1:100 # vector of integers
-mat1 <- diag(1:20) ; dimnames(mat1) <- list(letters[1:20], LETTERS[1:20]) # diagonal matrix 20 * 20 with row names and column names
-
-
-### Datasets info
-vec1 # vector of integers
-mat1 # diagonal matrix 20 * 20 with row names and column names
-
-
-### Simple example
-fun_tail(data1 = vec1) # fun_tail() works like tail() on non 2D objects
-fun_tail(data1 = mat1)
-
-
-### Argument n
-fun_tail(data1 = mat1, n = 5) # number of dimension to print (5 means 5 rows and columns)
-
-
-### Argument side
-fun_tail(data1 = mat1, side = "r") # left or right side of the 2D object (only for matrix, data frame or table)
-
-
-### All the arguments
-fun_tail(
- data1 = mat1,
- n = 6,
- side = "l"
-)
-
-
-
-
-
diff --git a/examples_info.R b/examples_info.R
deleted file mode 100644
index a3bc5a1f7ebb6283e4446f28d085540c14311302..0000000000000000000000000000000000000000
--- a/examples_info.R
+++ /dev/null
@@ -1,87 +0,0 @@
-
-
-
-
-
-######## info() #### recover object information
-
-### Datasets
-vec1 <- -1:3 # vector of integers
-vec2 <- 1:3 / 3 # vector of proportions
-vec3 <- c(1, 2, NA, -Inf) # vector of integers but stored as "double", with NA and Inf
-vec4 <- "pearson" # vector of characters
-vec5 <- c("a", "b","a", NA) # vector of characters with NA
-cpx <- as.complex(1) # complex
-mat1 <- matrix(vec1) # 1D matrix of integers
-mat2 <- matrix(c(1:5, NA), ncol = 2, dimnames = list(c("ROW1", "ROW2", "ROW3"), c("M1", "M2"))) # 2D matrix of floats with NA
-df1 <- as.data.frame(mat2) # data.frame
-l1 <- list(L1 = 1:3, L2 = letters[1:3]) # list
-fac1 <- factor(rep(letters[4:6], c(4:6))) # factor
-tab1 <- table(fac1) # 1D table
-tab2 <- table(fac1, fac1) # 2D table
-exp1 <- expression("a") # object of class "expression", mode "expression" & type "expression"
-name1 <- substitute(exp1) # object of class "name", mode "name" & type "symbol"
-fun1 <- mean # closure function of class "function", mode "function" & type "closure"
-fun2 <- sum # primitive function of class "function", mode "function" & type "builtin"
-fun3 <- get("<-") # primitive function of class "function", mode "function" & type "special"
-env1 <- new.env() # environment
-s4 <- show # S4 object
-call1 <- call("call1") # object of class "call", mode "call" & type "language"
-
-### Datasets info
-vec1 # vector of integers
-vec2 # vector of proportions
-vec3 # vector of integers but stored as "double", with NA
-vec4 # vector of characters
-vec5 # vector of characters with NA
-mat1 # 1D matrix of integers
-mat2 # 2D matrix of floats with NA
-df1 # data.frame
-l1 # list
-fac1 # factor
-tab1 # 1D table
-tab2 # 2D table
-exp1 # object of class "expression", mode "expression" & type "expression"
-name1 # object of class "name", mode "name" & type "symbol"
-fun1 # closure function of class "function", mode "function" & type "closure"
-fun2 # primitive function of class "function", mode "function" & type "builtin"
-fun3 # primitive function of class "function", mode "function" & type "special"
-env1 # environment
-s4 # S4 object
-call1 # object of class "call", mode "call" & type "language"
-
-
-### Simple example
-info(data = vec1) # vector of integers
-info(data = vec2) # vector of proportions
-info(data = vec3) # vector of integers but stored as "double", with NA and Inf
-info(data = vec4) # vector of characters
-info(data = vec5) # vector of characters with NA
-info(data = mat1) # 1D matrix of integers
-info(data = mat2) # 2D matrix of floats with NA
-info(data = df1) # data.frame
-info(data = l1) # list
-info(data = fac1) # factor
-info(data = tab1) # 1D table
-info(data = tab2) # 2D table
-info(data = exp1) # object of class "expression", mode "expression" & type "expression"
-info(data = name1) # object of class "name", mode "name" & type "symbol"
-info(data = fun1) # closure function of class "function", mode "function" & type "closure"
-info(data = fun2) # primitive function of class "function", mode "function" & type "builtin"
-info(data = fun3) # primitive function of class "function", mode "function" & type "special"
-info(data = env1) # environment
-info(data = s4) # S4 object
-info(data = call1) # object of class "call", mode "call" & type "language"
-
-
-
-### All the arguments
-info(
- data = vec1,
- n = 1, # number of element to display per compartment of the output list (i.e., head(..., n))
- warn.print = FALSE
-)
-
-
-
-
diff --git a/fun_secu.R b/fun_secu.R
deleted file mode 100644
index ed93411d26ac35976b49acbcdbbd9af352a975f3..0000000000000000000000000000000000000000
--- a/fun_secu.R
+++ /dev/null
@@ -1,120 +0,0 @@
-fun_secu <- function(pos = 1, name = NULL){
- # AIM
- # Verify that object names in the environment defined by the pos parameter are identical or not to object names in the above environment (following R Scope). This can be used to verify that names used for objects inside a function or in the working environment do not override names of objects already present in the above R environments, following the R scope.
- # ARGUMENTS
- # pos: single non nul positive integer indicating the position of the environment checked (argument n of the parent.frame() function). Value 1 means one step above the fun_secu() local environment (by default). This means that when fun_secu(pos = 1) is used inside a function A, it checks if the name of any object in the local environment of this function A is also present in above environments, following R Scope, starting by the just above environment. When fun_secu(pos = 1) is used in the working (Global) environment (named .GlobalEnv), it checks the object names of this .GlobalEnv environment, in the above environments. See the examples below.
- # name: single character string indicating a string that will be added in the output string, for instance the name of a function inside which fun_secu() is used.
- # RETURN
- # A character string indicating the object names of the tested environment that match object names in the above environments, following the R scope, or NULL if no match.
- # REQUIRED PACKAGES
- # None
- # REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
- # fun_check()
- # EXAMPLES
- # Example in the working environment
- # mean <- 1 # creation of the object mean with value 1 in the .GlobalEnv environment, knowing that the mean() function also exists in the environment base, above .GlobalEnv.
- # t.test <- 1 # creation of the object t.test with value 1 in the .GlobalEnv environment, knowing that the t.test() function also exists in the environment stats, above .GlobalEnv.
- # search() # current R scope (order of the successive R environments).
- # find("mean") # where the objects with the name "mean" are present.
- # find("t.test") # where the objects with the name "mean" are present.
- # a <- fun_secu(pos = 1) # test if any object name of the global environment are above environments (or fun_secu(), as pos = 1 is the default value).
- # a # the output string of fun_sec().
- # cat(a) # the evaluated output.
- # fun_secu(pos = 2) # test if any object of the stats environment (one step above .GlobalEnv) are above environments. Returns NULL since no object names of stats are in above environments
- # Example inside a function
- # fun1 <- function(){t.test <- 0 ; mean <- 5 ; fun_secu(pos = 1)} # fun_secu() will check if the object names inside the fun1 function exist in the .GlobalEnv environment and above.
- # fun1()
- # fun2 <- function(){t.test <- 0 ; mean <- 5 ; fun_secu(pos = 2)} # fun_secu() will check if the object names inside the fun2 function exist in the stats environment and above.
- # fun2()
- # fun3 <- function(){t.test <- 0 ; mean <- 5 ; fun_secu(pos = 2, name = "fun3")} # idem fun2() but with the name of the function fun2 indicated. Instead of writting name = "fun3", we can also use name = as.character(sys.calls()[[length(sys.calls())]]), as sys.calls() gives the function name at top stack of the imbricated functions, sys.calls()[[length(sys.calls())]] the name of the just above function. This can also been used for the above function: as.character(sys.call(1))
- # fun3()
- # test.pos <- 1
- # fun_secu(pos = test.pos, name = if(length(sys.calls()) >= test.pos){as.character(sys.calls()[[length(sys.calls()) + 1 - test.pos]])}else{search()[ (1:length(search()))[test.pos - length(sys.calls())]]}) # here is a way to have the name of the tested environment according to test.pos value
- # DEBUGGING
- # pos = 1 ; name = "mean" # for function debugging
- # function name
- function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
- arg.user.setting <- as.list(match.call(expand.dots = FALSE))[-1] # list of the argument settings (excluding default values not provided by the user)
- # end function name
- # required function checking
- if(length(utils::find("fun_check", mode = "function")) == 0L){
- tempo.cat <- paste0("ERROR IN ", function.name, "\nREQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- }
- # end required function checking
- # argument primary checking
- # arg with no default values
- # end arg with no default values
- # using fun_check()
- arg.check <- NULL #
- text.check <- NULL #
- checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
- ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$object.name))
- tempo <- fun_check(data = pos, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, length = 1, fun.name = function.name) ; eval(ee)
- if( ! is.null(name)){
- tempo <- fun_check(data = name, class = "vector", typeof = "character", fun.name = function.name) ; eval(ee)
- }
- if( ! is.null(arg.check)){
- if(any(arg.check) == TRUE){
- stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
- }
- }
- # end using fun_check()
- # source("C:/Users/gmillot/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.7/r_debugging_tools-v1.7.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
- # end argument primary checking
- # second round of checking and data preparation
- # management of NA arguments
- if( ! (all(class(arg.user.setting) == "list") & length(arg.user.setting) == 0)){
- tempo.arg <- names(arg.user.setting) # values provided by the user
- tempo.log <- suppressWarnings(sapply(lapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = is.na), FUN = any)) & lapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = length) == 1L # no argument provided by the user can be just NA
- if(any(tempo.log) == TRUE){ # normally no NA because is.na() used here
- tempo.cat <- paste0("ERROR IN ", function.name, "\n", ifelse(sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT JUST BE NA:", paste0(tempo.arg[tempo.log], collapse = "\n"))
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- }
- }
- # end management of NA arguments
- # management of NULL arguments
- tempo.arg <- c(
- "pos"
- )
- tempo.log <- sapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = is.null)
- if(any(tempo.log) == TRUE){
- tempo.cat <- paste0("ERROR IN ", function.name, "\n", ifelse(sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT BE NULL:", paste0(tempo.arg[tempo.log], collapse = "\n"))
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- }
- # end management of NULL arguments
- # end second round of checking and data preparation
- # main code
- # match.list <- vector("list", length = (length(sys.calls()) - 1 + length(search()) + ifelse(length(sys.calls()) == 1L, -1, 0))) # match.list is a list of all the environment tested (local of functions and R envs), length(sys.calls()) - 1 to remove the level of the fun_secu() function, sys.calls() giving all the names of the imbricated functions, including fun_secu, ifelse(length(sys.calls()) == 1L, -1, 0) to remove Global env if this one is tested
- tempo.name <- rev(as.character(unlist(sys.calls()))) # get names of frames (i.e., enclosed env)
- tempo.frame <- rev(sys.frames()) # get frames (i.e., enclosed env)
- # dealing with source()
- # source() used in the Global env creates three frames above the Global env, which should be removed because not very interesting for variable duplications. Add a <<-(sys.frames()) in this code and source anova_contrasts code to see this. With ls(a[[4]]), we can see the content of each env, which are probably elements of source()
- if(any(sapply(tempo.frame, FUN = environmentName) %in% "R_GlobalEnv")){
- global.pos <- which(sapply(tempo.frame, FUN = environmentName) %in% "R_GlobalEnv")
- # remove the global env (because already in search(), and all the oabove env
- tempo.name <- tempo.name[-c(global.pos:length(tempo.frame))]
- tempo.frame <- tempo.frame[-c(global.pos:length(tempo.frame))]
- }
- # end dealing with source()
- # might have a problem if(length(tempo.name) == 0L){
- match.list <- vector("list", length = length(tempo.name) + length(search())) # match.list is a list of all the environment tested (local of functions and R envs), length(sys.calls()) - 1 to remove the level of the fun_secu() function, sys.calls() giving all the names of the imbricated functions, including fun_secu, ifelse(length(sys.calls()) == 1L, -1, 0) to remove Global env if this one is tested
- ls.names <- c(tempo.name, search()) # names of the functions + names of the search() environments
- ls.input <- c(tempo.frame, as.list(search())) # environements of the functions + names of the search() environments
- names(match.list) <- ls.names #
- match.list <- match.list[-c(1:(pos + 1))] # because we check only above pos
- ls.tested <- ls.input[[pos + 1]]
- ls.input <- ls.input[-c(1:(pos + 1))]
- for(i1 in 1:length(match.list)){
- if(any(ls(name = ls.input[[i1]], all.names = TRUE) %in% ls(name = ls.tested, all.names = TRUE))){
- match.list[i1] <- list(ls(name = ls.input[[i1]], all.names = TRUE)[ls(name = ls.input[[i1]], all.names = TRUE) %in% ls(name = ls.tested, all.names = TRUE)])
- }
- }
- if( ! all(sapply(match.list, FUN = is.null))){
- output <- paste0("SOME VARIABLES ", ifelse(is.null(name), "OF THE CHECKED ENVIRONMENT", paste0("OF ", name)), " ARE ALSO PRESENT IN :\n", paste0(names(match.list[ ! sapply(match.list, FUN = is.null)]), ": ", sapply(match.list[ ! sapply(match.list, FUN = is.null)], FUN = paste0, collapse = " "), collapse = "\n"), "\n")
- }else{
- output <- NULL
- }
- return(output)
-}
-
diff --git a/fun_test.R b/fun_test.R
deleted file mode 100644
index dbebe71e209c10b820b684b0a758d5a1ce49b4db..0000000000000000000000000000000000000000
--- a/fun_test.R
+++ /dev/null
@@ -1,797 +0,0 @@
-# add traceback https://stackoverflow.com/questions/47414119/how-to-read-a-traceback-in-r
-#
-# remove cute.path argument everywhere in this function. But check that cuteDev packages are accessible in the environment of parallelization
-# in if(exists(env.name, where = -1)){ # verify if still ok when fun_test() is inside a function
-# was in red : assign("val", val, envir = get(env.name, env = sys.nframe(), inherit = FALSE)) # var replaced by val
-# was in red : # after return() ? # can we put this after return ? I do not think so
-
-fun_test <- function(
- fun,
- arg,
- val,
- expect.error = NULL,
- parall = FALSE,
- thread.nb = NULL,
- print.count = 10,
- plot.fun = FALSE,
- export = FALSE,
- res.path = NULL,
- lib.path = NULL,
- cute.path = "C:\\Users\\gmillot\\Documents\\Git_projects\\cute_little_R_functions\\cute_little_R_functions.R"
-){
- # AIM
- # test combinations of argument values of a function
- # WARNINGS
- # Limited to 43 arguments with at least 2 values each. The total number of arguments tested can be more if the additional arguments have a single value. The limit is due to nested "for" loops (https://stat.ethz.ch/pipermail/r-help/2008-March/157341.html), but this limitation is away from the number of tests performed that would be 2^43
- # ARGUMENTS
- # fun: character string indicating the name of the function tested (without brackets)
- # arg: vector of character strings of arguments of fun. At least arguments that do not have default values must be present in this vector
- # val: list with number of compartments equal to the length of arg, each compartment containing values of the corresponding argument in arg. Each different value must be in a list or in a vector. For instance, argument 3 in arg is a logical argument (values accepted TRUE, FALSE, NA). Thus, compartment 3 of val can be either list(TRUE, FALSE, NA), or c(TRUE, FALSE, NA). NULL value alone must be written list(NULL)
- # expect.error: list of exactly the same structure as val argument, but containing FALSE or TRUE, depending on whether error is expected (TRUE) or not (FALSE) for each corresponding value of val. A message is returned depending on discrepancies between the expected and observed errors. See the examples below. BEWARE: not always possible to write the expected errors for all the combination of argument values. Ignored if NULL
- # parall: Single logical value. Force parallelization ?
- # thread.nb: single numeric integer indicating the number of threads to use if ever parallelization is required. If NULL, all the available threads will be used. Ignored if parall is FALSE
- # print.count: single interger value. Print a working progress message every print.count during loops. BEWARE: can increase substentially the time to complete the process if using a small integer value, like 10 for instance. Use Inf if no loop message desired
- # plot.fun: single logical value. Plot the plotting function tested for each test? Ignored if the tested function is not a graphic function
- # export: single logical value. Export the results into a .RData file and into a .tsv file? If FALSE, return a list into the console (see below). BEWARE: will be automatically set to TRUE if parall is TRUE. This means that when using parallelization, the results are systematically exported, not returned into the console
- # res.path: single character string indicating the absolute pathway of the folder where the txt results and pdfs, containing all the plots, will be saved. Several txt and pdf, one per thread, if parallelization. Ignored if export is FALSE. Must be specified if parall is TRUE or if export is TRUE
- # lib.path: vector of characters specifying the absolute pathways of the directories containing the required packages if not in the default directories. Ignored if NULL
- # cute.path: character string indicating the absolute path of the cute.R file. Will be remove when cute will be a package. Ignored if parall is FALSE
- # REQUIRED PACKAGES
- # lubridate
- # parallel if parall argument is TRUE (included in the R installation packages but not automatically loaded)
- # pdftools if parall argument is TRUE (included in the R installation packages but not automatically loaded)
- # If the tested function is in a package, this package must be imported first (no parallelization) or must be in the classical R package folder indicated by the lib.path argument (parallelization)
- # RETURN
- # if export is FALSE a list containing:
- # $fun: the tested function
- # $ini: the initial input values
- # $data: a data frame of all the combination tested, containing the following columns:
- # the different values tested, named by arguments
- # $kind: a vector of character strings indicating the kind of test result: either "ERROR", or "WARNING", or "OK"
- # $problem: a logical vector indicating if error or not
- # $expected.error: optional logical vector indicating the expected error specified in the expect.error argument
- # $message: either NULL if $kind is always "OK", or the messages
- # $sys.info: system and packages info
- # if export is TRUE 1) the same list object into a .RData file, 2) also the $data data frame into a .tsv file, and 3) if expect.error is non NULL and if any discrepancy, the $data data frame into a .tsv file but containing only the rows with discrepancies between expected and observed errors
- # one or several pdf if a plotting function is tested and if the plot.fun argument is TRUE
- # REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
- # fun_check()
- # fun_get_message()
- # fun_pack()
- # EXAMPLES
- # fun_test(fun = "unique", arg = c("x", "incomparables"), val = list(x = list(1:10, c(1,1,2,8), NA), incomparable = c(TRUE, FALSE, NA)))
- # fun_test(fun = "unique", arg = c("x", "incomparables"), val = list(x = list(1:10, c(1,1,2,8), NA), incomparable = c(TRUE, FALSE, NA)), expect.error = list(x = list(FALSE, FALSE, TRUE), incomparable = c(FALSE, FALSE, TRUE)))
- # fun_test(fun = "unique", arg = c("x", "incomparables"), val = list(x = list(1:10, c(1,1,2,8), NA), incomparable = c(TRUE, FALSE, NA)), expect.error = list(x = list(FALSE, FALSE, TRUE), incomparable = c(FALSE, FALSE, TRUE)), export = TRUE, res.path = getwd())
- # fun_test(fun = "fun_round", arg = c("data", "dec.nb", "after.lead.zero"), val = list(L1 = list(c(1, 1.0002256, 1.23568), "a", NA), L2 = list(2, c(1,3), NA), L3 = c(TRUE, FALSE, NA)))
- # fun_test(fun = "plot", arg = c("x", "y"), val = list(x = list(1:10, 12:13, NA, (1:10)^2), y = list(1:10, NA, NA)), expect.error = list(x = list(FALSE, TRUE, TRUE, FALSE), y = list(FALSE, TRUE, TRUE)), parall = FALSE, thread.nb = NULL, plot.fun = TRUE, res.path = "C:\\Users\\gmillot\\Desktop\\", lib.path = NULL)
- # fun_test(fun = "plot", arg = c("x", "y"), val = list(x = list(1:10, 12:13, NA, (1:10)^2), y = list(1:10, NA, NA)), parall = FALSE, thread.nb = 4, plot.fun = TRUE, res.path = "C:\\Users\\gmillot\\Desktop\\", lib.path = "C:\\Program Files\\R\\R-4.3.1\\library\\")
- # set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10), stringsAsFactors = TRUE) ; fun_test(fun = "fun_gg_boxplot", arg = c("data1", "y", "categ"), val = list(L1 = list(L1 = obs1), L2 = list(L1 = "Time"), L3 = list(L1 = "Group1")))
- # set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10), stringsAsFactors = TRUE) ; fun_test(fun = "fun_gg_boxplot", arg = c("data1", "y", "categ"), val = list(L1 = list(obs1), L2 = "Time", L3 = "Group1"), parall = FALSE, thread.nb = NULL, plot.fun = TRUE, res.path = "C:\\Users\\gmillot\\Desktop\\", lib.path = "C:\\Program Files\\R\\R-4.3.1\\library\\")
- # library(ggplot2) ; fun_test(fun = "geom_histogram", arg = c("data", "mapping"), val = list(x = list(data.frame(X = "a", stringsAsFactors = TRUE)), y = list(ggplot2::aes(x = X))), parall = FALSE, thread.nb = NULL, plot.fun = TRUE, res.path = "C:\\Users\\gmillot\\Desktop\\", lib.path = "C:\\Program Files\\R\\R-4.3.1\\library\\") # BEWARE: ggplot2::geom_histogram does not work
- # DEBUGGING
- # fun = "unique" ; arg = "x" ; val = list(x = list(1:10, c(1,1,2,8), NA)) ; expect.error = list(x = list(FALSE, FALSE, TRUE)) ; parall = FALSE ; thread.nb = NULL ; plot.fun = FALSE ; export = FALSE ; res.path = "C:\\Users\\gmillot\\Desktop\\" ; lib.path = NULL ; print.count = 1 ; cute.path = "C:\\Users\\gmillot\\Documents\\Git_projects\\cute_little_R_functions\\cute_little_R_functions.R" # for function debugging
- # fun = "unique" ; arg = c("x", "incomparables") ; val = list(x = list(1:10, c(1,1,2,8), NA), incomparable = c(TRUE, FALSE, NA)) ; expect.error = NULL ; parall = FALSE ; thread.nb = 2 ; plot.fun = FALSE ; export = TRUE ; res.path = "C:\\Users\\gmillot\\Desktop\\" ; lib.path = NULL ; print.count = 10 ; cute.path = "C:\\Users\\gmillot\\Documents\\Git_projects\\cute_little_R_functions\\cute_little_R_functions.R" # for function debugging
- # fun = "plot" ; arg = c("x", "y") ; val = list(x = list(1:10, 12:13, NA), y = list(1:10, NA, NA)) ; expect.error = list(x = list(FALSE, FALSE, TRUE, FALSE), y = list(FALSE, TRUE, TRUE)) ; print.count = 10 ; parall = FALSE ; thread.nb = NULL ; plot.fun = TRUE ; export = TRUE ; res.path = "C:\\Users\\gmillot\\Desktop\\" ; lib.path = NULL # for function debugging
- # set.seed(1) ; obs1 <- data.frame(Time = c(rnorm(10), rnorm(10) + 2), Group1 = rep(c("G", "H"), each = 10), stringsAsFactors = TRUE) ; fun = "fun_gg_boxplot" ; arg = c("data1", "y", "categ") ; val = list(L1 = list(L1 = obs1), L2 = list(L1 = "Time"), L3 = list(L1 = "Group1")) ; expect.error = NULL ; print.count = 10 ; parall = FALSE ; thread.nb = NULL ; plot.fun = TRUE ; export = TRUE ; res.path = "C:\\Users\\gmillot\\Desktop\\" ; lib.path = NULL # for function debugging
- # fun = "unique" ; arg = "x" ; val = list(x = list(1:3, mean)) ; expect.error = list(x = list(TRUE, TRUE)) ; parall = FALSE ; thread.nb = NULL ; plot.fun = FALSE ; export = FALSE ; res.path = "C:\\Users\\gmillot\\Desktop\\" ; lib.path = NULL ; print.count = 1 ; cute.path = "C:\\Users\\gmillot\\Documents\\Git_projects\\cute_little_R_functions\\cute_little_R_functions.R" # for function debugging
- # function name
- ini <- match.call(expand.dots = FALSE) # initial parameters
- function.name <- paste0(as.list(match.call(expand.dots = FALSE))[[1]], "()")
- arg.names <- names(formals(fun = sys.function(sys.parent(n = 2)))) # names of all the arguments
- arg.user.setting <- as.list(match.call(expand.dots = FALSE))[-1] # list of the argument settings (excluding default values not provided by the user)
- # end function name
- # required function checking
- req.function <- c(
- "fun_check",
- "fun_get_message",
- "fun_pack"
- )
- tempo <- NULL
- for(i1 in req.function){
- if(length(find(i1, mode = "function")) == 0L){
- tempo <- c(tempo, i1)
- }
- }
- if( ! is.null(tempo)){
- tempo.cat <- paste0("ERROR IN ", function.name, "\nREQUIRED cute FUNCTION", ifelse(length(tempo) > 1, "S ARE", " IS"), " MISSING IN THE R ENVIRONMENT:\n", paste0(tempo, collapse = "()\n"))
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- }
- # end required function checking
- # reserved words
- # end reserved words
- # arg with no default values
- mandat.args <- c(
- "fun",
- "arg",
- "val"
- )
- tempo <- eval(parse(text = paste0("missing(", paste0(mandat.args, collapse = ") | missing("), ")")))
- if(any(tempo)){ # normally no NA for missing() output
- tempo.cat <- paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", ifelse(sum(tempo, na.rm = TRUE) > 1, "S HAVE", " HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", paste0(mandat.args[tempo], collapse = "\n"))
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- }
- # end arg with no default values
- # argument primary checking
- arg.check <- NULL #
- text.check <- NULL #
- checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
- ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$object.name))
- tempo <- fun_check(data = fun, class = "vector", mode = "character", length = 1, fun.name = function.name) ; eval(ee)
- tempo <- fun_check(data = arg, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
- tempo <- fun_check(data = val, class = "list", fun.name = function.name) ; eval(ee)
- if( ! is.null(expect.error)){
- tempo <- fun_check(data = expect.error, class = "list", fun.name = function.name) ; eval(ee)
- }
- tempo <- fun_check(data = parall, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
- if(parall == TRUE){
- if( ! is.null(thread.nb)){
- tempo <- fun_check(data = thread.nb, typeof = "integer", double.as.integer.allowed = TRUE, neg.values = FALSE, length = 1, fun.name = function.name) ; eval(ee)
- if(tempo$problem == FALSE & thread.nb < 1){
- tempo.cat <- paste0("ERROR IN ", function.name, ": thread.nb PARAMETER MUST EQUAL OR GREATER THAN 1: ", thread.nb)
- text.check <- c(text.check, tempo.cat)
- arg.check <- c(arg.check, TRUE)
- }
- }
- }
- tempo <- fun_check(data = print.count, class = "vector", typeof = "integer", length = 1, double.as.integer.allowed = TRUE, neg.values = FALSE, fun.name = function.name) ; eval(ee)
- tempo <- fun_check(data = plot.fun, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
- tempo <- fun_check(data = export, class = "vector", mode = "logical", length = 1, fun.name = function.name) ; eval(ee)
- if( ! is.null(res.path)){
- tempo <- fun_check(data = res.path, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
- }
- if( ! is.null(lib.path)){
- tempo <- fun_check(data = lib.path, class = "vector", mode = "character", fun.name = function.name) ; eval(ee)
- }
- tempo <- fun_check(data = cute.path, class = "vector", typeof = "character", length = 1, fun.name = function.name) ; eval(ee)
- if( ! is.null(arg.check)){
- if(any(arg.check) == TRUE){
- stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
- }
- }
- # end using fun_check()
- # source("C:/Users/gmillot/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.7/r_debugging_tools-v1.7.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
- # end argument primary checking
- # second round of checking and data preparation
- # new environment
- env.name <- paste0("env", as.numeric(Sys.time()))
- if(exists(env.name, where = -1)){ # verify if still ok when fun_info() is inside a function
- tempo.cat <- paste0("ERROR IN ", function.name, ": ENVIRONMENT env.name ALREADY EXISTS. PLEASE RERUN ONCE")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- }else{
- assign(env.name, new.env())
- assign("data", data, envir = get(env.name, env = sys.nframe(), inherit = FALSE)) # data assigned in a new envir for test
- }
- # end new environment
- # management of NA arguments
- if( ! (all(class(arg.user.setting) == "list") & length(arg.user.setting) == 0)){
- tempo.arg <- names(arg.user.setting) # values provided by the user
- tempo.log <- suppressWarnings(sapply(lapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = is.na), FUN = any)) & lapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = length) == 1L # no argument provided by the user can be just NA
- if(any(tempo.log) == TRUE){
- tempo.cat <- paste0("ERROR IN ", function.name, "\n", ifelse(sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT JUST BE NA:", paste0(tempo.arg[tempo.log], collapse = "\n"))
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- }
- }
- # end management of NA arguments
- # management of NULL arguments
- tempo.arg <-c(
- "fun",
- "arg",
- "val",
- # "expect.erro", # because can be NULL
- "parall",
- # "thread.nb", # because can be NULL
- "print.count",
- "plot.fun",
- "export",
- # "res.path", # because can be NULL
- # "lib.path", # because can be NULL
- "cute.path"
- )
- tempo.log <- sapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), inherit = FALSE), FUN = is.null)
- if(any(tempo.log) == TRUE){# normally no NA with is.null()
- tempo.cat <- paste0("ERROR IN ", function.name, ":\n", ifelse(sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS\n", "THIS ARGUMENT\n"), paste0(tempo.arg[tempo.log], collapse = "\n"),"\nCANNOT BE NULL")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- }
- # end management of NULL arguments
- # code that protects set.seed() in the global environment
- # end code that protects set.seed() in the global environment
- # warning initiation
- # end warning initiation
- # other checkings
- if(grepl(x = fun, pattern = "()$")){ # remove ()
- fun <- sub(x = fun, pattern = "()$", replacement = "")
- }
- if( ! exists(fun)){
- tempo.cat <- paste0("ERROR IN ", function.name, ": CHARACTER STRING IN fun ARGUMENT DOES NOT EXIST IN THE R WORKING ENVIRONMENT: ", paste(fun, collapse = "\n"))
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }else if( ! all(base::class(get(fun)) == "function")){ # here no env = sys.nframe(), inherit = FALSE for get() because fun is a function in the classical scope
- tempo.cat <- paste0("ERROR IN ", function.name, ": fun ARGUMENT IS NOT CLASS \"function\" BUT: ", paste(base::class(get(fun)), collapse = "\n"), "\nCHECK IF ANY CREATED OBJECT WOULD HAVE THE NAME OF THE TESTED FUNCTION")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }
- if(tempo$problem == FALSE & base::length(arg) == 0L){
- tempo.cat <- paste0("ERROR IN ", function.name, ": arg ARGUMENT CANNOT BE LENGTH 0")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }
- for(i2 in 1:base::length(val)){ # length(val) must be aequal to nb of arguments
- tempo1 <- fun_check(data = val[[i2]], class = "vector", na.contain = TRUE, fun.name = function.name)
- tempo2 <- fun_check(data = val[[i2]], class = "list", na.contain = TRUE, fun.name = function.name)
- if(tempo1$problem == TRUE & tempo2$problem == TRUE){
- tempo.cat <- paste0("ERROR IN ", function.name, ": COMPARTMENT ", i2, " OF val ARGUMENT MUST BE A VECTOR OR A LIST")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }else if(tempo1$problem == FALSE){ # vector split into list compartments
- val[[i2]] <- split(x = val[[i2]], f = 1:base::length(val[[i2]]))
- }
- }
- if(base::length(arg) != base::length(val)){
- tempo.cat <- paste0("ERROR IN ", function.name, ": LENGTH OF arg ARGUMENT MUST BE IDENTICAL TO LENGTH OF val ARGUMENT:\nHERE IT IS: ", base::length(arg), " VERSUS ", base::length(val))
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }
- args <- names(formals(get(fun))) # here no env = sys.nframe(), inherit = FALSE for get() because fun is a function in the classical scope
- if( ! all(arg %in% args)){
- tempo.cat <- paste0("ERROR IN ", function.name, ": SOME OF THE STRINGS IN arg ARE NOT ARGUMENTS OF fun\nfun ARGUMENTS: ", paste(args, collapse = " "),"\nPROBLEMATIC STRINGS IN arg: ", paste(arg[ ! arg %in% args], collapse = " "))
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }
- if(sum(sapply(val, FUN = length) > 1) > 43){
- tempo.cat <- paste0("ERROR IN ", function.name, ": CANNOT TEST MORE THAN 43 ARGUMENTS IF THEY ALL HAVE AT LEAST 2 VALUES EACH\nHERE THE NUMBER IS: ", sum(sapply(val, FUN = length) > 1))
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }
- if( ! is.null(expect.error)){
- if(base::length(val) != base::length(expect.error)){
- tempo.cat <- paste0("ERROR IN ", function.name, ": LENGTH OF val ARGUMENT MUST BE IDENTICAL TO LENGTH OF expect.error ARGUMENT:\nHERE IT IS: ", base::length(val), " VERSUS ", base::length(expect.error))
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }
- for(i3 in 1:base::length(expect.error)){
- tempo1 <- fun_check(data = expect.error[[i3]], class = "vector", mode = "logical", fun.name = function.name)
- tempo2 <- fun_check(data = expect.error[[i3]], class = "list", fun.name = function.name)
- if(tempo1$problem == TRUE & tempo2$problem == TRUE){
- tempo.cat <- paste0("ERROR IN ", function.name, ": COMPARTMENT ", i3, " OF expect.error ARGUMENT MUST BE TRUE OR FALSE")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }else if(tempo1$problem == FALSE){ # vector split into list compartments
- expect.error[[i3]] <- split(x = expect.error[[i3]], f = 1:base::length(expect.error[[i3]]))
- }
- }
- }
- if( ! is.null(res.path)){
- if( ! all(dir.exists(res.path))){ # separation to avoid the problem of tempo$problem == FALSE and res.path == NA
- tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE res.path ARGUMENT DOES NOT EXISTS:\n", paste(res.path, collapse = "\n"))
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }
- }
- if(parall == TRUE & is.null(res.path)){
- tempo.cat <- paste0("ERROR IN ", function.name, ": res.path ARGUMENT MUST BE SPECIFIED IF parall ARGUMENT IS TRUE")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }
- if(is.null(res.path) & export == TRUE){
- tempo.cat <- paste0("ERROR IN ", function.name, ": res.path ARGUMENT MUST BE SPECIFIED IF export ARGUMENT TRUE")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }
- if(parall == TRUE & export == FALSE){
- export <- TRUE
- tempo.cat <- paste0("WARNING FROM ", function.name, ": export ARGUMENT CONVERTED TO TRUE BECAUSE thread.nb ARGUMENT IS NOT NULL")
- warning(paste0("\n", tempo.cat, "\n"), call. = FALSE)
- }
- if( ! is.null(lib.path)){
- if( ! all(dir.exists(lib.path))){ # separation to avoid the problem of tempo$problem == FALSE and lib.path == NA
- tempo.cat <- paste0("ERROR IN ", function.name, ": DIRECTORY PATH INDICATED IN THE lib.path ARGUMENT DOES NOT EXISTS:\n", paste(lib.path, collapse = "\n"))
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }
- }
- if(parall == TRUE){
- if(grepl(x = cute.path, pattern = "^http")){
- tempo.error1 <- any(grepl(x = fun_get_message(data = "source(cute.path)", kind = "error", header = FALSE, env = get(env.name, env = sys.nframe(), inherit = FALSE)), pattern = "^[Ee]rror"))
- tempo.error2 <- FALSE
- }else{
- tempo.error1 <- FALSE
- tempo.error2 <- ! file.exists(cute.path)
- }
- if(tempo.error1 | tempo.error2){
- tempo.cat <- paste0("ERROR IN ", function.name, ": ", ifelse(grepl(x = cute.path, pattern = "^http"), "URL", "FILE"), " PATH INDICATED IN THE cute.path PARAMETER DOES NOT EXISTS:\n", cute.path)
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE)
- }
- }
- # end other checkings
- # reserved word checking
- # end reserved word checking
- # end second round of checking and data preparation
- # package checking
- fun_pack(req.package = c("lubridate"), lib.path = lib.path)
- if(parall == TRUE){
- fun_pack(req.package = c("parallel", "pdftools"), lib.path = lib.path)
- }
- # end package checking
- # declaration of special plot functions
- sp.plot.fun <- c("fun_gg_scatter", "fun_gg_bar", "fun_gg_boxplot")
- # end declaration of special plot functions
- # main code
- ini.warning.length <- base::options()$warning.length
- options(warning.length = 8170)
- warn <- NULL
- warn.count <- 0
- cat("\nfun_test JOB IGNITION\n")
- ini.date <- Sys.time()
- ini.time <- as.numeric(ini.date) # time of process begin, converted into seconds
- if(export == TRUE){
- res.path <- paste0(res.path, "/fun_test_res_", trunc(ini.time))
- if(dir.exists(res.path)){
- tempo.cat <- paste0("ERROR IN ", function.name, ": FOLDER ALREADY EXISTS\n", res.path, "\nPLEASE RERUN ONCE")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- }else{
- dir.create(res.path)
- }
- }
- total.comp.nb <- prod(sapply(val, FUN = "length"))
- cat(paste0("\nTHE TOTAL NUMBER OF TESTS IS: ", total.comp.nb, "\n"))
- # creation of the txt instruction that includes several loops
- loop.string <- NULL
- end.loop.string <- NULL
- fun.args <- NULL
- fun.args2 <- NULL
- error.values <- NULL
- arg.values <- "list("
- for(i1 in 1:base::length(arg)){
- if(parall == FALSE){
- if(base::length(val[[i1]]) > 1){ # loop only if more than one value in base::length(val[[i1]])
- loop.string <- paste0(loop.string, "for(i", i1, " in 1:", base::length(val[[i1]]), "){")
- end.loop.string <- paste0(end.loop.string, "}")
- }
- }else{
- loop.string <- "for(i in x){"
- end.loop.string <- "}"
- }
- fun.args <- paste0(
- fun.args,
- ifelse(i1 == 1L, "", ", "),
- arg[i1],
- " = val[[",
- i1,
- "]][[",
- if(parall == FALSE){
- if(base::length(val[[i1]]) > 1){
- paste0("i", i1)
- }else{
- "1" # a unique element in val[[i1]]
- }
- }else{
- paste0("i.list[[", i1, "]][i]")
- },
- "]]"
- )
- fun.args2 <- paste0(
- fun.args2,
- ifelse(i1 == 1L, "", ", "),
- arg[i1],
- " = val[[",
- i1,
- "]][[', ",
- if(parall == FALSE){
- if(base::length(val[[i1]]) > 1){
- paste0("i", i1)
- }else{
- "1" # a unique element in val[[i1]]
- }
- }else{
- paste0("i.list[[", i1, "]][i]")
- },
- ", ']]"
- )
- arg.values <- paste0(
- arg.values,
- "val[[", i1, "]][[",
- if(parall == FALSE){
- if(base::length(val[[i1]]) > 1){
- paste0("i", i1)
- }else{
- "1" # a unique element in val[[i1]]
- }
- }else{
- paste0("i.list[[", i1, "]][i]")
- },
- "]]",
- ifelse(i1 == base::length(arg), "", ", ")
- )
- error.values <- paste0(
- error.values,
- ifelse(i1 == 1L, "", " | "),
- "expect.error[[", i1, "]][[",
- if(parall == FALSE){
- if(base::length(expect.error[[i1]]) > 1){
- paste0("i", i1)
- }else{
- "1" # a unique element in expect.error[[i1]]
- }
- }else{
- paste0("i.list[[", i1, "]][i]")
- },
- "]]"
- )
- }
- arg.values <- paste0(arg.values, ")")
- fun.test <- paste0(fun, "(", fun.args, ")")
- fun.test2 <- paste0("paste0('", fun, "(", fun.args2, ")')")
- # plot title for special plot functions
- if(plot.fun == TRUE){
- plot.kind <- "classic"
- if(fun %in% sp.plot.fun){
- plot.kind <- "special"
- if(any(arg %in% "title")){ # this is for the special functions
- tempo.match <- regmatches(x = fun.test, m = regexpr(text = fun.test, pattern = "title = .+[,)]"))
- tempo.match <- substring(tempo.match , 1, nchar(tempo.match) - 1)
- fun.test <- sub(x = fun.test, pattern = tempo.match, replacement = paste0(tempo.match, "\ntempo.title"))
- }else{
- fun.test <- sub(x = fun.test, pattern = ")$", replacement = ", title = tempo.title)")
- }
- }
- }
- # end plot title for special plot functions
- kind <- character()
- problem <- logical()
- expected.error <- logical()
- res <- character()
- count <- 0
- print.count.loop <- 0
- plot.count <- 0
- if(base::length(arg) == 1L){
- data <- data.frame()
- }else{ # base::length(arg) == 0L already tested above
- data <- data.frame(t(vector("character", base::length(arg))), stringsAsFactors = FALSE)[-1, ] # -1 to remove the single row created and to have an empty data frame with base::length(arg) columns
- }
- code <- paste(
- loop.string, '
-count <- count + 1
-print.count.loop <- print.count.loop + 1
-arg.values.print <- eval(parse(text = arg.values)) # recover the list of the i1 compartment
-for(j3 in 1:base::length(arg.values.print)){ # WARNING: do not use i1, i2 etc., here because already in loop.string
-tempo.capt <- capture.output(tempo.error <- fun_get_message(data = paste0("paste(arg.values.print[[", j3, "]])"), kind = "error", header = FALSE, print.no = FALSE, env = get(env.name, env = sys.nframe(), inherit = FALSE))) # collapsing arg.values sometimes does not work (with function for instance)
-if( ! is.null(tempo.error)){
-arg.values.print[[j3]] <- paste0("SPECIAL VALUE OF CLASS ", base::class(arg.values.print[[j3]]), " AND TYPE ", base::typeof(arg.values.print[[j3]]))
-}
-}
-data <- rbind(data, as.character(sapply(arg.values.print, FUN = "paste", collapse = " ")), stringsAsFactors = FALSE) # each colum is a test
-tempo.capt <- capture.output(tempo.try.error <- fun_get_message(data = eval(parse(text = fun.test2)), kind = "error", header = FALSE, print.no = FALSE, env = get(env.name, env = sys.nframe(), inherit = FALSE))) # data argument needs a character string but eval(parse(text = fun.test2)) provides it (eval parse replace the i1, i2, etc., by the correct values, meaning that only val is required in the env.name environment)
-tempo.capt <- capture.output(tempo.try.warning <- fun_get_message(data = eval(parse(text = fun.test2)), kind = "warning", header = FALSE, env = get(env.name, env = sys.nframe(), inherit = FALSE), print.no = FALSE)) # data argument needs a character string but eval(parse(text = fun.test2)) provides it (eval parse replace the i1, i2, etc., by the correct values, meaning that only val is required in the env.name environment)
-if( ! is.null(expect.error)){
-expected.error <- c(expected.error, eval(parse(text = error.values)))
-}
-if( ! is.null(tempo.try.error)){
-kind <- c(kind, "ERROR")
-problem <- c(problem, TRUE)
-res <- c(res, tempo.try.error)
-}else{
-if( ! is.null(tempo.try.warning)){
-kind <- c(kind, "WARNING")
-problem <- c(problem, FALSE)
-res <- c(res, tempo.try.warning)
-}else{
-kind <- c(kind, "OK")
-problem <- c(problem, FALSE)
-res <- c(res, "")
-}
-if(plot.fun == TRUE){
-invisible(dev.set(window.nb))
-plot.count <- plot.count + 1
-tempo.title <- paste0("test_", sprintf(paste0("%0", nchar(total.comp.nb), "d"), ifelse(parall == FALSE, count, x[count])))
-if(plot.kind == "classic"){
-eval(parse(text = fun.test))
-tempo <- fun_post_plot(corner.text = tempo.title)
-}else if(plot.kind == "special"){
-eval(parse(text = fun.test))
-}else{
-tempo.cat <- paste0("INTERNAL CODE ERROR 1 IN ", function.name, ": CODE HAS TO BE MODIFIED")
-stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
-}
-}
-}
-if(print.count.loop == print.count){
-print.count.loop <- 0
-tempo.time <- as.numeric(Sys.time())
-tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - ini.time))
-final.loop <- (tempo.time - ini.time) / count * ifelse(parall == FALSE, total.comp.nb, base::length(x)) # expected duration in seconds # intra nb.compar loop lapse: time lapse / cycles done * cycles remaining
-final.exp <- as.POSIXct(final.loop, origin = ini.date)
-cat(paste0(ifelse(parall == FALSE, "\n", paste0("\nIN PROCESS ", process.id, " | ")), "LOOP ", format(count, big.mark=","), " / ", format(ifelse(parall == FALSE, total.comp.nb, base::length(x)), big.mark=","), " | TIME SPENT: ", tempo.lapse, " | EXPECTED END: ", final.exp))
-}
-if(count == ifelse(parall == FALSE, total.comp.nb, base::length(x))){
-tempo.time <- as.numeric(Sys.time())
-tempo.lapse <- round(lubridate::seconds_to_period(tempo.time - ini.time))
-cat(paste0(ifelse(parall == FALSE, "\nLOOP PROCESS ENDED | ", paste0("\nPROCESS ", process.id, " ENDED | ")), "LOOP ", format(count, big.mark=","), " / ", format(ifelse(parall == FALSE, total.comp.nb, base::length(x)), big.mark=","), " | TIME SPENT: ", tempo.lapse, "\n\n"))
-}
-',
-end.loop.string
- )
- # end creation of the txt instruction that includes several loops
- if(parall == TRUE){
- # list of i numbers that will be split
- i.list <- vector("list", base::length(val)) # positions to split in parallel jobs
- for(i2 in 1:base::length(arg)){
- if(i2 == 1L){
- tempo.divisor <- total.comp.nb / base::length(val[[i2]])
- i.list[[i2]] <- rep(1:base::length(val[[i2]]), each = as.integer(tempo.divisor))
- tempo.multi <- base::length(val[[i2]])
- }else{
- tempo.divisor <- tempo.divisor / base::length(val[[i2]])
- i.list[[i2]] <- rep(rep(1:base::length(val[[i2]]), each = as.integer(tempo.divisor)), time = as.integer(tempo.multi))
- tempo.multi <- tempo.multi * base::length(val[[i2]])
- }
- }
- # end list of i numbers that will be split
- tempo.cat <- paste0("PARALLELIZATION INITIATED AT: ", ini.date)
- cat(paste0("\n", tempo.cat, "\n"))
- tempo.thread.nb = parallel::detectCores(all.tests = FALSE, logical = TRUE) # detect the number of threads
- if(tempo.thread.nb < thread.nb){
- thread.nb <- tempo.thread.nb
- }
- tempo.cat <- paste0("NUMBER OF THREADS USED: ", thread.nb)
- cat(paste0("\n ", tempo.cat, "\n"))
- Clust <- parallel::makeCluster(thread.nb, outfile = paste0(res.path, "/fun_test_parall_log.txt")) # outfile to print or cat during parallelization (only possible in a file, outfile = "" do not work on windows)
- tempo.cat <- paste0("SPLIT OF TEST NUMBERS IN PARALLELISATION:")
- cat(paste0("\n ", tempo.cat, "\n"))
- cluster.list <- parallel::clusterSplit(Clust, 1:total.comp.nb) # split according to the number of cluster
- str(cluster.list) # using print(str()) add a NULL below the result
- cat("\n")
- paral.output.list <- parallel::clusterApply( # paral.output.list is a list made of thread.nb compartments, each made of n / thread.nb (mat theo column number) compartment. Each compartment receive the corresponding results of fun_permut(), i.e., data (permuted mat1.perm), warning message, cor (final correlation) and count (number of permutations)
- cl = Clust,
- x = cluster.list,
- function.name = function.name,
- ini = ini,
- thread.nb = thread.nb,
- print.count = print.count,
- total.comp.nb = total.comp.nb,
- sp.plot.fun = sp.plot.fun,
- i.list = i.list,
- fun.tested = fun,
- arg.values = arg.values,
- fun.test = fun.test,
- fun.test2 = fun.test2,
- kind = kind,
- problem = problem,
- res = res,
- count = count,
- plot.count = plot.count,
- data = data,
- code = code,
- plot.fun = plot.fun,
- res.path = res.path,
- lib.path = lib.path,
- cute.path = cute.path,
- fun = function(
- x,
- function.name,
- ini,
- thread.nb,
- print.count,
- total.comp.nb,
- sp.plot.fun,
- i.list,
- fun.tested,
- arg.values,
- fun.test,
- fun.test2,
- kind,
- problem,
- res,
- count,
- plot.count,
- data,
- code,
- plot.fun,
- res.path,
- lib.path,
- cute.path
- ){
- # check again: very important because another R
- process.id <- Sys.getpid()
- cat(paste0("\nPROCESS ID ", process.id, " -> TESTS ", x[1], " TO ", x[base::length(x)], "\n"))
- source(cute.path, local = .GlobalEnv)
- fun_pack(req.package = "lubridate", lib.path = lib.path, load = TRUE) # load = TRUE to be sure that functions are present in the environment. And this prevent to use R.lib.path argument of fun_python_pack()
- # end check again: very important because another R
- # plot management
- if(plot.fun == TRUE){
- pdf(file = paste0(res.path, "/plots_from_fun_test_", x[1], ifelse(base::length(x) == 1L, ".pdf", paste0("-", x[base::length(x)], ".pdf"))))
- }else{
- pdf(file = NULL) # send plots into a NULL file, no pdf file created
- }
- window.nb <- dev.cur()
- invisible(dev.set(window.nb))
- # end plot management
- # new environment
- ini.date <- Sys.time()
- ini.time <- as.numeric(ini.date) # time of process begin, converted into
- env.name <- paste0("env", ini.time)
- if(exists(env.name, where = -1)){ # verify if still ok when fun_test() is inside a function
- tempo.cat <- paste0("ERROR IN ", function.name, ": ENVIRONMENT env.name ALREADY EXISTS. PLEASE RERUN ONCE")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- }else{
- assign(env.name, new.env())
- assign("val", val, envir = get(env.name, env = sys.nframe(), inherit = FALSE)) # var replaced by val
- }
- # end new environment
- print.count.loop <- 0
- suppressMessages(suppressWarnings(eval(parse(text = code))))
- colnames(data) <- arg
- if( ! is.null(expect.error)){
- data <- data.frame(data, kind = kind, problem = problem, expected.error = expected.error, message = res, stringsAsFactors = FALSE)
- }else{
- data <- data.frame(data, kind = kind, problem = problem, message = res, stringsAsFactors = FALSE)
- }
- row.names(data) <- paste0("test_", sprintf(paste0("%0", nchar(total.comp.nb), "d"), x))
- sys.info <- sessionInfo()
- sys.info$loadedOnly <- sys.info$loadedOnly[order(names(sys.info$loadedOnly))] # sort the packages
- invisible(dev.off(window.nb))
- rm(env.name) # optional, because should disappear at the end of the function execution
- # output
- output <- list(fun = fun, ini = ini, data = data, sys.info = sys.info)
- save(output, file = paste0(res.path, "/fun_test_", x[1], ifelse(base::length(x) == 1L, ".RData", paste0("-", x[base::length(x)], ".RData"))))
- if(plot.fun == TRUE & plot.count == 0L){
- warn.count <- warn.count + 1
- tempo.warn <- paste0("(", warn.count,") IN PROCESS ", process.id, ": NO PDF PLOT BECAUSE ONLY ERRORS REPORTED")
- warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
- file.remove(paste0(res.path, "/plots_from_fun_test_", x[1], ifelse(base::length(x) == 1L, ".pdf", paste0("-", x[base::length(x)], ".pdf"))))
- }
- table.out <- as.matrix(data)
- # table.out[table.out == ""] <- " " # does not work # because otherwise read.table() converts "" into NA
- table.out <- gsub(table.out, pattern = "\n", replacement = " ")
- write.table(table.out, file = paste0(res.path, "/table_from_fun_test_", x[1], ifelse(base::length(x) == 1L, ".tsv", paste0("-", x[base::length(x)], ".tsv"))), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n", na = "")
- }
- )
- parallel::stopCluster(Clust)
- # files assembly
- if(base::length(cluster.list) > 1){
- for(i2 in 1:base::length(cluster.list)){
- tempo.file <- paste0(res.path, "/table_from_fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".tsv", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".tsv"))) # txt file
- tempo <- read.table(file = tempo.file, header = TRUE, stringsAsFactors = FALSE, sep = "\t", row.names = 1, comment.char = "", colClasses = "character") # row.names = 1 (1st column) because now read.table() adds a NA in the header if the header starts by a tabulation, comment.char = "" because colors with #, colClasses = "character" otherwise convert "" (from NULL) into NA
- if(file.exists(paste0(res.path, "/plots_from_fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".pdf", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".pdf"))))){
- tempo.pdf <- paste0(res.path, "/plots_from_fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".pdf", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".pdf"))) # pdf file
- }else{
- tempo.pdf <- NULL
- }
- tempo.rdata <- paste0(res.path, "/fun_test_", min(cluster.list[[i2]], na.rm = TRUE), ifelse(base::length(cluster.list[[i2]]) == 1L, ".RData", paste0("-", max(cluster.list[[i2]], na.rm = TRUE), ".RData"))) # RData file
- if(i2 == 1L){
- final.file <- tempo
- final.pdf <- tempo.pdf
- # new env for RData combining
- env.name <- paste0("env", ini.time)
- if(exists(env.name, where = -1)){ # verify if still ok when fun_test() is inside a function
- tempo.cat <- paste0("ERROR IN ", function.name, ": ENVIRONMENT env.name ALREADY EXISTS. PLEASE RERUN ONCE")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- # end new env for RData combining
- }else{
- assign(env.name, new.env())
- load(tempo.rdata, envir = get(env.name))
- tempo.rdata1 <- tempo.rdata
- assign("final.output", get("output", envir = get(env.name)), envir = get(env.name))
- }
- }else{
- final.file <- rbind(final.file, tempo, stringsAsFactors = TRUE)
- final.pdf <- c(final.pdf, tempo.pdf)
- load(tempo.rdata, envir = get(env.name))
- if( ! identical(get("final.output", envir = get(env.name))[c("R.version", "locale", "platform")], get("output", envir = get(env.name))[c("R.version", "locale", "platform")])){
- tempo.cat <- paste0("ERROR IN ", function.name, ": DIFFERENCE BETWEEN OUTPUTS WHILE THEY SHOULD BE IDENTICAL\nPLEASE CHECK\n", tempo.rdata1, "\n", tempo.rdata)
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- }else{
- # add the differences in RData $sysinfo into final.output
- tempo.base1 <- sort(get("final.output", envir = get(env.name))$sys.info$basePkgs)
- tempo.base2 <- sort(get("output", envir = get(env.name))$sys.info$basePkgs)
- tempo.other1 <- names(get("final.output", envir = get(env.name))$sys.info$otherPkgs)
- tempo.other2 <- names(get("output", envir = get(env.name))$sys.info$otherPkgs)
- tempo.loaded1 <- names(get("final.output", envir = get(env.name))$sys.info$loadedOnly)
- tempo.loaded2 <- names(get("output", envir = get(env.name))$sys.info$loadedOnly)
- assign("final.output", {
- x <- get("final.output", envir = get(env.name))
- y <- get("output", envir = get(env.name))
- x$sys.info$basePkgs <- sort(unique(tempo.base1, tempo.base2))
- if( ! all(tempo.other2 %in% tempo.other1)){
- x$sys.info$otherPkgs <- c(x$sys.info$otherPkgs, y$sys.info$otherPkgs[ ! (tempo.other2 %in% tempo.other1)])
- x$sys.info$otherPkgs <- x$sys.info$otherPkgs[order(names(x$sys.info$otherPkgs))]
- }
- if( ! all(tempo.loaded2 %in% tempo.loaded1)){
- x$sys.info$loadedOnly <- c(x$sys.info$loadedOnly, y$sys.info$loadedOnly[ ! (tempo.loaded2 %in% tempo.loaded1)])
- x$sys.info$loadedOnly <- x$sys.info$loadedOnly[order(names(x$sys.info$loadedOnly))]
- }
- x
- }, envir = get(env.name))
- # add the differences in RData $sysinfo into final.output
- }
- }
- file.remove(c(tempo.file, tempo.rdata))
- }
- # combine pdf and save
- if( ! is.null(final.pdf)){
- pdftools::pdf_combine(
- input = final.pdf,
- output = paste0(res.path, "/plots_from_fun_test_1-", total.comp.nb, ".pdf")
- )
- file.remove(final.pdf)
- }
- # end combine pdf and save
- # save RData
- assign("output", c(get("final.output", envir = get(env.name)), data = list(final.file)), envir = get(env.name))
- save(output, file = paste0(res.path, "/fun_test__1-", total.comp.nb, ".RData"), envir = get(env.name))
- rm(env.name) # optional, because should disappear at the end of the function execution
- # end save RData
- # save txt
- write.table(final.file, file = paste0(res.path, "/table_from_fun_test_1-", total.comp.nb, ".tsv"), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n", na = "")
- # end save txt
- if( ! is.null(expect.error)){
- final.file <- final.file[ ! final.file$problem == final.file$expected.error, ]
- if(nrow(final.file) == 0L){
- cat(paste0("NO DISCREPANCY BETWEEN EXPECTED AND OBSERVED ERRORS\n\n"))
- }else{
- cat(paste0("DISCREPANCIES BETWEEN EXPECTED AND OBSERVED ERRORS (SEE THE discrepancy_table_from_fun_test_1-", total.comp.nb, ".tsv FILE)\n\n"))
- write.table(final.file, file = paste0(res.path, "/discrepancy_table_from_fun_test_1-", total.comp.nb, ".tsv"), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n", na = "")
- }
- }
- }
- # end files assembly
- }else{
- # plot management
- if(plot.fun == TRUE){
- pdf(file = paste0(res.path, "/plots_from_fun_test_1", ifelse(total.comp.nb == 1L, ".pdf", paste0("-", total.comp.nb, ".pdf"))))
- }else{
- pdf(file = NULL) # send plots into a NULL file, no pdf file created
- }
- window.nb <- dev.cur()
- invisible(dev.set(window.nb))
- # end plot management
- # new environment
- env.name <- paste0("env", ini.time)
- if(exists(env.name, where = -1)){
- tempo.cat <- paste0("ERROR IN ", function.name, ": ENVIRONMENT env.name ALREADY EXISTS. PLEASE RERUN ONCE")
- stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between ==
- }else{
- assign(env.name, new.env())
- assign("val", val, envir = get(env.name, env = sys.nframe(), inherit = FALSE)) # var replaced by val
- }
- # end new environment
- suppressMessages(suppressWarnings(eval(parse(text = code))))
- colnames(data) <- arg
- expect.data <- data.frame()
- if( ! is.null(expect.error)){
- data <- data.frame(data, kind = kind, problem = problem, expected.error = expected.error, message = res, stringsAsFactors = FALSE)
- }else{
- data <- data.frame(data, kind = kind, problem = problem, message = res, stringsAsFactors = FALSE)
- }
- row.names(data) <- paste0("test_", sprintf(paste0("%0", nchar(total.comp.nb), "d"), 1:total.comp.nb))
- sys.info <- sessionInfo()
- sys.info$loadedOnly <- sys.info$loadedOnly[order(names(sys.info$loadedOnly))] # sort the packages
- invisible(dev.off(window.nb))
- rm(env.name) # optional, because should disappear at the end of the function execution
- # output
- output <- list(fun = fun, ini = ini, data = data, sys.info = sys.info)
- if(plot.fun == TRUE & plot.count == 0L){
- warn.count <- warn.count + 1
- tempo.warn <- paste0("(", warn.count,") NO PDF PLOT BECAUSE ONLY ERRORS REPORTED")
- warn <- paste0(ifelse(is.null(warn), tempo.warn, paste0(warn, "\n\n", tempo.warn)))
- file.remove(paste0(res.path, "/plots_from_fun_test_1", ifelse(total.comp.nb == 1L, ".pdf", paste0("-", total.comp.nb, ".pdf"))))
- }
- if( ! is.null(expect.error)){
- expect.data <- output$data[ ! output$data$problem == output$data$expected.error, ]
- if(nrow(expect.data) == 0L){
- cat(paste0("NO DISCREPANCY BETWEEN EXPECTED AND OBSERVED ERRORS\n\n"))
- }else{
- cat(paste0("DISCREPANCIES BETWEEN EXPECTED AND OBSERVED ERRORS (SEE THE ", if(export == TRUE){paste0("discrepancy_table_from_fun_test_1", ifelse(total.comp.nb == 1L, "", paste0("-", total.comp.nb)), ".tsv FILE")}else{"$data RESULT"}, ")\n\n"))
- if(export == TRUE){
- expect.data <- as.matrix(expect.data)
- expect.data <- gsub(expect.data, pattern = "\n", replacement = " ")
- write.table(expect.data, file = paste0(res.path, "/discrepancy_table_from_fun_test_1", ifelse(total.comp.nb == 1L, ".tsv", paste0("-", total.comp.nb, ".tsv"))), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n", na = "")
- }
- }
- }
- if( ! is.null(warn)){
- base::options(warning.length = 8170)
- on.exit(warning(paste0("FROM ", function.name, ":\n\n", warn), call. = FALSE))
- }
- on.exit(exp = base::options(warning.length = ini.warning.length), add = TRUE)
- if(export == TRUE){
- save(output, file = paste0(res.path, "/fun_test_1", ifelse(total.comp.nb == 1L, ".RData", paste0("-", total.comp.nb, ".RData"))))
- table.out <- as.matrix(output$data)
- table.out <- gsub(table.out, pattern = "\n", replacement = " ")
- write.table(table.out, file = paste0(res.path, "/table_from_fun_test_1", ifelse(total.comp.nb == 1L, ".tsv", paste0("-", total.comp.nb, ".tsv"))), row.names = TRUE, col.names = NA, append = FALSE, quote = FALSE, sep = "\t", eol = "\n", na = "")
- }else{
- return(output)
- }
- }
- # after return() ?
- end.date <- Sys.time()
- end.time <- as.numeric(end.date)
- total.lapse <- round(lubridate::seconds_to_period(end.time - ini.time))
- cat(paste0("fun_test JOB END\n\nTIME: ", end.date, "\n\nTOTAL TIME LAPSE: ", total.lapse, "\n\n\n"))
-}