diff --git a/.Rbuildignore b/.Rbuildignore new file mode 100644 index 0000000000000000000000000000000000000000..13e458ca9f1c3010bb141b225afc602884bdde93 --- /dev/null +++ b/.Rbuildignore @@ -0,0 +1,2 @@ +^.*\.Rproj$ +^\.Rproj\.user$ diff --git a/.Rhistory b/.Rhistory new file mode 100644 index 0000000000000000000000000000000000000000..76c521e34de9877a71069387b040104e27a20de2 --- /dev/null +++ b/.Rhistory @@ -0,0 +1,23 @@ +library(roxygen2) +roxygenise() +library(roxygen2) +roxygenise() +?check +?cute +library(cute) +install.packages(cute) +library(roxygen2) +library(cute) +?cute +??cute +install.packages(cute) +install.packages(cute) +install.packages("cute") +?cute +??cute +install.packages("cute") +?fun_check +library(devtools) +library(usethis) +library(devtools) +load_all(".") diff --git a/.Rproj.user/667C8368/cpp-definition-cache b/.Rproj.user/667C8368/cpp-definition-cache new file mode 100644 index 0000000000000000000000000000000000000000..0637a088a01e8ddab3bf3fa98dbe804cbde1a0dc --- /dev/null +++ b/.Rproj.user/667C8368/cpp-definition-cache @@ -0,0 +1 @@ +[] \ No newline at end of file diff --git a/.Rproj.user/667C8368/pcs/debug-breakpoints.pper b/.Rproj.user/667C8368/pcs/debug-breakpoints.pper new file mode 100644 index 0000000000000000000000000000000000000000..4893a8a7c977f8819a9ea9bff0ed5b7b2deca480 --- /dev/null +++ b/.Rproj.user/667C8368/pcs/debug-breakpoints.pper @@ -0,0 +1,5 @@ +{ + "debugBreakpointsState": { + "breakpoints": [] + } +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/pcs/files-pane.pper b/.Rproj.user/667C8368/pcs/files-pane.pper new file mode 100644 index 0000000000000000000000000000000000000000..7e8f5a56e5dcb04e1557a14269cac7cf8e401954 --- /dev/null +++ b/.Rproj.user/667C8368/pcs/files-pane.pper @@ -0,0 +1,9 @@ +{ + "sortOrder": [ + { + "columnIndex": 2, + "ascending": true + } + ], + "path": "~/cute" +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/pcs/source-pane.pper b/.Rproj.user/667C8368/pcs/source-pane.pper new file mode 100644 index 0000000000000000000000000000000000000000..ddca97d7a81cee67a5bfdbf3a928062dc82d1df9 --- /dev/null +++ b/.Rproj.user/667C8368/pcs/source-pane.pper @@ -0,0 +1,3 @@ +{ + "activeTab": 2 +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/pcs/windowlayoutstate.pper b/.Rproj.user/667C8368/pcs/windowlayoutstate.pper new file mode 100644 index 0000000000000000000000000000000000000000..da4a73e5081506a0057aea6405b9754af1f8954a --- /dev/null +++ b/.Rproj.user/667C8368/pcs/windowlayoutstate.pper @@ -0,0 +1,14 @@ +{ + "left": { + "splitterpos": 338, + "topwindowstate": "NORMAL", + "panelheight": 809, + "windowheight": 847 + }, + "right": { + "splitterpos": 508, + "topwindowstate": "NORMAL", + "panelheight": 809, + "windowheight": 847 + } +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/pcs/workbench-pane.pper b/.Rproj.user/667C8368/pcs/workbench-pane.pper new file mode 100644 index 0000000000000000000000000000000000000000..ab5e9509c3c88740118596738fc0c659f9afd95a --- /dev/null +++ b/.Rproj.user/667C8368/pcs/workbench-pane.pper @@ -0,0 +1,5 @@ +{ + "TabSet1": 3, + "TabSet2": 0, + "TabZoom": {} +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/rmd-outputs b/.Rproj.user/667C8368/rmd-outputs new file mode 100644 index 0000000000000000000000000000000000000000..3f2ff2d6cc8f257ffcade7ead1ca4042c0e884b9 --- /dev/null +++ b/.Rproj.user/667C8368/rmd-outputs @@ -0,0 +1,5 @@ + + + + + diff --git a/.Rproj.user/667C8368/saved_source_markers b/.Rproj.user/667C8368/saved_source_markers new file mode 100644 index 0000000000000000000000000000000000000000..2b1bef112ac6921abda6162a65dbfcd8c6d55c80 --- /dev/null +++ b/.Rproj.user/667C8368/saved_source_markers @@ -0,0 +1 @@ +{"active_set":"","sets":[]} \ No newline at end of file diff --git a/.Rproj.user/667C8368/sources/prop/0ED03E8D b/.Rproj.user/667C8368/sources/prop/0ED03E8D new file mode 100644 index 0000000000000000000000000000000000000000..d8c1b623a40023e382cb8e4814e4bec9ada5c373 --- /dev/null +++ b/.Rproj.user/667C8368/sources/prop/0ED03E8D @@ -0,0 +1,7 @@ +{ + "tempName": "Untitled1", + "source_window_id": "", + "Source": "Source", + "cursorPosition": "0,0", + "scrollLine": "38" +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/sources/prop/53387873 b/.Rproj.user/667C8368/sources/prop/53387873 new file mode 100644 index 0000000000000000000000000000000000000000..146c69935e4bbc9b25b2db5498a97d701d84fc9f --- /dev/null +++ b/.Rproj.user/667C8368/sources/prop/53387873 @@ -0,0 +1,6 @@ +{ + "source_window_id": "", + "Source": "Source", + "cursorPosition": "8,34", + "scrollLine": "0" +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/sources/prop/572201D2 b/.Rproj.user/667C8368/sources/prop/572201D2 new file mode 100644 index 0000000000000000000000000000000000000000..62bedca53a4eb16006773dcce0319f9c92064f6d --- /dev/null +++ b/.Rproj.user/667C8368/sources/prop/572201D2 @@ -0,0 +1,6 @@ +{ + "source_window_id": "", + "Source": "Source", + "cursorPosition": "3,0", + "scrollLine": "0" +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/sources/prop/803A4700 b/.Rproj.user/667C8368/sources/prop/803A4700 new file mode 100644 index 0000000000000000000000000000000000000000..bb276909ee70e4175f228787abe8a4a2df0886d8 --- /dev/null +++ b/.Rproj.user/667C8368/sources/prop/803A4700 @@ -0,0 +1,4 @@ +{ + "source_window_id": "", + "Source": "Source" +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/sources/prop/870E03F3 b/.Rproj.user/667C8368/sources/prop/870E03F3 new file mode 100644 index 0000000000000000000000000000000000000000..9e26dfeeb6e641a33dae4961196235bdb965b21b --- /dev/null +++ b/.Rproj.user/667C8368/sources/prop/870E03F3 @@ -0,0 +1 @@ +{} \ No newline at end of file diff --git a/.Rproj.user/667C8368/sources/prop/8C329874 b/.Rproj.user/667C8368/sources/prop/8C329874 new file mode 100644 index 0000000000000000000000000000000000000000..6094363d927734316bedd36d26658da30b61bcac --- /dev/null +++ b/.Rproj.user/667C8368/sources/prop/8C329874 @@ -0,0 +1,6 @@ +{ + "source_window_id": "", + "Source": "Source", + "cursorPosition": "475,1", + "scrollLine": "0" +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/sources/prop/INDEX b/.Rproj.user/667C8368/sources/prop/INDEX new file mode 100644 index 0000000000000000000000000000000000000000..57faf3b6304d8b4979af15f48e78f1bb6e0327c9 --- /dev/null +++ b/.Rproj.user/667C8368/sources/prop/INDEX @@ -0,0 +1,6 @@ +C%3A%2FUsers%2Fyhan%2FDocuments%2Fcute%2FNAMESPACE="870E03F3" +~%2Fcute%2FDESCRIPTION="53387873" +~%2Fcute%2FNAMESPACE="572201D2" +~%2Fcute%2FR%2Fcheck.R="8C329874" +~%2Fcute%2Fman%2Fcheck.Rd="0ED03E8D" +~%2Fcute%2Fman%2Ffun_check.Rd="803A4700" diff --git a/.Rproj.user/667C8368/sources/session-ea6e98c5/370BE8B6 b/.Rproj.user/667C8368/sources/session-ea6e98c5/370BE8B6 new file mode 100644 index 0000000000000000000000000000000000000000..0514a9e49a758c26400090bbbe05667676ccde05 --- /dev/null +++ b/.Rproj.user/667C8368/sources/session-ea6e98c5/370BE8B6 @@ -0,0 +1,26 @@ +{ + "id": "370BE8B6", + "path": "~/cute/man/fun_check.Rd", + "project_path": "man/fun_check.Rd", + "type": "r_doc", + "hash": "1184885037", + "contents": "", + "dirty": false, + "created": 1693472291204.0, + "source_on_save": false, + "relative_order": 3, + "properties": { + "source_window_id": "", + "Source": "Source" + }, + "folds": "", + "lastKnownWriteTime": 1693472284, + "encoding": "UTF-8", + "collab_server": "", + "source_window": "", + "last_content_update": 1693472284, + "read_only": true, + "read_only_alternatives": [ + "R/check.R" + ] +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/sources/session-ea6e98c5/370BE8B6-contents b/.Rproj.user/667C8368/sources/session-ea6e98c5/370BE8B6-contents new file mode 100644 index 0000000000000000000000000000000000000000..7ea65096776f5bd98c63ee21cc4d0c9a68a2a846 --- /dev/null +++ b/.Rproj.user/667C8368/sources/session-ea6e98c5/370BE8B6-contents @@ -0,0 +1,69 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/check.R +\name{fun_check} +\alias{fun_check} +\title{fun_check} +\usage{ +fun_check( + data, + class = NULL, + 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 +) +} +\arguments{ +\item{data}{Object to test} + +\item{class}{Character string. Either one of the class() result (But see the warning section above) or "vector" or "ggplot2" (i.e., objects of class c("gg", "ggplot")) or NULL} + +\item{typeof}{Character string. Either one of the typeof() result or NULL} + +\item{mode}{Character string. Either one of the mode() result (for non-vector object) or NULL} + +\item{length}{Numeric value indicating the length of the object. Not considered if NULL} + +\item{prop}{Logical. Are the numeric values between 0 and 1 (proportion)? If TRUE, can be used alone, without considering class, etc.} + +\item{double.as.integer.allowed}{Logical. If TRUE, no error is reported in the cheking message if argument is set to typeof == "integer" or class == "integer", while the reality is typeof == "double" or class == "numeric" but the numbers strictly have zero as modulo (remainder of a division). This means that i <- 1, which is typeof(i) -> "double" is considered as integer with double.as.integer.allowed = TRUE. WARNING: data%%1 == 0L but not isTRUE(all.equal(data%%1, 0)) is used here because the argument checks for integers stored as double (does not check for decimal numbers that are approximate integers)} + +\item{options}{A vector of character strings or integers indicating all the possible option values for the data argument, or NULL. Numbers of type "double" are accepted if they have a 0 modulo} + +\item{all.options.in.data}{Logical. If TRUE, all of the options must be present at least once in the data argument, and nothing else. If FALSE, some or all of the options must be present in the data argument, and nothing else. Ignored if options is NULL} + +\item{na.contain}{Logical. Can the data argument contain NA?} + +\item{neg.values}{Logical. Are negative numeric values authorized? Warning: the default setting is TRUE, meaning that, in that case, no check is performed for the presence of negative values. The neg.values argument is activated only when set to FALSE. In addition, (1) neg.values = FALSE can only be used when class, typeof or mode arguments are not NULL, otherwise return an error message, (2) the presence of negative values is not checked with neg.values = FALSE if the tested object is a factor and the following checking message is returned "OBJECT MUST BE MADE OF NON NEGATIVE VALUES BUT IS A FACTOR"} + +\item{inf.values}{Logical. Are infinite numeric values authorized (Inf or -Inf)? Identical remarks as for the neg.values argument} + +\item{print}{Logical. Print the message if $problem is TRUE? Warning: set by default to FALSE, which facilitates the control of the checking message output when using fun_check() inside functions. See the example section} + +\item{data.name}{Character string indicating the name of the object to test. If NULL, use what is assigned to the data argument for the returned message} + +\item{fun.name}{Character string indicating the name of the function checked (i.e., when fun_check() is used to check the arguments of this function). If non-null, the value of fun.name will be added into the message returned by fun_check()} +} +\value{ +A list containing: +$problem: logical. Is there any problem detected? +$text: message indicating the details of the problem, or the absence of problem +$object.name: value of the data.name argument (i.e., name of the checked object if provided, NULL otherwise) +} +\description{ +Check the class, type, mode and length of the data argument +Mainly used to check the arguments of other functions +Check also other kind of data parameters, is it a proportion? Is it type double but numbers without decimal part? +} +\examples{ +test <- matrix(1:3) ; fun_check(data = test, print = TRUE, class = "vector", mode = "numeric") +} diff --git a/.Rproj.user/667C8368/sources/session-ea6e98c5/691C989B b/.Rproj.user/667C8368/sources/session-ea6e98c5/691C989B new file mode 100644 index 0000000000000000000000000000000000000000..dc8c7ea24bfe8064c7d7fa8c2ab0022e15ac3e3c --- /dev/null +++ b/.Rproj.user/667C8368/sources/session-ea6e98c5/691C989B @@ -0,0 +1,27 @@ +{ + "id": "691C989B", + "path": null, + "project_path": null, + "type": "r_source", + "hash": "0", + "contents": "", + "dirty": true, + "created": 1693481260945.0, + "source_on_save": false, + "relative_order": 5, + "properties": { + "tempName": "Untitled1", + "source_window_id": "", + "Source": "Source", + "cursorPosition": "6,0", + "scrollLine": "0" + }, + "folds": "", + "lastKnownWriteTime": 8317129703101702757, + "encoding": "", + "collab_server": "", + "source_window": "", + "last_content_update": 1693481411526, + "read_only": false, + "read_only_alternatives": [] +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/sources/session-ea6e98c5/691C989B-contents b/.Rproj.user/667C8368/sources/session-ea6e98c5/691C989B-contents new file mode 100644 index 0000000000000000000000000000000000000000..1b02b807f8f0bcc4615a06c6daa3248b21df1186 --- /dev/null +++ b/.Rproj.user/667C8368/sources/session-ea6e98c5/691C989B-contents @@ -0,0 +1,6 @@ +?fun_check + +library(devtools) +library(usethis) +library(devtools) +load_all(".") diff --git a/.Rproj.user/667C8368/sources/session-ea6e98c5/A4C49243 b/.Rproj.user/667C8368/sources/session-ea6e98c5/A4C49243 new file mode 100644 index 0000000000000000000000000000000000000000..33534c3a0374553a784c340ff028956a0a75aeaa --- /dev/null +++ b/.Rproj.user/667C8368/sources/session-ea6e98c5/A4C49243 @@ -0,0 +1,26 @@ +{ + "id": "A4C49243", + "path": "~/cute/R/check.R", + "project_path": "R/check.R", + "type": "r_source", + "hash": "0", + "contents": "", + "dirty": false, + "created": 1693472129154.0, + "source_on_save": false, + "relative_order": 2, + "properties": { + "source_window_id": "", + "Source": "Source", + "cursorPosition": "475,1", + "scrollLine": "0" + }, + "folds": "", + "lastKnownWriteTime": 1693473253, + "encoding": "UTF-8", + "collab_server": "", + "source_window": "", + "last_content_update": 1693473253562, + "read_only": false, + "read_only_alternatives": [] +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/sources/session-ea6e98c5/A4C49243-contents b/.Rproj.user/667C8368/sources/session-ea6e98c5/A4C49243-contents new file mode 100644 index 0000000000000000000000000000000000000000..8caaf75a6dc579d39bea00f5d71debce405c85c0 --- /dev/null +++ b/.Rproj.user/667C8368/sources/session-ea6e98c5/A4C49243-contents @@ -0,0 +1,489 @@ + +######## fun_check() #### check class, type, length, etc., of objects + + +# todo list check OK +# Check r_debugging_tools-v1.4.R OK +# Check fun_test() 20201107 (see cute_checks.docx) OK +# example sheet OK +# check all and any OK +# -> clear to go Apollo +# -> transferred into the cute package +# Do not modify this function in cute_little_R_function anymore. See the cute repo + + +#' @title fun_check +#' @description +#' Check the class, type, mode and length of the data argument +#' Mainly used to check the arguments of other functions +#' Check also other kind of data parameters, is it a proportion? Is it type double but numbers without decimal part? +#' @param data Object to test +#' @param class Character string. Either one of the class() result (But see the warning section above) or "vector" or "ggplot2" (i.e., objects of class c("gg", "ggplot")) or NULL +#' @param typeof Character string. Either one of the typeof() result or NULL +#' @param mode Character string. Either one of the mode() result (for non-vector object) or NULL +#' @param length Numeric value indicating the length of the object. Not considered if NULL +#' @param prop Logical. Are the numeric values between 0 and 1 (proportion)? If TRUE, can be used alone, without considering class, etc. +#' @param double.as.integer.allowed Logical. If TRUE, no error is reported in the cheking message if argument is set to typeof == "integer" or class == "integer", while the reality is typeof == "double" or class == "numeric" but the numbers strictly have zero as modulo (remainder of a division). This means that i <- 1, which is typeof(i) -> "double" is considered as integer with double.as.integer.allowed = TRUE. WARNING: data%%1 == 0L but not isTRUE(all.equal(data%%1, 0)) is used here because the argument checks for integers stored as double (does not check for decimal numbers that are approximate integers) +#' @param options A vector of character strings or integers indicating all the possible option values for the data argument, or NULL. Numbers of type "double" are accepted if they have a 0 modulo +#' @param all.options.in.data Logical. If TRUE, all of the options must be present at least once in the data argument, and nothing else. If FALSE, some or all of the options must be present in the data argument, and nothing else. Ignored if options is NULL +#' @param na.contain Logical. Can the data argument contain NA? +#' @param neg.values Logical. Are negative numeric values authorized? Warning: the default setting is TRUE, meaning that, in that case, no check is performed for the presence of negative values. The neg.values argument is activated only when set to FALSE. In addition, (1) neg.values = FALSE can only be used when class, typeof or mode arguments are not NULL, otherwise return an error message, (2) the presence of negative values is not checked with neg.values = FALSE if the tested object is a factor and the following checking message is returned "OBJECT MUST BE MADE OF NON NEGATIVE VALUES BUT IS A FACTOR" +#' @param inf.values Logical. Are infinite numeric values authorized (Inf or -Inf)? Identical remarks as for the neg.values argument +#' @param print Logical. Print the message if $problem is TRUE? Warning: set by default to FALSE, which facilitates the control of the checking message output when using fun_check() inside functions. See the example section +#' @param data.name Character string indicating the name of the object to test. If NULL, use what is assigned to the data argument for the returned message +#' @param fun.name Character string indicating the name of the function checked (i.e., when fun_check() is used to check the arguments of this function). If non-null, the value of fun.name will be added into the message returned by fun_check() +#' @return A list containing: +#' $problem: logical. Is there any problem detected? +#' $text: message indicating the details of the problem, or the absence of problem +#' $object.name: value of the data.name argument (i.e., name of the checked object if provided, NULL otherwise) +#' @examples +#' test <- matrix(1:3) ; fun_check(data = test, print = TRUE, class = "vector", mode = "numeric") +#' @export + + +fun_check <- function( + data, + class = NULL, + 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 +){ + + # If options == NULL, then at least class or type or mode or length argument must be non-null + # If options is non-null, then class, type and mode must be NULL, and length can be NULL or specified + # WARNINGS + # The function tests what is written in its arguments, even if what is written is incoherent. For instance, fun_check(data = factor(1), class = "factor", mode = "character") will return a problem, whatever the object tested in the data argument, because no object can be class "factor" and mode "character" (factors are class "factor" and mode "numeric"). Of note, length of object of class "environment" is always 0 + # If the tested object is NULL, then the function will always return a checking problem + # Since R >= 4.0.0, class(matrix()) returns "matrix" "array", and not "matrix" alone as before. However, use argument class = "matrix" to check for matrix object (of class "matrix" "array" in R >= 4.0.0) and use argument class = "array" to check for array object (of class "array" in R >= 4.0.0) + # REQUIRED PACKAGES + # None + # REQUIRED FUNCTIONS FROM THE cute PACKAGE + # None + # EXAMPLE + # test <- matrix(1:3) ; fun_check(data = test, print = TRUE, class = "vector", mode = "numeric") + # see http + # DEBUGGING + # data = mean ; class = NULL ; typeof = NULL ; mode = NULL ; length = NULL ; prop = FALSE ; double.as.integer.allowed = FALSE ; options = "a" ; all.options.in.data = FALSE ; na.contain = FALSE ; neg.values = TRUE ; inf.values = TRUE ; print = TRUE ; data.name = NULL ; fun.name = NULL + # function name + # no used in this function for the error message, to avoid env colliding + # end function name + # required function checking + # end required function checking + # reserved words + # end reserved words + # fun.name checked first because required next + if( ! is.null(fun.name)){ # I have to use this way to deal with every kind of class for fun.name + if(all(base::class(fun.name) == "character")){ # all() without na.rm -> ok because class(NA) is "logical" + if(base::length(fun.name) != 1){ + tempo.cat <- paste0("ERROR IN fun_check(): THE fun.name ARGUMENT MUST BE A CHARACTER VECTOR OF LENGTH 1: ", paste(fun.name, collapse = " ")) + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + }else if(any(is.na(fun.name))){ # normally no NA with is.na() + tempo.cat <- paste0("ERROR IN fun_check(): NO ARGUMENT EXCEPT data AND options CAN HAVE NA VALUES\nPROBLEMATIC ARGUMENT IS fun.name") + 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{ + tempo.cat <- paste0("ERROR IN fun_check(): THE fun.name ARGUMENT MUST BE A CHARACTER VECTOR OF LENGTH 1") # paste(fun.name, collapse = " ") removed here because does not work with objects like function + 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 fun.name checked first because required next + # arg with no default values + mandat.args <- c( + "data" + ) + tempo <- eval(parse(text = paste0("c(missing(", paste0(mandat.args, collapse = "), missing("), "))"))) + if(any(tempo)){ # normally no NA for missing() output + tempo.cat <- paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", ifelse(sum(tempo, na.rm = TRUE) > 1, "S HAVE", " HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", paste0(mandat.args[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 + # source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.7/r_debugging_tools-v1.7.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status + # end argument primary checking + # second round of checking and data preparation + # management of special classes + basic.class <- c( + "NULL", # because class(NULL) is "NULL". The NULL aspect will be dealt later + "logical", + "integer", + "numeric", + # "complex", + "character" + # "matrix", + # "array", + # "data.frame", + # "list", + # "factor", + # "table", + # "expression", + # "name", + # "symbol", + # "function", + # "uneval", + # "environment", + # "ggplot2", + # "ggplot_built", + # "call" + ) + tempo.arg.base <-c( # no names(formals(fun = sys.function(sys.parent(n = 2)))) used with fun_check() to be sure to deal with the correct environment + "class", + "typeof", + "mode", + "length", + "prop", + "double.as.integer.allowed", + "options", + "all.options.in.data", + "na.contain", + "neg.values", + "inf.values", + "print", + "data.name", + "fun.name" + ) + tempo.class <-list( # no get() used to be sure to deal with the correct environment + base::class(class), + base::class(typeof), + base::class(mode), + base::class(length), + base::class(prop), + base::class(double.as.integer.allowed), + base::class(options), + base::class(all.options.in.data), + base::class(na.contain), + base::class(neg.values), + base::class(inf.values), + base::class(print), + base::class(data.name), + base::class(fun.name) + ) + tempo <- ! sapply(lapply(tempo.class, FUN = "%in%", basic.class), FUN = all) + if(any(tempo)){ + tempo.cat1 <- tempo.arg.base[tempo] + tempo.cat2 <- sapply(tempo.class[tempo], FUN = paste0, collapse = " ") + tempo.sep <- sapply(mapply(" ", max(nchar(tempo.cat1)) - nchar(tempo.cat1) + 3, FUN = rep, SIMPLIFY = FALSE), FUN = paste0, collapse = "") + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": ANY ARGUMENT EXCEPT data MUST HAVE A BASIC CLASS\nPROBLEMATIC ARGUMENT", ifelse(base::length(tempo.cat1) > 1, "S", ""), " AND ASSOCIATED CLASS", ifelse(base::length(tempo.cat1) > 1, "ES ARE", " IS"), ":\n", paste0(tempo.cat1, tempo.sep, tempo.cat2, collapse = "\n")) # normally no NA with is.na() + 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 special classes + # management of NA arguments + if(any(is.na(data.name)) | any(is.na(class)) | any(is.na(typeof)) | any(is.na(mode)) | any(is.na(length)) | any(is.na(prop)) | any(is.na(double.as.integer.allowed)) | any(is.na(all.options.in.data)) | any(is.na(na.contain)) | any(is.na(neg.values)) | any(is.na(inf.values)) | any(is.na(print)) | any(is.na(fun.name))){ # normally no NA with is.na() + tempo <- c("data.name", "class", "typeof", "mode", "length", "prop", "double.as.integer.allowed", "all.options.in.data", "na.contain", "neg.values", "inf.values", "print", "fun.name")[c(any(is.na(data.name)), any(is.na(class)), any(is.na(typeof)), any(is.na(mode)), any(is.na(length)), any(is.na(prop)), any(is.na(double.as.integer.allowed)), any(is.na(all.options.in.data)), any(is.na(na.contain)), any(is.na(neg.values)), any(is.na(inf.values)), any(is.na(print)), any(is.na(fun.name)))] + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": NO ARGUMENT EXCEPT data AND options CAN HAVE NA VALUES\nPROBLEMATIC ARGUMENT", ifelse(length(tempo) > 1, "S ARE", " IS"), ":\n", paste(tempo, collapse = "\n")) # normally no NA with is.na() + 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( + "prop", + "double.as.integer.allowed", + "all.options.in.data", + "na.contain", + "neg.values", + "inf.values", + "print" + ) + 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 fun.check():\n", ifelse(sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT BE NULL:\n", 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 + # dealing with logical + # tested below + # end dealing with logical + # 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( ! is.null(data.name)){ + if( ! (base::length(data.name) == 1L & all(base::class(data.name) == "character"))){ # all() without na.rm -> ok because class(NA) is "logical" + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": data.name ARGUMENT MUST BE A SINGLE CHARACTER ELEMENT AND NOT ", paste(data.name, collapse = " ")) + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + } + } + if(is.null(options) & is.null(class) & is.null(typeof) & is.null(mode) & prop == FALSE & is.null(length)){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": AT LEAST ONE OF THE options, class, typeof, mode, prop, OR length ARGUMENT MUST BE SPECIFIED (I.E, TRUE FOR prop)") + 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( ! is.null(options) & ( ! is.null(class) | ! is.null(typeof) | ! is.null(mode) | prop == TRUE)){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE class, typeof, mode ARGUMENTS MUST BE NULL, AND prop FALSE, IF THE options ARGUMENT IS SPECIFIED\nTHE options ARGUMENT MUST BE NULL IF THE class AND/OR typeof AND/OR mode AND/OR prop ARGUMENT IS SPECIFIED") + 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( ! (all(base::class(neg.values) == "logical") & base::length(neg.values) == 1L)){ # all() without na.rm -> ok because class(NA) is "logical" + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE neg.values ARGUMENT MUST BE TRUE OR FALSE ONLY") + 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(neg.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE neg.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE 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 == + } + if( ! (all(base::class(inf.values) == "logical") & base::length(inf.values) == 1L)){ # all() without na.rm -> ok because class(NA) is "logical" + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE inf.values ARGUMENT MUST BE TRUE OR FALSE ONLY") + 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(inf.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE inf.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE 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 == + } + if( ! is.null(class)){ # may add "formula" and "Date" as in https://renenyffenegger.ch/notes/development/languages/R/functions/class + if( ! all(class %in% c("vector", "logical", "integer", "numeric", "complex", "character", "matrix", "array", "data.frame", "list", "factor", "table", "expression", "name", "symbol", "function", "uneval", "environment", "ggplot2", "ggplot_built", "call") & base::length(class) == 1L)){ # length == 1L here because of class(matrix()) since R4.0.0 # all() without na.rm -> ok because class cannot be NA (tested above) + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT MUST BE ONE OF THESE VALUE:\n\"vector\", \"logical\", \"integer\", \"numeric\", \"complex\", \"character\", \"matrix\", \"array\", \"data.frame\", \"list\", \"factor\", \"table\", \"expression\", \"name\", \"symbol\", \"function\", \"environment\", \"ggplot2\", \"ggplot_built\", \"call\"") + 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(neg.values == FALSE & ! any(class %in% c("vector", "numeric", "integer", "matrix", "array", "data.frame", "table"))){ # no need of na.rm = TRUE for any() because %in% does not output NA + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"integer\", \"matrix\", \"array\", \"data.frame\", \"table\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") + 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(inf.values == FALSE & ! any(class %in% c("vector", "numeric", "matrix", "array", "data.frame", "table"))){ # no need of na.rm = TRUE for any() because %in% does not output NA + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF inf.values ARGUMENT IS SWITCHED TO FALSE. \"integer IS NOT ALLOWED BECAUSE IFINITE VALUES ARE NOT INTEGERS\"") + 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( ! is.null(typeof)){ # all the types are here: https://renenyffenegger.ch/notes/development/languages/R/functions/typeof + if( ! (all(typeof %in% c("logical", "integer", "double", "complex", "character", "list", "expression", "symbol", "closure", "special", "builtin", "environment", "S4", "language")) & base::length(typeof) == 1L)){ # "language" is the type of object of class "call" # all() without na.rm -> ok because typeof cannot be NA (tested above) + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"integer\", \"double\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"closure\", \"special\", \"builtin\", \"environment\", \"S4\", \"language\"") + 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(neg.values == FALSE & ! typeof %in% c("double", "integer")){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN \"double\" OR \"integer\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") + 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(inf.values == FALSE & typeof != "double"){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN \"double\" IF inf.values ARGUMENT IS SWITCHED TO FALSE. \"integer IS NOT ALLOWED BECAUSE IFINITE VALUES ARE NOT INTEGERS\"") + 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( ! is.null(mode)){ # all the types are here: https://renenyffenegger.ch/notes/development/languages/R/functions/typeof + if( ! (all(mode %in% c("logical", "numeric", "complex", "character", "list", "expression", "name", "symbol", "function", "environment", "S4", "call")) & base::length(mode) == 1L)){ # all() without na.rm -> ok because mode cannot be NA (tested above) + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"numeric\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"function\", \"environment\", \"S4\", \"call\"") + 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(neg.values == FALSE & mode != "numeric"){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") + 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(inf.values == FALSE & mode != "numeric"){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF inf.values ARGUMENT IS SWITCHED TO FALSE") + 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( ! is.null(length)){ + if( ! (is.numeric(length) & base::length(length) == 1L & all( ! grepl(length, pattern = "\\.")))){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": length ARGUMENT MUST BE A SINGLE INTEGER VALUE") + 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( ! (is.logical(prop) & base::length(prop) == 1L)){ # is.na() already checked for prop + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": prop ARGUMENT MUST BE TRUE OR FALSE ONLY") + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + }else if(prop == TRUE){ + if( ! is.null(class)){ + if( ! any(class %in% c("vector", "numeric", "matrix", "array", "data.frame", "table"))){ # no need of na.rm = TRUE for any() because %in% does not output NA + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN NULL, \"vector\", \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF prop ARGUMENT IS TRUE") # not integer because prop + 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( ! is.null(mode)){ + if(mode != "numeric"){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN NULL OR \"numeric\" IF prop ARGUMENT IS TRUE") + 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( ! is.null(typeof)){ + if(typeof != "double"){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN NULL OR \"double\" IF prop ARGUMENT IS TRUE") + 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( ! (all(base::class(double.as.integer.allowed) == "logical") & base::length(double.as.integer.allowed) == 1L)){ # all() without na.rm -> ok because class() never returns NA + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE double.as.integer.allowed ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(double.as.integer.allowed, collapse = " ")) + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + } + if( ! (is.logical(all.options.in.data) & base::length(all.options.in.data) == 1L)){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": all.options.in.data ARGUMENT MUST BE A SINGLE LOGICAL VALUE (TRUE OR FALSE ONLY): ", paste(all.options.in.data, collapse = " ")) + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + } + if( ! (all(base::class(na.contain) == "logical") & base::length(na.contain) == 1L)){ # all() without na.rm -> ok because class() never returns NA + tempo.cat <- paste0("ERROR IN fun_check(): THE na.contain ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(na.contain, collapse = " ")) + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + } + if( ! (all(base::class(print) == "logical") & base::length(print) == 1L)){ # all() without na.rm -> ok because class() never returns NA + tempo.cat <- paste0("ERROR IN fun_check(): THE print ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(print, collapse = " ")) + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + } + # data.name and fun.name tested at the beginning + # end other checkings + # end second round of checking and data preparation + # package checking + # end package checking + # main code + if(is.null(data.name)){ + data.name <- deparse(substitute(data)) + } + problem <- FALSE + text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT") + if(( ! is.null(options)) & (all(base::typeof(data) == "character") | all(base::typeof(data) == "integer") | all(base::typeof(data) == "double"))){ # all() without na.rm -> ok because typeof() never returns NA + if(all(base::typeof(data) == "double")){ + if( ! all(data %% 1 == 0L, na.rm = TRUE)){ + problem <- TRUE + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nBUT IS NOT EVEN TYPE CHARACTER OR INTEGER") + } + }else{ + text <- "" + if( ! all(data %in% options)){ # no need of na.rm = TRUE for all() because %in% does not output NA + problem <- TRUE + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nTHE PROBLEMATIC ELEMENTS OF ", data.name, " ARE: ", paste(unique(data[ ! (data %in% options)]), collapse = " ")) + } + if(all.options.in.data == TRUE){ + if( ! all(options %in% data)){ # no need of na.rm = TRUE for all() because %in% does not output NA + problem <- TRUE + text <- paste0(ifelse(text == "", "", paste0(text, "\n")), ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE MADE OF ALL THESE OPTIONS: ", paste(options, collapse = " "), "\nTHE MISSING ELEMENTS OF THE options ARGUMENT ARE: ", paste(unique(options[ ! (options %in% data)]), collapse = " ")) + } + } + if( ! is.null(length)){ + if(base::length(data) != length){ + problem <- TRUE + text <- paste0(ifelse(text == "", "", paste0(text, "\n")), ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE LENGTH OF ", data.name, " MUST BE ", length, " AND NOT ", base::length(data)) + } + } + if(text == ""){ + text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT") + } + } + }else if( ! is.null(options)){ + problem <- TRUE + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nBUT IS NOT EVEN TYPE CHARACTER OR INTEGER") + } + arg.names <- c("class", "typeof", "mode", "length") + if( ! is.null(class)){ + if(class == "matrix"){ # because of class(matric()) since R4.0.0 + class <- c("matrix", "array") + }else if(class == "factor" & all(base::class(data) %in% c("factor", "ordered"))){ # to deal with ordered factors # all() without na.rm -> ok because class(NA) is "logical" + class <- c("factor", "ordered") + } + } + if(is.null(options)){ + for(i2 in 1:base::length(arg.names)){ + if( ! is.null(get(arg.names[i2], env = sys.nframe(), inherit = FALSE))){ + # script to execute + tempo.script <- ' +problem <- TRUE ; +if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ +text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE ") ; +}else{ +text <- paste0(text, " AND ") ; +} +text <- paste0(text, toupper(arg.names[i2]), " ", if(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) %in% c("matrix", "array"))){"matrix"}else if(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) %in% c("factor", "ordered"))){"factor"}else{get(arg.names[i2], env = sys.nframe(), inherit = FALSE)}) +' # no need of na.rm = TRUE for all() because %in% does not output NA + # end script to execute + if(base::typeof(data) == "double" & double.as.integer.allowed == TRUE & ((arg.names[i2] == "class" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "integer")) | (arg.names[i2] == "typeof" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "integer")))){ # no need of na.rm = TRUE for all() because == does not output NA if no NA in left of ==, which is the case for arg.names # typeof(data) == "double" means no factor allowed + if( ! all(data %% 1 == 0L, na.rm = TRUE)){ # to check integers (use %%, meaning the remaining of a division): see the precedent line. isTRUE(all.equal(data%%1, rep(0, length(data)))) not used because we strictly need zero as a result. Warning: na.rm = TRUE required here for all() + eval(parse(text = tempo.script)) # execute tempo.script + } + }else if( ! any(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) %in% c("vector", "ggplot2"))) & ! all(eval(parse(text = paste0(arg.names[i2], "(data)"))) %in% get(arg.names[i2], env = sys.nframe(), inherit = FALSE))){ # test the four c("class", "typeof", "mode", "length") arguments with their corresponding function. No need of na.rm = TRUE for all() because %in% does not output NA # no need of na.rm = TRUE for all() because %in% does not output NA # no need of na.rm = TRUE for any() because get get(arg.names) does not contain NA + eval(parse(text = tempo.script)) # execute tempo.script + }else if(arg.names[i2] == "class" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "vector") & ! (all(base::class(data) %in% "numeric") | all(base::class(data) %in% "integer") | all(base::class(data) %in% "character") | all(base::class(data) %in% "logical"))){ # test class == "vector". No need of na.rm = TRUE for all() because %in% does not output NA # no need of na.rm = TRUE for all() because == does not output NA if no NA in left of ==, which is the case for arg.names + eval(parse(text = tempo.script)) # execute tempo.script + }else if(arg.names[i2] == "class" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "ggplot2") & ! all(base::class(data) %in% c("gg", "ggplot"))){ # test ggplot object # no need of na.rm = TRUE for all() because == does not output NA if no NA in left of ==, which is the case for arg.names # no need of na.rm = TRUE for all() because %in% does not output NA + eval(parse(text = tempo.script)) # execute tempo.script + } + } + } + } +if(prop == TRUE & all(base::typeof(data) == "double")){ # all() without na.rm -> ok because typeof(NA) is "logical" + if(is.null(data) | any(data < 0 | data > 1, na.rm = TRUE)){ # works if data is NULL # Warning: na.rm = TRUE required here for any() # typeof(data) == "double" means no factor allowed + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT MUST BE DECIMAL VALUES BETWEEN 0 AND 1") + } +}else if(prop == TRUE){ + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT MUST BE DECIMAL VALUES BETWEEN 0 AND 1") +} +if(all(base::class(data) %in% "expression")){ # no need of na.rm = TRUE for all() because %in% does not output NA + data <- as.character(data) # to evaluate the presence of NA +} +if(na.contain == FALSE & (base::mode(data) %in% c("logical", "numeric", "complex", "character", "list"))){ # before it was ! (class(data) %in% c("function", "environment")) + if(any(is.na(data)) == TRUE){ # not on the same line because when data is class envir or function , do not like that # normally no NA with is.na() + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT CONTAINS NA WHILE NOT AUTHORIZED") + } +} +if(neg.values == FALSE & all(base::mode(data) %in% "numeric") & ! any(base::class(data) %in% "factor")){ # no need of na.rm = TRUE for all() because %in% does not output NA + if(any(data < 0, na.rm = TRUE)){ # Warning: na.rm = TRUE required here for any() + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON NEGATIVE NUMERIC VALUES") + } +}else if(neg.values == FALSE){ + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON NEGATIVE VALUES BUT IS ", ifelse(any(base::class(data) %in% "factor"), "A FACTOR", "NOT EVEN MODE NUMERIC")) +} +if(inf.values == FALSE & all(base::typeof(data) %in% "double") & ! any(base::class(data) %in% "factor")){ # no need of na.rm = TRUE for all() because %in% does not output NA + if(any(is.infinite(data), na.rm = TRUE)){ # Warning: na.rm = TRUE required here for any() + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON INFINITE NUMERIC VALUES") + } +}else if(inf.values == FALSE){ + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON INFINITE VALUES BUT IS ", ifelse(any(base::class(data) %in% "factor"), "A FACTOR", "NOT EVEN TYPE DOUBLE")) +} +if(print == TRUE & problem == TRUE){ + cat(paste0("\n\n================\n\n", text, "\n\n================\n\n")) +} +# output +output <- list(problem = problem, text = text, object.name = data.name) +return(output) +# end output +# end main code +} + +library(roxygen2) +roxygenise() + diff --git a/.Rproj.user/667C8368/sources/session-ea6e98c5/D3D453AE b/.Rproj.user/667C8368/sources/session-ea6e98c5/D3D453AE new file mode 100644 index 0000000000000000000000000000000000000000..6b454d164b890221f00ff1b30bfbca0a9fe677be --- /dev/null +++ b/.Rproj.user/667C8368/sources/session-ea6e98c5/D3D453AE @@ -0,0 +1,26 @@ +{ + "id": "D3D453AE", + "path": "~/cute/DESCRIPTION", + "project_path": "DESCRIPTION", + "type": "dcf", + "hash": "0", + "contents": "", + "dirty": false, + "created": 1693481219458.0, + "source_on_save": false, + "relative_order": 3, + "properties": { + "source_window_id": "", + "Source": "Source", + "cursorPosition": "8,34", + "scrollLine": "0" + }, + "folds": "", + "lastKnownWriteTime": 1693481363, + "encoding": "UTF-8", + "collab_server": "", + "source_window": "", + "last_content_update": 1693481363651, + "read_only": false, + "read_only_alternatives": [] +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/sources/session-ea6e98c5/D3D453AE-contents b/.Rproj.user/667C8368/sources/session-ea6e98c5/D3D453AE-contents new file mode 100644 index 0000000000000000000000000000000000000000..969b3c60fae17e05a8c1169e50f5624164d5a326 --- /dev/null +++ b/.Rproj.user/667C8368/sources/session-ea6e98c5/D3D453AE-contents @@ -0,0 +1,13 @@ +Package: cute +Type: Package +Title: What the Package Does (Title Case) +Version: 0.1.0 +Author: Who wrote it +Maintainer: The package maintainer <yourself@somewhere.net> +Description: More about what it does (maybe more than one line) + Use four spaces when indenting paragraphs within the Description. +License: What license is it under? +Encoding: UTF-8 +LazyData: true +RoxygenNote: 7.2.3 + diff --git a/.Rproj.user/667C8368/sources/session-ea6e98c5/DF9914DB b/.Rproj.user/667C8368/sources/session-ea6e98c5/DF9914DB new file mode 100644 index 0000000000000000000000000000000000000000..b2b25e9b41563527552a659f8156a231c1a47271 --- /dev/null +++ b/.Rproj.user/667C8368/sources/session-ea6e98c5/DF9914DB @@ -0,0 +1,26 @@ +{ + "id": "DF9914DB", + "path": "~/cute/NAMESPACE", + "project_path": "NAMESPACE", + "type": "r_namespace", + "hash": "0", + "contents": "", + "dirty": false, + "created": 1693481221831.0, + "source_on_save": false, + "relative_order": 4, + "properties": { + "source_window_id": "", + "Source": "Source", + "cursorPosition": "3,0", + "scrollLine": "0" + }, + "folds": "", + "lastKnownWriteTime": 1693472356, + "encoding": "UTF-8", + "collab_server": "", + "source_window": "", + "last_content_update": 1693472356, + "read_only": false, + "read_only_alternatives": [] +} \ No newline at end of file diff --git a/.Rproj.user/667C8368/sources/session-ea6e98c5/DF9914DB-contents b/.Rproj.user/667C8368/sources/session-ea6e98c5/DF9914DB-contents new file mode 100644 index 0000000000000000000000000000000000000000..807b096a333754b7fc16771aa66f9c212effa97e --- /dev/null +++ b/.Rproj.user/667C8368/sources/session-ea6e98c5/DF9914DB-contents @@ -0,0 +1,3 @@ +# Generated by roxygen2: do not edit by hand + +export(fun_check) diff --git a/check.doc b/.Rproj.user/667C8368/sources/session-ea6e98c5/lock_file similarity index 100% rename from check.doc rename to .Rproj.user/667C8368/sources/session-ea6e98c5/lock_file diff --git a/.Rproj.user/shared/notebooks/patch-chunk-names b/.Rproj.user/shared/notebooks/patch-chunk-names new file mode 100644 index 0000000000000000000000000000000000000000..e69de29bb2d1d6434b8b29ae775ad8c2e48c5391 diff --git a/.Rproj.user/shared/notebooks/paths b/.Rproj.user/shared/notebooks/paths new file mode 100644 index 0000000000000000000000000000000000000000..790beb01c5941303cccbce2641fe19ed0abc6813 --- /dev/null +++ b/.Rproj.user/shared/notebooks/paths @@ -0,0 +1,3 @@ +C:/Users/yhan/Documents/cute/DESCRIPTION="3F0C4DFF" +C:/Users/yhan/Documents/cute/NAMESPACE="009BF0BE" +C:/Users/yhan/Documents/cute/R/check.R="FB5CDB26" diff --git a/DESCRIPTION b/DESCRIPTION new file mode 100644 index 0000000000000000000000000000000000000000..603cbc09ac5173754ab0b124b7eedf9e83d7ee0c --- /dev/null +++ b/DESCRIPTION @@ -0,0 +1,13 @@ +Package: cute +Type: Package +Title: What the Package Does (Title Case) +Version: 0.1.0 +Author: Who wrote it +Maintainer: The package maintainer <yourself@somewhere.net> +Description: More about what it does (maybe more than one line) + Use four spaces when indenting paragraphs within the Description. +License: What license is it under? +Encoding: UTF-8 +LazyData: true +RoxygenNote: 7.2.3 + diff --git a/NAMESPACE b/NAMESPACE new file mode 100644 index 0000000000000000000000000000000000000000..807b096a333754b7fc16771aa66f9c212effa97e --- /dev/null +++ b/NAMESPACE @@ -0,0 +1,3 @@ +# Generated by roxygen2: do not edit by hand + +export(fun_check) diff --git a/R/check.R b/R/check.R new file mode 100644 index 0000000000000000000000000000000000000000..af3b00f1c54c0952dfb87ebacec270fb134f6748 --- /dev/null +++ b/R/check.R @@ -0,0 +1,489 @@ + +######## fun_check() #### check class, type, length, etc., of objects + + +# todo list check OK +# Check r_debugging_tools-v1.4.R OK +# Check fun_test() 20201107 (see cute_checks.docx) OK +# example sheet OK +# check all and any OK +# -> clear to go Apollo +# -> transferred into the cute package +# Do not modify this function in cute_little_R_function anymore. See the cute repo + + +#' @title fun_check +#' @description +#' Check the class, type, mode and length of the data argument +#' Mainly used to check the arguments of other functions +#' Check also other kind of data parameters, is it a proportion? Is it type double but numbers without decimal part? +#' @param data Object to test +#' @param class Character string. Either one of the class() result (But see the warning section above) or "vector" or "ggplot2" (i.e., objects of class c("gg", "ggplot")) or NULL +#' @param typeof Character string. Either one of the typeof() result or NULL +#' @param mode Character string. Either one of the mode() result (for non-vector object) or NULL +#' @param length Numeric value indicating the length of the object. Not considered if NULL +#' @param prop Logical. Are the numeric values between 0 and 1 (proportion)? If TRUE, can be used alone, without considering class, etc. +#' @param double.as.integer.allowed Logical. If TRUE, no error is reported in the cheking message if argument is set to typeof == "integer" or class == "integer", while the reality is typeof == "double" or class == "numeric" but the numbers strictly have zero as modulo (remainder of a division). This means that i <- 1, which is typeof(i) -> "double" is considered as integer with double.as.integer.allowed = TRUE. WARNING: data%%1 == 0L but not isTRUE(all.equal(data%%1, 0)) is used here because the argument checks for integers stored as double (does not check for decimal numbers that are approximate integers) +#' @param options A vector of character strings or integers indicating all the possible option values for the data argument, or NULL. Numbers of type "double" are accepted if they have a 0 modulo +#' @param all.options.in.data Logical. If TRUE, all of the options must be present at least once in the data argument, and nothing else. If FALSE, some or all of the options must be present in the data argument, and nothing else. Ignored if options is NULL +#' @param na.contain Logical. Can the data argument contain NA? +#' @param neg.values Logical. Are negative numeric values authorized? Warning: the default setting is TRUE, meaning that, in that case, no check is performed for the presence of negative values. The neg.values argument is activated only when set to FALSE. In addition, (1) neg.values = FALSE can only be used when class, typeof or mode arguments are not NULL, otherwise return an error message, (2) the presence of negative values is not checked with neg.values = FALSE if the tested object is a factor and the following checking message is returned "OBJECT MUST BE MADE OF NON NEGATIVE VALUES BUT IS A FACTOR" +#' @param inf.values Logical. Are infinite numeric values authorized (Inf or -Inf)? Identical remarks as for the neg.values argument +#' @param print Logical. Print the message if $problem is TRUE? Warning: set by default to FALSE, which facilitates the control of the checking message output when using fun_check() inside functions. See the example section +#' @param data.name Character string indicating the name of the object to test. If NULL, use what is assigned to the data argument for the returned message +#' @param fun.name Character string indicating the name of the function checked (i.e., when fun_check() is used to check the arguments of this function). If non-null, the value of fun.name will be added into the message returned by fun_check() +#' @return A list containing: +#' $problem: logical. Is there any problem detected? +#' $text: message indicating the details of the problem, or the absence of problem +#' $object.name: value of the data.name argument (i.e., name of the checked object if provided, NULL otherwise) +#' @examples +#' test <- matrix(1:3) ; fun_check(data = test, print = TRUE, class = "vector", mode = "numeric") +#' @export + + +fun_check <- function( + data, + class = NULL, + 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 +){ + + # If options == NULL, then at least class or type or mode or length argument must be non-null + # If options is non-null, then class, type and mode must be NULL, and length can be NULL or specified + # WARNINGS + # The function tests what is written in its arguments, even if what is written is incoherent. For instance, fun_check(data = factor(1), class = "factor", mode = "character") will return a problem, whatever the object tested in the data argument, because no object can be class "factor" and mode "character" (factors are class "factor" and mode "numeric"). Of note, length of object of class "environment" is always 0 + # If the tested object is NULL, then the function will always return a checking problem + # Since R >= 4.0.0, class(matrix()) returns "matrix" "array", and not "matrix" alone as before. However, use argument class = "matrix" to check for matrix object (of class "matrix" "array" in R >= 4.0.0) and use argument class = "array" to check for array object (of class "array" in R >= 4.0.0) + # REQUIRED PACKAGES + # None + # REQUIRED FUNCTIONS FROM THE cute PACKAGE + # None + # EXAMPLE + # test <- matrix(1:3) ; fun_check(data = test, print = TRUE, class = "vector", mode = "numeric") + # see http + # DEBUGGING + # data = mean ; class = NULL ; typeof = NULL ; mode = NULL ; length = NULL ; prop = FALSE ; double.as.integer.allowed = FALSE ; options = "a" ; all.options.in.data = FALSE ; na.contain = FALSE ; neg.values = TRUE ; inf.values = TRUE ; print = TRUE ; data.name = NULL ; fun.name = NULL + # function name + # no used in this function for the error message, to avoid env colliding + # end function name + # required function checking + # end required function checking + # reserved words + # end reserved words + # fun.name checked first because required next + if( ! is.null(fun.name)){ # I have to use this way to deal with every kind of class for fun.name + if(all(base::class(fun.name) == "character")){ # all() without na.rm -> ok because class(NA) is "logical" + if(base::length(fun.name) != 1){ + tempo.cat <- paste0("ERROR IN fun_check(): THE fun.name ARGUMENT MUST BE A CHARACTER VECTOR OF LENGTH 1: ", paste(fun.name, collapse = " ")) + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + }else if(any(is.na(fun.name))){ # normally no NA with is.na() + tempo.cat <- paste0("ERROR IN fun_check(): NO ARGUMENT EXCEPT data AND options CAN HAVE NA VALUES\nPROBLEMATIC ARGUMENT IS fun.name") + 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{ + tempo.cat <- paste0("ERROR IN fun_check(): THE fun.name ARGUMENT MUST BE A CHARACTER VECTOR OF LENGTH 1") # paste(fun.name, collapse = " ") removed here because does not work with objects like function + 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 fun.name checked first because required next + # arg with no default values + mandat.args <- c( + "data" + ) + tempo <- eval(parse(text = paste0("c(missing(", paste0(mandat.args, collapse = "), missing("), "))"))) + if(any(tempo)){ # normally no NA for missing() output + tempo.cat <- paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", ifelse(sum(tempo, na.rm = TRUE) > 1, "S HAVE", " HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", paste0(mandat.args[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 + # source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.7/r_debugging_tools-v1.7.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status + # end argument primary checking + # second round of checking and data preparation + # management of special classes + basic.class <- c( + "NULL", # because class(NULL) is "NULL". The NULL aspect will be dealt later + "logical", + "integer", + "numeric", + # "complex", + "character" + # "matrix", + # "array", + # "data.frame", + # "list", + # "factor", + # "table", + # "expression", + # "name", + # "symbol", + # "function", + # "uneval", + # "environment", + # "ggplot2", + # "ggplot_built", + # "call" + ) + tempo.arg.base <-c( # no names(formals(fun = sys.function(sys.parent(n = 2)))) used with fun_check() to be sure to deal with the correct environment + "class", + "typeof", + "mode", + "length", + "prop", + "double.as.integer.allowed", + "options", + "all.options.in.data", + "na.contain", + "neg.values", + "inf.values", + "print", + "data.name", + "fun.name" + ) + tempo.class <-list( # no get() used to be sure to deal with the correct environment + base::class(class), + base::class(typeof), + base::class(mode), + base::class(length), + base::class(prop), + base::class(double.as.integer.allowed), + base::class(options), + base::class(all.options.in.data), + base::class(na.contain), + base::class(neg.values), + base::class(inf.values), + base::class(print), + base::class(data.name), + base::class(fun.name) + ) + tempo <- ! sapply(lapply(tempo.class, FUN = "%in%", basic.class), FUN = all) + if(any(tempo)){ + tempo.cat1 <- tempo.arg.base[tempo] + tempo.cat2 <- sapply(tempo.class[tempo], FUN = paste0, collapse = " ") + tempo.sep <- sapply(mapply(" ", max(nchar(tempo.cat1)) - nchar(tempo.cat1) + 3, FUN = rep, SIMPLIFY = FALSE), FUN = paste0, collapse = "") + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": ANY ARGUMENT EXCEPT data MUST HAVE A BASIC CLASS\nPROBLEMATIC ARGUMENT", ifelse(base::length(tempo.cat1) > 1, "S", ""), " AND ASSOCIATED CLASS", ifelse(base::length(tempo.cat1) > 1, "ES ARE", " IS"), ":\n", paste0(tempo.cat1, tempo.sep, tempo.cat2, collapse = "\n")) # normally no NA with is.na() + 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 special classes + # management of NA arguments + if(any(is.na(data.name)) | any(is.na(class)) | any(is.na(typeof)) | any(is.na(mode)) | any(is.na(length)) | any(is.na(prop)) | any(is.na(double.as.integer.allowed)) | any(is.na(all.options.in.data)) | any(is.na(na.contain)) | any(is.na(neg.values)) | any(is.na(inf.values)) | any(is.na(print)) | any(is.na(fun.name))){ # normally no NA with is.na() + tempo <- c("data.name", "class", "typeof", "mode", "length", "prop", "double.as.integer.allowed", "all.options.in.data", "na.contain", "neg.values", "inf.values", "print", "fun.name")[c(any(is.na(data.name)), any(is.na(class)), any(is.na(typeof)), any(is.na(mode)), any(is.na(length)), any(is.na(prop)), any(is.na(double.as.integer.allowed)), any(is.na(all.options.in.data)), any(is.na(na.contain)), any(is.na(neg.values)), any(is.na(inf.values)), any(is.na(print)), any(is.na(fun.name)))] + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": NO ARGUMENT EXCEPT data AND options CAN HAVE NA VALUES\nPROBLEMATIC ARGUMENT", ifelse(length(tempo) > 1, "S ARE", " IS"), ":\n", paste(tempo, collapse = "\n")) # normally no NA with is.na() + 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( + "prop", + "double.as.integer.allowed", + "all.options.in.data", + "na.contain", + "neg.values", + "inf.values", + "print" + ) + 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 fun.check():\n", ifelse(sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT BE NULL:\n", 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 + # dealing with logical + # tested below + # end dealing with logical + # 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( ! is.null(data.name)){ + if( ! (base::length(data.name) == 1L & all(base::class(data.name) == "character"))){ # all() without na.rm -> ok because class(NA) is "logical" + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": data.name ARGUMENT MUST BE A SINGLE CHARACTER ELEMENT AND NOT ", paste(data.name, collapse = " ")) + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + } + } + if(is.null(options) & is.null(class) & is.null(typeof) & is.null(mode) & prop == FALSE & is.null(length)){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": AT LEAST ONE OF THE options, class, typeof, mode, prop, OR length ARGUMENT MUST BE SPECIFIED (I.E, TRUE FOR prop)") + 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( ! is.null(options) & ( ! is.null(class) | ! is.null(typeof) | ! is.null(mode) | prop == TRUE)){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE class, typeof, mode ARGUMENTS MUST BE NULL, AND prop FALSE, IF THE options ARGUMENT IS SPECIFIED\nTHE options ARGUMENT MUST BE NULL IF THE class AND/OR typeof AND/OR mode AND/OR prop ARGUMENT IS SPECIFIED") + 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( ! (all(base::class(neg.values) == "logical") & base::length(neg.values) == 1L)){ # all() without na.rm -> ok because class(NA) is "logical" + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE neg.values ARGUMENT MUST BE TRUE OR FALSE ONLY") + 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(neg.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE neg.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE 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 == + } + if( ! (all(base::class(inf.values) == "logical") & base::length(inf.values) == 1L)){ # all() without na.rm -> ok because class(NA) is "logical" + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE inf.values ARGUMENT MUST BE TRUE OR FALSE ONLY") + 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(inf.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE inf.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE 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 == + } + if( ! is.null(class)){ # may add "formula" and "Date" as in https://renenyffenegger.ch/notes/development/languages/R/functions/class + if( ! all(class %in% c("vector", "logical", "integer", "numeric", "complex", "character", "matrix", "array", "data.frame", "list", "factor", "table", "expression", "name", "symbol", "function", "uneval", "environment", "ggplot2", "ggplot_built", "call") & base::length(class) == 1L)){ # length == 1L here because of class(matrix()) since R4.0.0 # all() without na.rm -> ok because class cannot be NA (tested above) + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT MUST BE ONE OF THESE VALUE:\n\"vector\", \"logical\", \"integer\", \"numeric\", \"complex\", \"character\", \"matrix\", \"array\", \"data.frame\", \"list\", \"factor\", \"table\", \"expression\", \"name\", \"symbol\", \"function\", \"environment\", \"ggplot2\", \"ggplot_built\", \"call\"") + 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(neg.values == FALSE & ! any(class %in% c("vector", "numeric", "integer", "matrix", "array", "data.frame", "table"))){ # no need of na.rm = TRUE for any() because %in% does not output NA + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"integer\", \"matrix\", \"array\", \"data.frame\", \"table\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") + 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(inf.values == FALSE & ! any(class %in% c("vector", "numeric", "matrix", "array", "data.frame", "table"))){ # no need of na.rm = TRUE for any() because %in% does not output NA + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF inf.values ARGUMENT IS SWITCHED TO FALSE. \"integer IS NOT ALLOWED BECAUSE IFINITE VALUES ARE NOT INTEGERS\"") + 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( ! is.null(typeof)){ # all the types are here: https://renenyffenegger.ch/notes/development/languages/R/functions/typeof + if( ! (all(typeof %in% c("logical", "integer", "double", "complex", "character", "list", "expression", "symbol", "closure", "special", "builtin", "environment", "S4", "language")) & base::length(typeof) == 1L)){ # "language" is the type of object of class "call" # all() without na.rm -> ok because typeof cannot be NA (tested above) + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"integer\", \"double\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"closure\", \"special\", \"builtin\", \"environment\", \"S4\", \"language\"") + 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(neg.values == FALSE & ! typeof %in% c("double", "integer")){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN \"double\" OR \"integer\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") + 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(inf.values == FALSE & typeof != "double"){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN \"double\" IF inf.values ARGUMENT IS SWITCHED TO FALSE. \"integer IS NOT ALLOWED BECAUSE IFINITE VALUES ARE NOT INTEGERS\"") + 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( ! is.null(mode)){ # all the types are here: https://renenyffenegger.ch/notes/development/languages/R/functions/typeof + if( ! (all(mode %in% c("logical", "numeric", "complex", "character", "list", "expression", "name", "symbol", "function", "environment", "S4", "call")) & base::length(mode) == 1L)){ # all() without na.rm -> ok because mode cannot be NA (tested above) + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"numeric\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"function\", \"environment\", \"S4\", \"call\"") + 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(neg.values == FALSE & mode != "numeric"){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") + 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(inf.values == FALSE & mode != "numeric"){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF inf.values ARGUMENT IS SWITCHED TO FALSE") + 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( ! is.null(length)){ + if( ! (is.numeric(length) & base::length(length) == 1L & all( ! grepl(length, pattern = "\\.")))){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": length ARGUMENT MUST BE A SINGLE INTEGER VALUE") + 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( ! (is.logical(prop) & base::length(prop) == 1L)){ # is.na() already checked for prop + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": prop ARGUMENT MUST BE TRUE OR FALSE ONLY") + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + }else if(prop == TRUE){ + if( ! is.null(class)){ + if( ! any(class %in% c("vector", "numeric", "matrix", "array", "data.frame", "table"))){ # no need of na.rm = TRUE for any() because %in% does not output NA + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN NULL, \"vector\", \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF prop ARGUMENT IS TRUE") # not integer because prop + 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( ! is.null(mode)){ + if(mode != "numeric"){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN NULL OR \"numeric\" IF prop ARGUMENT IS TRUE") + 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( ! is.null(typeof)){ + if(typeof != "double"){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN NULL OR \"double\" IF prop ARGUMENT IS TRUE") + 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( ! (all(base::class(double.as.integer.allowed) == "logical") & base::length(double.as.integer.allowed) == 1L)){ # all() without na.rm -> ok because class() never returns NA + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE double.as.integer.allowed ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(double.as.integer.allowed, collapse = " ")) + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + } + if( ! (is.logical(all.options.in.data) & base::length(all.options.in.data) == 1L)){ + tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": all.options.in.data ARGUMENT MUST BE A SINGLE LOGICAL VALUE (TRUE OR FALSE ONLY): ", paste(all.options.in.data, collapse = " ")) + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + } + if( ! (all(base::class(na.contain) == "logical") & base::length(na.contain) == 1L)){ # all() without na.rm -> ok because class() never returns NA + tempo.cat <- paste0("ERROR IN fun_check(): THE na.contain ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(na.contain, collapse = " ")) + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + } + if( ! (all(base::class(print) == "logical") & base::length(print) == 1L)){ # all() without na.rm -> ok because class() never returns NA + tempo.cat <- paste0("ERROR IN fun_check(): THE print ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(print, collapse = " ")) + stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == + } + # data.name and fun.name tested at the beginning + # end other checkings + # end second round of checking and data preparation + # package checking + # end package checking + # main code + if(is.null(data.name)){ + data.name <- deparse(substitute(data)) + } + problem <- FALSE + text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT") + if(( ! is.null(options)) & (all(base::typeof(data) == "character") | all(base::typeof(data) == "integer") | all(base::typeof(data) == "double"))){ # all() without na.rm -> ok because typeof() never returns NA + if(all(base::typeof(data) == "double")){ + if( ! all(data %% 1 == 0L, na.rm = TRUE)){ + problem <- TRUE + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nBUT IS NOT EVEN TYPE CHARACTER OR INTEGER") + } + }else{ + text <- "" + if( ! all(data %in% options)){ # no need of na.rm = TRUE for all() because %in% does not output NA + problem <- TRUE + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nTHE PROBLEMATIC ELEMENTS OF ", data.name, " ARE: ", paste(unique(data[ ! (data %in% options)]), collapse = " ")) + } + if(all.options.in.data == TRUE){ + if( ! all(options %in% data)){ # no need of na.rm = TRUE for all() because %in% does not output NA + problem <- TRUE + text <- paste0(ifelse(text == "", "", paste0(text, "\n")), ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE MADE OF ALL THESE OPTIONS: ", paste(options, collapse = " "), "\nTHE MISSING ELEMENTS OF THE options ARGUMENT ARE: ", paste(unique(options[ ! (options %in% data)]), collapse = " ")) + } + } + if( ! is.null(length)){ + if(base::length(data) != length){ + problem <- TRUE + text <- paste0(ifelse(text == "", "", paste0(text, "\n")), ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE LENGTH OF ", data.name, " MUST BE ", length, " AND NOT ", base::length(data)) + } + } + if(text == ""){ + text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT") + } + } + }else if( ! is.null(options)){ + problem <- TRUE + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nBUT IS NOT EVEN TYPE CHARACTER OR INTEGER") + } + arg.names <- c("class", "typeof", "mode", "length") + if( ! is.null(class)){ + if(class == "matrix"){ # because of class(matric()) since R4.0.0 + class <- c("matrix", "array") + }else if(class == "factor" & all(base::class(data) %in% c("factor", "ordered"))){ # to deal with ordered factors # all() without na.rm -> ok because class(NA) is "logical" + class <- c("factor", "ordered") + } + } + if(is.null(options)){ + for(i2 in 1:base::length(arg.names)){ + if( ! is.null(get(arg.names[i2], env = sys.nframe(), inherit = FALSE))){ + # script to execute + tempo.script <- ' +problem <- TRUE ; +if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ +text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE ") ; +}else{ +text <- paste0(text, " AND ") ; +} +text <- paste0(text, toupper(arg.names[i2]), " ", if(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) %in% c("matrix", "array"))){"matrix"}else if(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) %in% c("factor", "ordered"))){"factor"}else{get(arg.names[i2], env = sys.nframe(), inherit = FALSE)}) +' # no need of na.rm = TRUE for all() because %in% does not output NA + # end script to execute + if(base::typeof(data) == "double" & double.as.integer.allowed == TRUE & ((arg.names[i2] == "class" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "integer")) | (arg.names[i2] == "typeof" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "integer")))){ # no need of na.rm = TRUE for all() because == does not output NA if no NA in left of ==, which is the case for arg.names # typeof(data) == "double" means no factor allowed + if( ! all(data %% 1 == 0L, na.rm = TRUE)){ # to check integers (use %%, meaning the remaining of a division): see the precedent line. isTRUE(all.equal(data%%1, rep(0, length(data)))) not used because we strictly need zero as a result. Warning: na.rm = TRUE required here for all() + eval(parse(text = tempo.script)) # execute tempo.script + } + }else if( ! any(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) %in% c("vector", "ggplot2"))) & ! all(eval(parse(text = paste0(arg.names[i2], "(data)"))) %in% get(arg.names[i2], env = sys.nframe(), inherit = FALSE))){ # test the four c("class", "typeof", "mode", "length") arguments with their corresponding function. No need of na.rm = TRUE for all() because %in% does not output NA # no need of na.rm = TRUE for all() because %in% does not output NA # no need of na.rm = TRUE for any() because get get(arg.names) does not contain NA + eval(parse(text = tempo.script)) # execute tempo.script + }else if(arg.names[i2] == "class" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "vector") & ! (all(base::class(data) %in% "numeric") | all(base::class(data) %in% "integer") | all(base::class(data) %in% "character") | all(base::class(data) %in% "logical"))){ # test class == "vector". No need of na.rm = TRUE for all() because %in% does not output NA # no need of na.rm = TRUE for all() because == does not output NA if no NA in left of ==, which is the case for arg.names + eval(parse(text = tempo.script)) # execute tempo.script + }else if(arg.names[i2] == "class" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "ggplot2") & ! all(base::class(data) %in% c("gg", "ggplot"))){ # test ggplot object # no need of na.rm = TRUE for all() because == does not output NA if no NA in left of ==, which is the case for arg.names # no need of na.rm = TRUE for all() because %in% does not output NA + eval(parse(text = tempo.script)) # execute tempo.script + } + } + } + } +if(prop == TRUE & all(base::typeof(data) == "double")){ # all() without na.rm -> ok because typeof(NA) is "logical" + if(is.null(data) | any(data < 0 | data > 1, na.rm = TRUE)){ # works if data is NULL # Warning: na.rm = TRUE required here for any() # typeof(data) == "double" means no factor allowed + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT MUST BE DECIMAL VALUES BETWEEN 0 AND 1") + } +}else if(prop == TRUE){ + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT MUST BE DECIMAL VALUES BETWEEN 0 AND 1") +} +if(all(base::class(data) %in% "expression")){ # no need of na.rm = TRUE for all() because %in% does not output NA + data <- as.character(data) # to evaluate the presence of NA +} +if(na.contain == FALSE & (base::mode(data) %in% c("logical", "numeric", "complex", "character", "list"))){ # before it was ! (class(data) %in% c("function", "environment")) + if(any(is.na(data)) == TRUE){ # not on the same line because when data is class envir or function , do not like that # normally no NA with is.na() + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT CONTAINS NA WHILE NOT AUTHORIZED") + } +} +if(neg.values == FALSE & all(base::mode(data) %in% "numeric") & ! any(base::class(data) %in% "factor")){ # no need of na.rm = TRUE for all() because %in% does not output NA + if(any(data < 0, na.rm = TRUE)){ # Warning: na.rm = TRUE required here for any() + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON NEGATIVE NUMERIC VALUES") + } +}else if(neg.values == FALSE){ + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON NEGATIVE VALUES BUT IS ", ifelse(any(base::class(data) %in% "factor"), "A FACTOR", "NOT EVEN MODE NUMERIC")) +} +if(inf.values == FALSE & all(base::typeof(data) %in% "double") & ! any(base::class(data) %in% "factor")){ # no need of na.rm = TRUE for all() because %in% does not output NA + if(any(is.infinite(data), na.rm = TRUE)){ # Warning: na.rm = TRUE required here for any() + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON INFINITE NUMERIC VALUES") + } +}else if(inf.values == FALSE){ + problem <- TRUE + if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ + text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") + }else{ + text <- paste0(text, " AND ") + } + text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON INFINITE VALUES BUT IS ", ifelse(any(base::class(data) %in% "factor"), "A FACTOR", "NOT EVEN TYPE DOUBLE")) +} +if(print == TRUE & problem == TRUE){ + cat(paste0("\n\n================\n\n", text, "\n\n================\n\n")) +} +# output +output <- list(problem = problem, text = text, object.name = data.name) +return(output) +# end output +# end main code +} + +library(roxygen2) +roxygenise() + diff --git a/README.md b/README.md deleted file mode 100644 index f16ae8931c0c8b16c62b8543f3f8e3b71b1d101b..0000000000000000000000000000000000000000 --- a/README.md +++ /dev/null @@ -1,92 +0,0 @@ -# cute - - - -## Getting started - -To make it easy for you to get started with GitLab, here's a list of recommended next steps. - -Already a pro? Just edit this README.md and make it your own. Want to make it easy? [Use the template at the bottom](#editing-this-readme)! - -## Add your files - -- [ ] [Create](https://docs.gitlab.com/ee/user/project/repository/web_editor.html#create-a-file) or [upload](https://docs.gitlab.com/ee/user/project/repository/web_editor.html#upload-a-file) files -- [ ] [Add files using the command line](https://docs.gitlab.com/ee/gitlab-basics/add-file.html#add-a-file-using-the-command-line) or push an existing Git repository with the following command: - -``` -cd existing_repo -git remote add origin https://gitlab.pasteur.fr/yhan/cute.git -git branch -M main -git push -uf origin main -``` - -## Integrate with your tools - -- [ ] [Set up project integrations](https://gitlab.pasteur.fr/yhan/cute/-/settings/integrations) - -## Collaborate with your team - -- [ ] [Invite team members and collaborators](https://docs.gitlab.com/ee/user/project/members/) -- [ ] [Create a new merge request](https://docs.gitlab.com/ee/user/project/merge_requests/creating_merge_requests.html) -- [ ] [Automatically close issues from merge requests](https://docs.gitlab.com/ee/user/project/issues/managing_issues.html#closing-issues-automatically) -- [ ] [Enable merge request approvals](https://docs.gitlab.com/ee/user/project/merge_requests/approvals/) -- [ ] [Set auto-merge](https://docs.gitlab.com/ee/user/project/merge_requests/merge_when_pipeline_succeeds.html) - -## Test and Deploy - -Use the built-in continuous integration in GitLab. - -- [ ] [Get started with GitLab CI/CD](https://docs.gitlab.com/ee/ci/quick_start/index.html) -- [ ] [Analyze your code for known vulnerabilities with Static Application Security Testing(SAST)](https://docs.gitlab.com/ee/user/application_security/sast/) -- [ ] [Deploy to Kubernetes, Amazon EC2, or Amazon ECS using Auto Deploy](https://docs.gitlab.com/ee/topics/autodevops/requirements.html) -- [ ] [Use pull-based deployments for improved Kubernetes management](https://docs.gitlab.com/ee/user/clusters/agent/) -- [ ] [Set up protected environments](https://docs.gitlab.com/ee/ci/environments/protected_environments.html) - -*** - -# Editing this README - -When you're ready to make this README your own, just edit this file and use the handy template below (or feel free to structure it however you want - this is just a starting point!). Thank you to [makeareadme.com](https://www.makeareadme.com/) for this template. - -## Suggestions for a good README -Every project is different, so consider which of these sections apply to yours. The sections used in the template are suggestions for most open source projects. Also keep in mind that while a README can be too long and detailed, too long is better than too short. If you think your README is too long, consider utilizing another form of documentation rather than cutting out information. - -## Name -Choose a self-explaining name for your project. - -## Description -Let people know what your project can do specifically. Provide context and add a link to any reference visitors might be unfamiliar with. A list of Features or a Background subsection can also be added here. If there are alternatives to your project, this is a good place to list differentiating factors. - -## Badges -On some READMEs, you may see small images that convey metadata, such as whether or not all the tests are passing for the project. You can use Shields to add some to your README. Many services also have instructions for adding a badge. - -## Visuals -Depending on what you are making, it can be a good idea to include screenshots or even a video (you'll frequently see GIFs rather than actual videos). Tools like ttygif can help, but check out Asciinema for a more sophisticated method. - -## Installation -Within a particular ecosystem, there may be a common way of installing things, such as using Yarn, NuGet, or Homebrew. However, consider the possibility that whoever is reading your README is a novice and would like more guidance. Listing specific steps helps remove ambiguity and gets people to using your project as quickly as possible. If it only runs in a specific context like a particular programming language version or operating system or has dependencies that have to be installed manually, also add a Requirements subsection. - -## Usage -Use examples liberally, and show the expected output if you can. It's helpful to have inline the smallest example of usage that you can demonstrate, while providing links to more sophisticated examples if they are too long to reasonably include in the README. - -## Support -Tell people where they can go to for help. It can be any combination of an issue tracker, a chat room, an email address, etc. - -## Roadmap -If you have ideas for releases in the future, it is a good idea to list them in the README. - -## Contributing -State if you are open to contributions and what your requirements are for accepting them. - -For people who want to make changes to your project, it's helpful to have some documentation on how to get started. Perhaps there is a script that they should run or some environment variables that they need to set. Make these steps explicit. These instructions could also be useful to your future self. - -You can also document commands to lint the code or run tests. These steps help to ensure high code quality and reduce the likelihood that the changes inadvertently break something. Having instructions for running tests is especially helpful if it requires external setup, such as starting a Selenium server for testing in a browser. - -## Authors and acknowledgment -Show your appreciation to those who have contributed to the project. - -## License -For open source projects, say how it is licensed. - -## Project status -If you have run out of energy or time for your project, put a note at the top of the README saying that development has slowed down or stopped completely. Someone may choose to fork your project or volunteer to step in as a maintainer or owner, allowing your project to keep going. You can also make an explicit request for maintainers. diff --git a/check.R b/check.R deleted file mode 100644 index ebabce7d09e84919998adf25b1410622ca37f3a6..0000000000000000000000000000000000000000 --- a/check.R +++ /dev/null @@ -1,478 +0,0 @@ - -######## fun_check() #### check class, type, length, etc., of objects - - -# todo list check OK -# Check r_debugging_tools-v1.4.R OK -# Check fun_test() 20201107 (see cute_checks.docx) OK -# example sheet OK -# check all and any OK -# -> clear to go Apollo -# -> transferred into the cute package -# Do not modify this function in cute_little_R_function anymore. See the cute repo -fun_check <- function( - data, - class = NULL, - 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 -){ - # AIM - # Check the class, type, mode and length of the data argument - # Mainly used to check the arguments of other functions - # Check also other kind of data parameters, is it a proportion? Is it type double but numbers without decimal part? - # If options == NULL, then at least class or type or mode or length argument must be non-null - # If options is non-null, then class, type and mode must be NULL, and length can be NULL or specified - # WARNINGS - # The function tests what is written in its arguments, even if what is written is incoherent. For instance, fun_check(data = factor(1), class = "factor", mode = "character") will return a problem, whatever the object tested in the data argument, because no object can be class "factor" and mode "character" (factors are class "factor" and mode "numeric"). Of note, length of object of class "environment" is always 0 - # If the tested object is NULL, then the function will always return a checking problem - # Since R >= 4.0.0, class(matrix()) returns "matrix" "array", and not "matrix" alone as before. However, use argument class = "matrix" to check for matrix object (of class "matrix" "array" in R >= 4.0.0) and use argument class = "array" to check for array object (of class "array" in R >= 4.0.0) - # ARGUMENTS - # data: object to test - # class: character string. Either one of the class() result (But see the warning section above) or "vector" or "ggplot2" (i.e., objects of class c("gg", "ggplot")) or NULL - # typeof: character string. Either one of the typeof() result or NULL - # mode: character string. Either one of the mode() result (for non-vector object) or NULL - # length: numeric value indicating the length of the object. Not considered if NULL - # prop: logical. Are the numeric values between 0 and 1 (proportion)? If TRUE, can be used alone, without considering class, etc. - # double.as.integer.allowed: logical. If TRUE, no error is reported in the cheking message if argument is set to typeof == "integer" or class == "integer", while the reality is typeof == "double" or class == "numeric" but the numbers strictly have zero as modulo (remainder of a division). This means that i <- 1, which is typeof(i) -> "double" is considered as integer with double.as.integer.allowed = TRUE. WARNING: data%%1 == 0L but not isTRUE(all.equal(data%%1, 0)) is used here because the argument checks for integers stored as double (does not check for decimal numbers that are approximate integers) - # options: a vector of character strings or integers indicating all the possible option values for the data argument, or NULL. Numbers of type "double" are accepted if they have a 0 modulo - # all.options.in.data: logical. If TRUE, all of the options must be present at least once in the data argument, and nothing else. If FALSE, some or all of the options must be present in the data argument, and nothing else. Ignored if options is NULL - # na.contain: logical. Can the data argument contain NA? - # neg.values: logical. Are negative numeric values authorized? Warning: the default setting is TRUE, meaning that, in that case, no check is performed for the presence of negative values. The neg.values argument is activated only when set to FALSE. In addition, (1) neg.values = FALSE can only be used when class, typeof or mode arguments are not NULL, otherwise return an error message, (2) the presence of negative values is not checked with neg.values = FALSE if the tested object is a factor and the following checking message is returned "OBJECT MUST BE MADE OF NON NEGATIVE VALUES BUT IS A FACTOR" - # inf.values: logical. Are infinite numeric values authorized (Inf or -Inf)? Identical remarks as for the neg.values argument - # print: logical. Print the message if $problem is TRUE? Warning: set by default to FALSE, which facilitates the control of the checking message output when using fun_check() inside functions. See the example section - # data.name: character string indicating the name of the object to test. If NULL, use what is assigned to the data argument for the returned message - # fun.name: character string indicating the name of the function checked (i.e., when fun_check() is used to check the arguments of this function). If non-null, the value of fun.name will be added into the message returned by fun_check() - # RETURN - # A list containing: - # $problem: logical. Is there any problem detected? - # $text: message indicating the details of the problem, or the absence of problem - # $object.name: value of the data.name argument (i.e., name of the checked object if provided, NULL otherwise) - # REQUIRED PACKAGES - # None - # REQUIRED FUNCTIONS FROM THE cute PACKAGE - # None - # EXAMPLE - # test <- matrix(1:3) ; fun_check(data = test, print = TRUE, class = "vector", mode = "numeric") - # see http - # DEBUGGING - # data = mean ; class = NULL ; typeof = NULL ; mode = NULL ; length = NULL ; prop = FALSE ; double.as.integer.allowed = FALSE ; options = "a" ; all.options.in.data = FALSE ; na.contain = FALSE ; neg.values = TRUE ; inf.values = TRUE ; print = TRUE ; data.name = NULL ; fun.name = NULL - # function name - # no used in this function for the error message, to avoid env colliding - # end function name - # required function checking - # end required function checking - # reserved words - # end reserved words - # fun.name checked first because required next - if( ! is.null(fun.name)){ # I have to use this way to deal with every kind of class for fun.name - if(all(base::class(fun.name) == "character")){ # all() without na.rm -> ok because class(NA) is "logical" - if(base::length(fun.name) != 1){ - tempo.cat <- paste0("ERROR IN fun_check(): THE fun.name ARGUMENT MUST BE A CHARACTER VECTOR OF LENGTH 1: ", paste(fun.name, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - }else if(any(is.na(fun.name))){ # normally no NA with is.na() - tempo.cat <- paste0("ERROR IN fun_check(): NO ARGUMENT EXCEPT data AND options CAN HAVE NA VALUES\nPROBLEMATIC ARGUMENT IS fun.name") - 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{ - tempo.cat <- paste0("ERROR IN fun_check(): THE fun.name ARGUMENT MUST BE A CHARACTER VECTOR OF LENGTH 1") # paste(fun.name, collapse = " ") removed here because does not work with objects like function - 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 fun.name checked first because required next - # arg with no default values - mandat.args <- c( - "data" - ) - tempo <- eval(parse(text = paste0("c(missing(", paste0(mandat.args, collapse = "), missing("), "))"))) - if(any(tempo)){ # normally no NA for missing() output - tempo.cat <- paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", ifelse(sum(tempo, na.rm = TRUE) > 1, "S HAVE", " HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", paste0(mandat.args[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 - # source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.7/r_debugging_tools-v1.7.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status - # end argument primary checking - # second round of checking and data preparation - # management of special classes - basic.class <- c( - "NULL", # because class(NULL) is "NULL". The NULL aspect will be dealt later - "logical", - "integer", - "numeric", - # "complex", - "character" - # "matrix", - # "array", - # "data.frame", - # "list", - # "factor", - # "table", - # "expression", - # "name", - # "symbol", - # "function", - # "uneval", - # "environment", - # "ggplot2", - # "ggplot_built", - # "call" - ) - tempo.arg.base <-c( # no names(formals(fun = sys.function(sys.parent(n = 2)))) used with fun_check() to be sure to deal with the correct environment - "class", - "typeof", - "mode", - "length", - "prop", - "double.as.integer.allowed", - "options", - "all.options.in.data", - "na.contain", - "neg.values", - "inf.values", - "print", - "data.name", - "fun.name" - ) - tempo.class <-list( # no get() used to be sure to deal with the correct environment - base::class(class), - base::class(typeof), - base::class(mode), - base::class(length), - base::class(prop), - base::class(double.as.integer.allowed), - base::class(options), - base::class(all.options.in.data), - base::class(na.contain), - base::class(neg.values), - base::class(inf.values), - base::class(print), - base::class(data.name), - base::class(fun.name) - ) - tempo <- ! sapply(lapply(tempo.class, FUN = "%in%", basic.class), FUN = all) - if(any(tempo)){ - tempo.cat1 <- tempo.arg.base[tempo] - tempo.cat2 <- sapply(tempo.class[tempo], FUN = paste0, collapse = " ") - tempo.sep <- sapply(mapply(" ", max(nchar(tempo.cat1)) - nchar(tempo.cat1) + 3, FUN = rep, SIMPLIFY = FALSE), FUN = paste0, collapse = "") - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": ANY ARGUMENT EXCEPT data MUST HAVE A BASIC CLASS\nPROBLEMATIC ARGUMENT", ifelse(base::length(tempo.cat1) > 1, "S", ""), " AND ASSOCIATED CLASS", ifelse(base::length(tempo.cat1) > 1, "ES ARE", " IS"), ":\n", paste0(tempo.cat1, tempo.sep, tempo.cat2, collapse = "\n")) # normally no NA with is.na() - 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 special classes - # management of NA arguments - if(any(is.na(data.name)) | any(is.na(class)) | any(is.na(typeof)) | any(is.na(mode)) | any(is.na(length)) | any(is.na(prop)) | any(is.na(double.as.integer.allowed)) | any(is.na(all.options.in.data)) | any(is.na(na.contain)) | any(is.na(neg.values)) | any(is.na(inf.values)) | any(is.na(print)) | any(is.na(fun.name))){ # normally no NA with is.na() - tempo <- c("data.name", "class", "typeof", "mode", "length", "prop", "double.as.integer.allowed", "all.options.in.data", "na.contain", "neg.values", "inf.values", "print", "fun.name")[c(any(is.na(data.name)), any(is.na(class)), any(is.na(typeof)), any(is.na(mode)), any(is.na(length)), any(is.na(prop)), any(is.na(double.as.integer.allowed)), any(is.na(all.options.in.data)), any(is.na(na.contain)), any(is.na(neg.values)), any(is.na(inf.values)), any(is.na(print)), any(is.na(fun.name)))] - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": NO ARGUMENT EXCEPT data AND options CAN HAVE NA VALUES\nPROBLEMATIC ARGUMENT", ifelse(length(tempo) > 1, "S ARE", " IS"), ":\n", paste(tempo, collapse = "\n")) # normally no NA with is.na() - 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( - "prop", - "double.as.integer.allowed", - "all.options.in.data", - "na.contain", - "neg.values", - "inf.values", - "print" - ) - 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 fun.check():\n", ifelse(sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT BE NULL:\n", 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 - # dealing with logical - # tested below - # end dealing with logical - # 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( ! is.null(data.name)){ - if( ! (base::length(data.name) == 1L & all(base::class(data.name) == "character"))){ # all() without na.rm -> ok because class(NA) is "logical" - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": data.name ARGUMENT MUST BE A SINGLE CHARACTER ELEMENT AND NOT ", paste(data.name, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - } - } - if(is.null(options) & is.null(class) & is.null(typeof) & is.null(mode) & prop == FALSE & is.null(length)){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": AT LEAST ONE OF THE options, class, typeof, mode, prop, OR length ARGUMENT MUST BE SPECIFIED (I.E, TRUE FOR prop)") - 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( ! is.null(options) & ( ! is.null(class) | ! is.null(typeof) | ! is.null(mode) | prop == TRUE)){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE class, typeof, mode ARGUMENTS MUST BE NULL, AND prop FALSE, IF THE options ARGUMENT IS SPECIFIED\nTHE options ARGUMENT MUST BE NULL IF THE class AND/OR typeof AND/OR mode AND/OR prop ARGUMENT IS SPECIFIED") - 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( ! (all(base::class(neg.values) == "logical") & base::length(neg.values) == 1L)){ # all() without na.rm -> ok because class(NA) is "logical" - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE neg.values ARGUMENT MUST BE TRUE OR FALSE ONLY") - 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(neg.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE neg.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE 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 == - } - if( ! (all(base::class(inf.values) == "logical") & base::length(inf.values) == 1L)){ # all() without na.rm -> ok because class(NA) is "logical" - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE inf.values ARGUMENT MUST BE TRUE OR FALSE ONLY") - 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(inf.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE inf.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE 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 == - } - if( ! is.null(class)){ # may add "formula" and "Date" as in https://renenyffenegger.ch/notes/development/languages/R/functions/class - if( ! all(class %in% c("vector", "logical", "integer", "numeric", "complex", "character", "matrix", "array", "data.frame", "list", "factor", "table", "expression", "name", "symbol", "function", "uneval", "environment", "ggplot2", "ggplot_built", "call") & base::length(class) == 1L)){ # length == 1L here because of class(matrix()) since R4.0.0 # all() without na.rm -> ok because class cannot be NA (tested above) - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT MUST BE ONE OF THESE VALUE:\n\"vector\", \"logical\", \"integer\", \"numeric\", \"complex\", \"character\", \"matrix\", \"array\", \"data.frame\", \"list\", \"factor\", \"table\", \"expression\", \"name\", \"symbol\", \"function\", \"environment\", \"ggplot2\", \"ggplot_built\", \"call\"") - 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(neg.values == FALSE & ! any(class %in% c("vector", "numeric", "integer", "matrix", "array", "data.frame", "table"))){ # no need of na.rm = TRUE for any() because %in% does not output NA - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"integer\", \"matrix\", \"array\", \"data.frame\", \"table\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") - 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(inf.values == FALSE & ! any(class %in% c("vector", "numeric", "matrix", "array", "data.frame", "table"))){ # no need of na.rm = TRUE for any() because %in% does not output NA - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF inf.values ARGUMENT IS SWITCHED TO FALSE. \"integer IS NOT ALLOWED BECAUSE IFINITE VALUES ARE NOT INTEGERS\"") - 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( ! is.null(typeof)){ # all the types are here: https://renenyffenegger.ch/notes/development/languages/R/functions/typeof - if( ! (all(typeof %in% c("logical", "integer", "double", "complex", "character", "list", "expression", "symbol", "closure", "special", "builtin", "environment", "S4", "language")) & base::length(typeof) == 1L)){ # "language" is the type of object of class "call" # all() without na.rm -> ok because typeof cannot be NA (tested above) - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"integer\", \"double\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"closure\", \"special\", \"builtin\", \"environment\", \"S4\", \"language\"") - 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(neg.values == FALSE & ! typeof %in% c("double", "integer")){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN \"double\" OR \"integer\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") - 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(inf.values == FALSE & typeof != "double"){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN \"double\" IF inf.values ARGUMENT IS SWITCHED TO FALSE. \"integer IS NOT ALLOWED BECAUSE IFINITE VALUES ARE NOT INTEGERS\"") - 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( ! is.null(mode)){ # all the types are here: https://renenyffenegger.ch/notes/development/languages/R/functions/typeof - if( ! (all(mode %in% c("logical", "numeric", "complex", "character", "list", "expression", "name", "symbol", "function", "environment", "S4", "call")) & base::length(mode) == 1L)){ # all() without na.rm -> ok because mode cannot be NA (tested above) - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"numeric\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"function\", \"environment\", \"S4\", \"call\"") - 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(neg.values == FALSE & mode != "numeric"){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") - 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(inf.values == FALSE & mode != "numeric"){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF inf.values ARGUMENT IS SWITCHED TO FALSE") - 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( ! is.null(length)){ - if( ! (is.numeric(length) & base::length(length) == 1L & all( ! grepl(length, pattern = "\\.")))){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": length ARGUMENT MUST BE A SINGLE INTEGER VALUE") - 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( ! (is.logical(prop) & base::length(prop) == 1L)){ # is.na() already checked for prop - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": prop ARGUMENT MUST BE TRUE OR FALSE ONLY") - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - }else if(prop == TRUE){ - if( ! is.null(class)){ - if( ! any(class %in% c("vector", "numeric", "matrix", "array", "data.frame", "table"))){ # no need of na.rm = TRUE for any() because %in% does not output NA - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN NULL, \"vector\", \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF prop ARGUMENT IS TRUE") # not integer because prop - 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( ! is.null(mode)){ - if(mode != "numeric"){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN NULL OR \"numeric\" IF prop ARGUMENT IS TRUE") - 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( ! is.null(typeof)){ - if(typeof != "double"){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN NULL OR \"double\" IF prop ARGUMENT IS TRUE") - 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( ! (all(base::class(double.as.integer.allowed) == "logical") & base::length(double.as.integer.allowed) == 1L)){ # all() without na.rm -> ok because class() never returns NA - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE double.as.integer.allowed ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(double.as.integer.allowed, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - } - if( ! (is.logical(all.options.in.data) & base::length(all.options.in.data) == 1L)){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": all.options.in.data ARGUMENT MUST BE A SINGLE LOGICAL VALUE (TRUE OR FALSE ONLY): ", paste(all.options.in.data, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - } - if( ! (all(base::class(na.contain) == "logical") & base::length(na.contain) == 1L)){ # all() without na.rm -> ok because class() never returns NA - tempo.cat <- paste0("ERROR IN fun_check(): THE na.contain ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(na.contain, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - } - if( ! (all(base::class(print) == "logical") & base::length(print) == 1L)){ # all() without na.rm -> ok because class() never returns NA - tempo.cat <- paste0("ERROR IN fun_check(): THE print ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(print, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - } - # data.name and fun.name tested at the beginning - # end other checkings - # end second round of checking and data preparation - # package checking - # end package checking - # main code - if(is.null(data.name)){ - data.name <- deparse(substitute(data)) - } - problem <- FALSE - text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT") - if(( ! is.null(options)) & (all(base::typeof(data) == "character") | all(base::typeof(data) == "integer") | all(base::typeof(data) == "double"))){ # all() without na.rm -> ok because typeof() never returns NA - if(all(base::typeof(data) == "double")){ - if( ! all(data %% 1 == 0L, na.rm = TRUE)){ - problem <- TRUE - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nBUT IS NOT EVEN TYPE CHARACTER OR INTEGER") - } - }else{ - text <- "" - if( ! all(data %in% options)){ # no need of na.rm = TRUE for all() because %in% does not output NA - problem <- TRUE - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nTHE PROBLEMATIC ELEMENTS OF ", data.name, " ARE: ", paste(unique(data[ ! (data %in% options)]), collapse = " ")) - } - if(all.options.in.data == TRUE){ - if( ! all(options %in% data)){ # no need of na.rm = TRUE for all() because %in% does not output NA - problem <- TRUE - text <- paste0(ifelse(text == "", "", paste0(text, "\n")), ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE MADE OF ALL THESE OPTIONS: ", paste(options, collapse = " "), "\nTHE MISSING ELEMENTS OF THE options ARGUMENT ARE: ", paste(unique(options[ ! (options %in% data)]), collapse = " ")) - } - } - if( ! is.null(length)){ - if(base::length(data) != length){ - problem <- TRUE - text <- paste0(ifelse(text == "", "", paste0(text, "\n")), ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE LENGTH OF ", data.name, " MUST BE ", length, " AND NOT ", base::length(data)) - } - } - if(text == ""){ - text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT") - } - } - }else if( ! is.null(options)){ - problem <- TRUE - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nBUT IS NOT EVEN TYPE CHARACTER OR INTEGER") - } - arg.names <- c("class", "typeof", "mode", "length") - if( ! is.null(class)){ - if(class == "matrix"){ # because of class(matric()) since R4.0.0 - class <- c("matrix", "array") - }else if(class == "factor" & all(base::class(data) %in% c("factor", "ordered"))){ # to deal with ordered factors # all() without na.rm -> ok because class(NA) is "logical" - class <- c("factor", "ordered") - } - } - if(is.null(options)){ - for(i2 in 1:base::length(arg.names)){ - if( ! is.null(get(arg.names[i2], env = sys.nframe(), inherit = FALSE))){ - # script to execute - tempo.script <- ' -problem <- TRUE ; -if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ -text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE ") ; -}else{ -text <- paste0(text, " AND ") ; -} -text <- paste0(text, toupper(arg.names[i2]), " ", if(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) %in% c("matrix", "array"))){"matrix"}else if(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) %in% c("factor", "ordered"))){"factor"}else{get(arg.names[i2], env = sys.nframe(), inherit = FALSE)}) -' # no need of na.rm = TRUE for all() because %in% does not output NA - # end script to execute - if(base::typeof(data) == "double" & double.as.integer.allowed == TRUE & ((arg.names[i2] == "class" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "integer")) | (arg.names[i2] == "typeof" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "integer")))){ # no need of na.rm = TRUE for all() because == does not output NA if no NA in left of ==, which is the case for arg.names # typeof(data) == "double" means no factor allowed - if( ! all(data %% 1 == 0L, na.rm = TRUE)){ # to check integers (use %%, meaning the remaining of a division): see the precedent line. isTRUE(all.equal(data%%1, rep(0, length(data)))) not used because we strictly need zero as a result. Warning: na.rm = TRUE required here for all() - eval(parse(text = tempo.script)) # execute tempo.script - } - }else if( ! any(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) %in% c("vector", "ggplot2"))) & ! all(eval(parse(text = paste0(arg.names[i2], "(data)"))) %in% get(arg.names[i2], env = sys.nframe(), inherit = FALSE))){ # test the four c("class", "typeof", "mode", "length") arguments with their corresponding function. No need of na.rm = TRUE for all() because %in% does not output NA # no need of na.rm = TRUE for all() because %in% does not output NA # no need of na.rm = TRUE for any() because get get(arg.names) does not contain NA - eval(parse(text = tempo.script)) # execute tempo.script - }else if(arg.names[i2] == "class" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "vector") & ! (all(base::class(data) %in% "numeric") | all(base::class(data) %in% "integer") | all(base::class(data) %in% "character") | all(base::class(data) %in% "logical"))){ # test class == "vector". No need of na.rm = TRUE for all() because %in% does not output NA # no need of na.rm = TRUE for all() because == does not output NA if no NA in left of ==, which is the case for arg.names - eval(parse(text = tempo.script)) # execute tempo.script - }else if(arg.names[i2] == "class" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "ggplot2") & ! all(base::class(data) %in% c("gg", "ggplot"))){ # test ggplot object # no need of na.rm = TRUE for all() because == does not output NA if no NA in left of ==, which is the case for arg.names # no need of na.rm = TRUE for all() because %in% does not output NA - eval(parse(text = tempo.script)) # execute tempo.script - } - } - } - } -if(prop == TRUE & all(base::typeof(data) == "double")){ # all() without na.rm -> ok because typeof(NA) is "logical" - if(is.null(data) | any(data < 0 | data > 1, na.rm = TRUE)){ # works if data is NULL # Warning: na.rm = TRUE required here for any() # typeof(data) == "double" means no factor allowed - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE DECIMAL VALUES BETWEEN 0 AND 1") - } -}else if(prop == TRUE){ - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE DECIMAL VALUES BETWEEN 0 AND 1") -} -if(all(base::class(data) %in% "expression")){ # no need of na.rm = TRUE for all() because %in% does not output NA - data <- as.character(data) # to evaluate the presence of NA -} -if(na.contain == FALSE & (base::mode(data) %in% c("logical", "numeric", "complex", "character", "list"))){ # before it was ! (class(data) %in% c("function", "environment")) - if(any(is.na(data)) == TRUE){ # not on the same line because when data is class envir or function , do not like that # normally no NA with is.na() - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT CONTAINS NA WHILE NOT AUTHORIZED") - } -} -if(neg.values == FALSE & all(base::mode(data) %in% "numeric") & ! any(base::class(data) %in% "factor")){ # no need of na.rm = TRUE for all() because %in% does not output NA - if(any(data < 0, na.rm = TRUE)){ # Warning: na.rm = TRUE required here for any() - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON NEGATIVE NUMERIC VALUES") - } -}else if(neg.values == FALSE){ - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON NEGATIVE VALUES BUT IS ", ifelse(any(base::class(data) %in% "factor"), "A FACTOR", "NOT EVEN MODE NUMERIC")) -} -if(inf.values == FALSE & all(base::typeof(data) %in% "double") & ! any(base::class(data) %in% "factor")){ # no need of na.rm = TRUE for all() because %in% does not output NA - if(any(is.infinite(data), na.rm = TRUE)){ # Warning: na.rm = TRUE required here for any() - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON INFINITE NUMERIC VALUES") - } -}else if(inf.values == FALSE){ - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON INFINITE VALUES BUT IS ", ifelse(any(base::class(data) %in% "factor"), "A FACTOR", "NOT EVEN TYPE DOUBLE")) -} -if(print == TRUE & problem == TRUE){ - cat(paste0("\n\n================\n\n", text, "\n\n================\n\n")) -} -# output -output <- list(problem = problem, text = text, object.name = data.name) -return(output) -# end output -# end main code -} diff --git a/checkFunctions/DESCRIPTION b/checkFunctions/DESCRIPTION deleted file mode 100644 index 4cac8f6a162274f61630e85a6b4b2cbb5ca95d49..0000000000000000000000000000000000000000 --- a/checkFunctions/DESCRIPTION +++ /dev/null @@ -1,10 +0,0 @@ -Package: checkFunctions -Type: Package -Title: What the package does (short line) -Version: 1.0 -Date: 2023-08-29 -Author: Who wrote it -Maintainer: Who to complain to <yourfault@somewhere.net> -Description: More about what it does (maybe more than one line) -License: What license is it under? -RoxygenNote: 7.2.3 diff --git a/checkFunctions/NAMESPACE b/checkFunctions/NAMESPACE deleted file mode 100644 index 5449867d7eb24a261e0a05fbcd8bc2d4f45af124..0000000000000000000000000000000000000000 --- a/checkFunctions/NAMESPACE +++ /dev/null @@ -1 +0,0 @@ -export("fun_check") diff --git a/checkFunctions/R/check.R b/checkFunctions/R/check.R deleted file mode 100644 index ebabce7d09e84919998adf25b1410622ca37f3a6..0000000000000000000000000000000000000000 --- a/checkFunctions/R/check.R +++ /dev/null @@ -1,478 +0,0 @@ - -######## fun_check() #### check class, type, length, etc., of objects - - -# todo list check OK -# Check r_debugging_tools-v1.4.R OK -# Check fun_test() 20201107 (see cute_checks.docx) OK -# example sheet OK -# check all and any OK -# -> clear to go Apollo -# -> transferred into the cute package -# Do not modify this function in cute_little_R_function anymore. See the cute repo -fun_check <- function( - data, - class = NULL, - 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 -){ - # AIM - # Check the class, type, mode and length of the data argument - # Mainly used to check the arguments of other functions - # Check also other kind of data parameters, is it a proportion? Is it type double but numbers without decimal part? - # If options == NULL, then at least class or type or mode or length argument must be non-null - # If options is non-null, then class, type and mode must be NULL, and length can be NULL or specified - # WARNINGS - # The function tests what is written in its arguments, even if what is written is incoherent. For instance, fun_check(data = factor(1), class = "factor", mode = "character") will return a problem, whatever the object tested in the data argument, because no object can be class "factor" and mode "character" (factors are class "factor" and mode "numeric"). Of note, length of object of class "environment" is always 0 - # If the tested object is NULL, then the function will always return a checking problem - # Since R >= 4.0.0, class(matrix()) returns "matrix" "array", and not "matrix" alone as before. However, use argument class = "matrix" to check for matrix object (of class "matrix" "array" in R >= 4.0.0) and use argument class = "array" to check for array object (of class "array" in R >= 4.0.0) - # ARGUMENTS - # data: object to test - # class: character string. Either one of the class() result (But see the warning section above) or "vector" or "ggplot2" (i.e., objects of class c("gg", "ggplot")) or NULL - # typeof: character string. Either one of the typeof() result or NULL - # mode: character string. Either one of the mode() result (for non-vector object) or NULL - # length: numeric value indicating the length of the object. Not considered if NULL - # prop: logical. Are the numeric values between 0 and 1 (proportion)? If TRUE, can be used alone, without considering class, etc. - # double.as.integer.allowed: logical. If TRUE, no error is reported in the cheking message if argument is set to typeof == "integer" or class == "integer", while the reality is typeof == "double" or class == "numeric" but the numbers strictly have zero as modulo (remainder of a division). This means that i <- 1, which is typeof(i) -> "double" is considered as integer with double.as.integer.allowed = TRUE. WARNING: data%%1 == 0L but not isTRUE(all.equal(data%%1, 0)) is used here because the argument checks for integers stored as double (does not check for decimal numbers that are approximate integers) - # options: a vector of character strings or integers indicating all the possible option values for the data argument, or NULL. Numbers of type "double" are accepted if they have a 0 modulo - # all.options.in.data: logical. If TRUE, all of the options must be present at least once in the data argument, and nothing else. If FALSE, some or all of the options must be present in the data argument, and nothing else. Ignored if options is NULL - # na.contain: logical. Can the data argument contain NA? - # neg.values: logical. Are negative numeric values authorized? Warning: the default setting is TRUE, meaning that, in that case, no check is performed for the presence of negative values. The neg.values argument is activated only when set to FALSE. In addition, (1) neg.values = FALSE can only be used when class, typeof or mode arguments are not NULL, otherwise return an error message, (2) the presence of negative values is not checked with neg.values = FALSE if the tested object is a factor and the following checking message is returned "OBJECT MUST BE MADE OF NON NEGATIVE VALUES BUT IS A FACTOR" - # inf.values: logical. Are infinite numeric values authorized (Inf or -Inf)? Identical remarks as for the neg.values argument - # print: logical. Print the message if $problem is TRUE? Warning: set by default to FALSE, which facilitates the control of the checking message output when using fun_check() inside functions. See the example section - # data.name: character string indicating the name of the object to test. If NULL, use what is assigned to the data argument for the returned message - # fun.name: character string indicating the name of the function checked (i.e., when fun_check() is used to check the arguments of this function). If non-null, the value of fun.name will be added into the message returned by fun_check() - # RETURN - # A list containing: - # $problem: logical. Is there any problem detected? - # $text: message indicating the details of the problem, or the absence of problem - # $object.name: value of the data.name argument (i.e., name of the checked object if provided, NULL otherwise) - # REQUIRED PACKAGES - # None - # REQUIRED FUNCTIONS FROM THE cute PACKAGE - # None - # EXAMPLE - # test <- matrix(1:3) ; fun_check(data = test, print = TRUE, class = "vector", mode = "numeric") - # see http - # DEBUGGING - # data = mean ; class = NULL ; typeof = NULL ; mode = NULL ; length = NULL ; prop = FALSE ; double.as.integer.allowed = FALSE ; options = "a" ; all.options.in.data = FALSE ; na.contain = FALSE ; neg.values = TRUE ; inf.values = TRUE ; print = TRUE ; data.name = NULL ; fun.name = NULL - # function name - # no used in this function for the error message, to avoid env colliding - # end function name - # required function checking - # end required function checking - # reserved words - # end reserved words - # fun.name checked first because required next - if( ! is.null(fun.name)){ # I have to use this way to deal with every kind of class for fun.name - if(all(base::class(fun.name) == "character")){ # all() without na.rm -> ok because class(NA) is "logical" - if(base::length(fun.name) != 1){ - tempo.cat <- paste0("ERROR IN fun_check(): THE fun.name ARGUMENT MUST BE A CHARACTER VECTOR OF LENGTH 1: ", paste(fun.name, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - }else if(any(is.na(fun.name))){ # normally no NA with is.na() - tempo.cat <- paste0("ERROR IN fun_check(): NO ARGUMENT EXCEPT data AND options CAN HAVE NA VALUES\nPROBLEMATIC ARGUMENT IS fun.name") - 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{ - tempo.cat <- paste0("ERROR IN fun_check(): THE fun.name ARGUMENT MUST BE A CHARACTER VECTOR OF LENGTH 1") # paste(fun.name, collapse = " ") removed here because does not work with objects like function - 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 fun.name checked first because required next - # arg with no default values - mandat.args <- c( - "data" - ) - tempo <- eval(parse(text = paste0("c(missing(", paste0(mandat.args, collapse = "), missing("), "))"))) - if(any(tempo)){ # normally no NA for missing() output - tempo.cat <- paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", ifelse(sum(tempo, na.rm = TRUE) > 1, "S HAVE", " HAS"), " NO DEFAULT VALUE AND REQUIRE ONE:\n", paste0(mandat.args[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 - # source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.7/r_debugging_tools-v1.7.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status - # end argument primary checking - # second round of checking and data preparation - # management of special classes - basic.class <- c( - "NULL", # because class(NULL) is "NULL". The NULL aspect will be dealt later - "logical", - "integer", - "numeric", - # "complex", - "character" - # "matrix", - # "array", - # "data.frame", - # "list", - # "factor", - # "table", - # "expression", - # "name", - # "symbol", - # "function", - # "uneval", - # "environment", - # "ggplot2", - # "ggplot_built", - # "call" - ) - tempo.arg.base <-c( # no names(formals(fun = sys.function(sys.parent(n = 2)))) used with fun_check() to be sure to deal with the correct environment - "class", - "typeof", - "mode", - "length", - "prop", - "double.as.integer.allowed", - "options", - "all.options.in.data", - "na.contain", - "neg.values", - "inf.values", - "print", - "data.name", - "fun.name" - ) - tempo.class <-list( # no get() used to be sure to deal with the correct environment - base::class(class), - base::class(typeof), - base::class(mode), - base::class(length), - base::class(prop), - base::class(double.as.integer.allowed), - base::class(options), - base::class(all.options.in.data), - base::class(na.contain), - base::class(neg.values), - base::class(inf.values), - base::class(print), - base::class(data.name), - base::class(fun.name) - ) - tempo <- ! sapply(lapply(tempo.class, FUN = "%in%", basic.class), FUN = all) - if(any(tempo)){ - tempo.cat1 <- tempo.arg.base[tempo] - tempo.cat2 <- sapply(tempo.class[tempo], FUN = paste0, collapse = " ") - tempo.sep <- sapply(mapply(" ", max(nchar(tempo.cat1)) - nchar(tempo.cat1) + 3, FUN = rep, SIMPLIFY = FALSE), FUN = paste0, collapse = "") - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": ANY ARGUMENT EXCEPT data MUST HAVE A BASIC CLASS\nPROBLEMATIC ARGUMENT", ifelse(base::length(tempo.cat1) > 1, "S", ""), " AND ASSOCIATED CLASS", ifelse(base::length(tempo.cat1) > 1, "ES ARE", " IS"), ":\n", paste0(tempo.cat1, tempo.sep, tempo.cat2, collapse = "\n")) # normally no NA with is.na() - 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 special classes - # management of NA arguments - if(any(is.na(data.name)) | any(is.na(class)) | any(is.na(typeof)) | any(is.na(mode)) | any(is.na(length)) | any(is.na(prop)) | any(is.na(double.as.integer.allowed)) | any(is.na(all.options.in.data)) | any(is.na(na.contain)) | any(is.na(neg.values)) | any(is.na(inf.values)) | any(is.na(print)) | any(is.na(fun.name))){ # normally no NA with is.na() - tempo <- c("data.name", "class", "typeof", "mode", "length", "prop", "double.as.integer.allowed", "all.options.in.data", "na.contain", "neg.values", "inf.values", "print", "fun.name")[c(any(is.na(data.name)), any(is.na(class)), any(is.na(typeof)), any(is.na(mode)), any(is.na(length)), any(is.na(prop)), any(is.na(double.as.integer.allowed)), any(is.na(all.options.in.data)), any(is.na(na.contain)), any(is.na(neg.values)), any(is.na(inf.values)), any(is.na(print)), any(is.na(fun.name)))] - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": NO ARGUMENT EXCEPT data AND options CAN HAVE NA VALUES\nPROBLEMATIC ARGUMENT", ifelse(length(tempo) > 1, "S ARE", " IS"), ":\n", paste(tempo, collapse = "\n")) # normally no NA with is.na() - 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( - "prop", - "double.as.integer.allowed", - "all.options.in.data", - "na.contain", - "neg.values", - "inf.values", - "print" - ) - 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 fun.check():\n", ifelse(sum(tempo.log, na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), " CANNOT BE NULL:\n", 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 - # dealing with logical - # tested below - # end dealing with logical - # 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( ! is.null(data.name)){ - if( ! (base::length(data.name) == 1L & all(base::class(data.name) == "character"))){ # all() without na.rm -> ok because class(NA) is "logical" - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": data.name ARGUMENT MUST BE A SINGLE CHARACTER ELEMENT AND NOT ", paste(data.name, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - } - } - if(is.null(options) & is.null(class) & is.null(typeof) & is.null(mode) & prop == FALSE & is.null(length)){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": AT LEAST ONE OF THE options, class, typeof, mode, prop, OR length ARGUMENT MUST BE SPECIFIED (I.E, TRUE FOR prop)") - 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( ! is.null(options) & ( ! is.null(class) | ! is.null(typeof) | ! is.null(mode) | prop == TRUE)){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE class, typeof, mode ARGUMENTS MUST BE NULL, AND prop FALSE, IF THE options ARGUMENT IS SPECIFIED\nTHE options ARGUMENT MUST BE NULL IF THE class AND/OR typeof AND/OR mode AND/OR prop ARGUMENT IS SPECIFIED") - 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( ! (all(base::class(neg.values) == "logical") & base::length(neg.values) == 1L)){ # all() without na.rm -> ok because class(NA) is "logical" - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE neg.values ARGUMENT MUST BE TRUE OR FALSE ONLY") - 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(neg.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE neg.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE 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 == - } - if( ! (all(base::class(inf.values) == "logical") & base::length(inf.values) == 1L)){ # all() without na.rm -> ok because class(NA) is "logical" - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE inf.values ARGUMENT MUST BE TRUE OR FALSE ONLY") - 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(inf.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE inf.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE 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 == - } - if( ! is.null(class)){ # may add "formula" and "Date" as in https://renenyffenegger.ch/notes/development/languages/R/functions/class - if( ! all(class %in% c("vector", "logical", "integer", "numeric", "complex", "character", "matrix", "array", "data.frame", "list", "factor", "table", "expression", "name", "symbol", "function", "uneval", "environment", "ggplot2", "ggplot_built", "call") & base::length(class) == 1L)){ # length == 1L here because of class(matrix()) since R4.0.0 # all() without na.rm -> ok because class cannot be NA (tested above) - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT MUST BE ONE OF THESE VALUE:\n\"vector\", \"logical\", \"integer\", \"numeric\", \"complex\", \"character\", \"matrix\", \"array\", \"data.frame\", \"list\", \"factor\", \"table\", \"expression\", \"name\", \"symbol\", \"function\", \"environment\", \"ggplot2\", \"ggplot_built\", \"call\"") - 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(neg.values == FALSE & ! any(class %in% c("vector", "numeric", "integer", "matrix", "array", "data.frame", "table"))){ # no need of na.rm = TRUE for any() because %in% does not output NA - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"integer\", \"matrix\", \"array\", \"data.frame\", \"table\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") - 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(inf.values == FALSE & ! any(class %in% c("vector", "numeric", "matrix", "array", "data.frame", "table"))){ # no need of na.rm = TRUE for any() because %in% does not output NA - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF inf.values ARGUMENT IS SWITCHED TO FALSE. \"integer IS NOT ALLOWED BECAUSE IFINITE VALUES ARE NOT INTEGERS\"") - 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( ! is.null(typeof)){ # all the types are here: https://renenyffenegger.ch/notes/development/languages/R/functions/typeof - if( ! (all(typeof %in% c("logical", "integer", "double", "complex", "character", "list", "expression", "symbol", "closure", "special", "builtin", "environment", "S4", "language")) & base::length(typeof) == 1L)){ # "language" is the type of object of class "call" # all() without na.rm -> ok because typeof cannot be NA (tested above) - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"integer\", \"double\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"closure\", \"special\", \"builtin\", \"environment\", \"S4\", \"language\"") - 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(neg.values == FALSE & ! typeof %in% c("double", "integer")){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN \"double\" OR \"integer\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") - 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(inf.values == FALSE & typeof != "double"){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN \"double\" IF inf.values ARGUMENT IS SWITCHED TO FALSE. \"integer IS NOT ALLOWED BECAUSE IFINITE VALUES ARE NOT INTEGERS\"") - 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( ! is.null(mode)){ # all the types are here: https://renenyffenegger.ch/notes/development/languages/R/functions/typeof - if( ! (all(mode %in% c("logical", "numeric", "complex", "character", "list", "expression", "name", "symbol", "function", "environment", "S4", "call")) & base::length(mode) == 1L)){ # all() without na.rm -> ok because mode cannot be NA (tested above) - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"numeric\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"function\", \"environment\", \"S4\", \"call\"") - 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(neg.values == FALSE & mode != "numeric"){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") - 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(inf.values == FALSE & mode != "numeric"){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF inf.values ARGUMENT IS SWITCHED TO FALSE") - 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( ! is.null(length)){ - if( ! (is.numeric(length) & base::length(length) == 1L & all( ! grepl(length, pattern = "\\.")))){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": length ARGUMENT MUST BE A SINGLE INTEGER VALUE") - 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( ! (is.logical(prop) & base::length(prop) == 1L)){ # is.na() already checked for prop - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": prop ARGUMENT MUST BE TRUE OR FALSE ONLY") - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - }else if(prop == TRUE){ - if( ! is.null(class)){ - if( ! any(class %in% c("vector", "numeric", "matrix", "array", "data.frame", "table"))){ # no need of na.rm = TRUE for any() because %in% does not output NA - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN NULL, \"vector\", \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF prop ARGUMENT IS TRUE") # not integer because prop - 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( ! is.null(mode)){ - if(mode != "numeric"){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN NULL OR \"numeric\" IF prop ARGUMENT IS TRUE") - 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( ! is.null(typeof)){ - if(typeof != "double"){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN NULL OR \"double\" IF prop ARGUMENT IS TRUE") - 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( ! (all(base::class(double.as.integer.allowed) == "logical") & base::length(double.as.integer.allowed) == 1L)){ # all() without na.rm -> ok because class() never returns NA - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": THE double.as.integer.allowed ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(double.as.integer.allowed, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - } - if( ! (is.logical(all.options.in.data) & base::length(all.options.in.data) == 1L)){ - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" INSIDE ", fun.name)), ": all.options.in.data ARGUMENT MUST BE A SINGLE LOGICAL VALUE (TRUE OR FALSE ONLY): ", paste(all.options.in.data, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - } - if( ! (all(base::class(na.contain) == "logical") & base::length(na.contain) == 1L)){ # all() without na.rm -> ok because class() never returns NA - tempo.cat <- paste0("ERROR IN fun_check(): THE na.contain ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(na.contain, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - } - if( ! (all(base::class(print) == "logical") & base::length(print) == 1L)){ # all() without na.rm -> ok because class() never returns NA - tempo.cat <- paste0("ERROR IN fun_check(): THE print ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(print, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), call. = FALSE) # == in stop() to be able to add several messages between == - } - # data.name and fun.name tested at the beginning - # end other checkings - # end second round of checking and data preparation - # package checking - # end package checking - # main code - if(is.null(data.name)){ - data.name <- deparse(substitute(data)) - } - problem <- FALSE - text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT") - if(( ! is.null(options)) & (all(base::typeof(data) == "character") | all(base::typeof(data) == "integer") | all(base::typeof(data) == "double"))){ # all() without na.rm -> ok because typeof() never returns NA - if(all(base::typeof(data) == "double")){ - if( ! all(data %% 1 == 0L, na.rm = TRUE)){ - problem <- TRUE - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nBUT IS NOT EVEN TYPE CHARACTER OR INTEGER") - } - }else{ - text <- "" - if( ! all(data %in% options)){ # no need of na.rm = TRUE for all() because %in% does not output NA - problem <- TRUE - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nTHE PROBLEMATIC ELEMENTS OF ", data.name, " ARE: ", paste(unique(data[ ! (data %in% options)]), collapse = " ")) - } - if(all.options.in.data == TRUE){ - if( ! all(options %in% data)){ # no need of na.rm = TRUE for all() because %in% does not output NA - problem <- TRUE - text <- paste0(ifelse(text == "", "", paste0(text, "\n")), ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE MADE OF ALL THESE OPTIONS: ", paste(options, collapse = " "), "\nTHE MISSING ELEMENTS OF THE options ARGUMENT ARE: ", paste(unique(options[ ! (options %in% data)]), collapse = " ")) - } - } - if( ! is.null(length)){ - if(base::length(data) != length){ - problem <- TRUE - text <- paste0(ifelse(text == "", "", paste0(text, "\n")), ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE LENGTH OF ", data.name, " MUST BE ", length, " AND NOT ", base::length(data)) - } - } - if(text == ""){ - text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT") - } - } - }else if( ! is.null(options)){ - problem <- TRUE - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nBUT IS NOT EVEN TYPE CHARACTER OR INTEGER") - } - arg.names <- c("class", "typeof", "mode", "length") - if( ! is.null(class)){ - if(class == "matrix"){ # because of class(matric()) since R4.0.0 - class <- c("matrix", "array") - }else if(class == "factor" & all(base::class(data) %in% c("factor", "ordered"))){ # to deal with ordered factors # all() without na.rm -> ok because class(NA) is "logical" - class <- c("factor", "ordered") - } - } - if(is.null(options)){ - for(i2 in 1:base::length(arg.names)){ - if( ! is.null(get(arg.names[i2], env = sys.nframe(), inherit = FALSE))){ - # script to execute - tempo.script <- ' -problem <- TRUE ; -if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ -text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " OBJECT MUST BE ") ; -}else{ -text <- paste0(text, " AND ") ; -} -text <- paste0(text, toupper(arg.names[i2]), " ", if(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) %in% c("matrix", "array"))){"matrix"}else if(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) %in% c("factor", "ordered"))){"factor"}else{get(arg.names[i2], env = sys.nframe(), inherit = FALSE)}) -' # no need of na.rm = TRUE for all() because %in% does not output NA - # end script to execute - if(base::typeof(data) == "double" & double.as.integer.allowed == TRUE & ((arg.names[i2] == "class" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "integer")) | (arg.names[i2] == "typeof" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "integer")))){ # no need of na.rm = TRUE for all() because == does not output NA if no NA in left of ==, which is the case for arg.names # typeof(data) == "double" means no factor allowed - if( ! all(data %% 1 == 0L, na.rm = TRUE)){ # to check integers (use %%, meaning the remaining of a division): see the precedent line. isTRUE(all.equal(data%%1, rep(0, length(data)))) not used because we strictly need zero as a result. Warning: na.rm = TRUE required here for all() - eval(parse(text = tempo.script)) # execute tempo.script - } - }else if( ! any(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) %in% c("vector", "ggplot2"))) & ! all(eval(parse(text = paste0(arg.names[i2], "(data)"))) %in% get(arg.names[i2], env = sys.nframe(), inherit = FALSE))){ # test the four c("class", "typeof", "mode", "length") arguments with their corresponding function. No need of na.rm = TRUE for all() because %in% does not output NA # no need of na.rm = TRUE for all() because %in% does not output NA # no need of na.rm = TRUE for any() because get get(arg.names) does not contain NA - eval(parse(text = tempo.script)) # execute tempo.script - }else if(arg.names[i2] == "class" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "vector") & ! (all(base::class(data) %in% "numeric") | all(base::class(data) %in% "integer") | all(base::class(data) %in% "character") | all(base::class(data) %in% "logical"))){ # test class == "vector". No need of na.rm = TRUE for all() because %in% does not output NA # no need of na.rm = TRUE for all() because == does not output NA if no NA in left of ==, which is the case for arg.names - eval(parse(text = tempo.script)) # execute tempo.script - }else if(arg.names[i2] == "class" & all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) == "ggplot2") & ! all(base::class(data) %in% c("gg", "ggplot"))){ # test ggplot object # no need of na.rm = TRUE for all() because == does not output NA if no NA in left of ==, which is the case for arg.names # no need of na.rm = TRUE for all() because %in% does not output NA - eval(parse(text = tempo.script)) # execute tempo.script - } - } - } - } -if(prop == TRUE & all(base::typeof(data) == "double")){ # all() without na.rm -> ok because typeof(NA) is "logical" - if(is.null(data) | any(data < 0 | data > 1, na.rm = TRUE)){ # works if data is NULL # Warning: na.rm = TRUE required here for any() # typeof(data) == "double" means no factor allowed - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE DECIMAL VALUES BETWEEN 0 AND 1") - } -}else if(prop == TRUE){ - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE DECIMAL VALUES BETWEEN 0 AND 1") -} -if(all(base::class(data) %in% "expression")){ # no need of na.rm = TRUE for all() because %in% does not output NA - data <- as.character(data) # to evaluate the presence of NA -} -if(na.contain == FALSE & (base::mode(data) %in% c("logical", "numeric", "complex", "character", "list"))){ # before it was ! (class(data) %in% c("function", "environment")) - if(any(is.na(data)) == TRUE){ # not on the same line because when data is class envir or function , do not like that # normally no NA with is.na() - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT CONTAINS NA WHILE NOT AUTHORIZED") - } -} -if(neg.values == FALSE & all(base::mode(data) %in% "numeric") & ! any(base::class(data) %in% "factor")){ # no need of na.rm = TRUE for all() because %in% does not output NA - if(any(data < 0, na.rm = TRUE)){ # Warning: na.rm = TRUE required here for any() - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON NEGATIVE NUMERIC VALUES") - } -}else if(neg.values == FALSE){ - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON NEGATIVE VALUES BUT IS ", ifelse(any(base::class(data) %in% "factor"), "A FACTOR", "NOT EVEN MODE NUMERIC")) -} -if(inf.values == FALSE & all(base::typeof(data) %in% "double") & ! any(base::class(data) %in% "factor")){ # no need of na.rm = TRUE for all() because %in% does not output NA - if(any(is.infinite(data), na.rm = TRUE)){ # Warning: na.rm = TRUE required here for any() - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON INFINITE NUMERIC VALUES") - } -}else if(inf.values == FALSE){ - problem <- TRUE - if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " OBJECT"))){ - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ") - }else{ - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON INFINITE VALUES BUT IS ", ifelse(any(base::class(data) %in% "factor"), "A FACTOR", "NOT EVEN TYPE DOUBLE")) -} -if(print == TRUE & problem == TRUE){ - cat(paste0("\n\n================\n\n", text, "\n\n================\n\n")) -} -# output -output <- list(problem = problem, text = text, object.name = data.name) -return(output) -# end output -# end main code -} diff --git a/checkFunctions/Read-and-delete-me b/checkFunctions/Read-and-delete-me deleted file mode 100644 index 4e395f1edaa32e7886bb91585ad76596a4eec2e7..0000000000000000000000000000000000000000 --- a/checkFunctions/Read-and-delete-me +++ /dev/null @@ -1,9 +0,0 @@ -* Edit the help file skeletons in 'man', possibly combining help files for multiple - functions. -* Edit the exports in 'NAMESPACE', and add necessary imports. -* Put any C/C++/Fortran code in 'src'. -* If you have compiled code, add a useDynLib() directive to 'NAMESPACE'. -* Run R CMD build to build the package tarball. -* Run R CMD check to check the package tarball. - -Read "Writing R Extensions" for more information. diff --git a/checkFunctions/man/checkFunctions-package.Rd b/checkFunctions/man/checkFunctions-package.Rd deleted file mode 100644 index aae370e0e304ac49c1e56a8010e321406bbd7d9d..0000000000000000000000000000000000000000 --- a/checkFunctions/man/checkFunctions-package.Rd +++ /dev/null @@ -1,35 +0,0 @@ -\name{checkFunctions-package} -\alias{checkFunctions-package} -\alias{checkFunctions} -\docType{package} -\title{ -\packageTitle{checkFunctions} -} -\description{ -\packageDescription{checkFunctions} -} -\details{ - -The DESCRIPTION file: -\packageDESCRIPTION{checkFunctions} -\packageIndices{checkFunctions} -~~ An overview of how to use the package, including the most important functions ~~ -} -\author{ -\packageAuthor{checkFunctions} - -Maintainer: \packageMaintainer{checkFunctions} -} -\references{ -~~ Literature or other references for background information ~~ -} -~~ Optionally other standard keywords, one per line, from file KEYWORDS in the R ~~ -~~ documentation directory ~~ -\keyword{ package } -\seealso{ -~~ Optional links to other man pages, e.g. ~~ -~~ \code{\link[<pkg>:<pkg>-package]{<pkg>}} ~~ -} -\examples{ -~~ simple examples of the most important functions ~~ -} diff --git a/checkFunctions/man/fun_check.Rd b/checkFunctions/man/fun_check.Rd deleted file mode 100644 index f3ddee34240da87b75b036f3a04d5bc7fb9eca99..0000000000000000000000000000000000000000 --- a/checkFunctions/man/fun_check.Rd +++ /dev/null @@ -1,624 +0,0 @@ -\name{fun_check} -\alias{fun_check} -%- Also NEED an '\alias' for EACH other topic documented here. -\title{ -%% ~~function to do ... ~~ -} -\description{ -%% ~~ A concise (1-5 lines) description of what the function does. ~~ -} -\usage{ -fun_check(data, class = NULL, 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) -} -%- maybe also 'usage' for other objects documented here. -\arguments{ - \item{data}{ -%% ~~Describe \code{data} here~~ -} - \item{class}{ -%% ~~Describe \code{class} here~~ -} - \item{typeof}{ -%% ~~Describe \code{typeof} here~~ -} - \item{mode}{ -%% ~~Describe \code{mode} here~~ -} - \item{length}{ -%% ~~Describe \code{length} here~~ -} - \item{prop}{ -%% ~~Describe \code{prop} here~~ -} - \item{double.as.integer.allowed}{ -%% ~~Describe \code{double.as.integer.allowed} here~~ -} - \item{options}{ -%% ~~Describe \code{options} here~~ -} - \item{all.options.in.data}{ -%% ~~Describe \code{all.options.in.data} here~~ -} - \item{na.contain}{ -%% ~~Describe \code{na.contain} here~~ -} - \item{neg.values}{ -%% ~~Describe \code{neg.values} here~~ -} - \item{inf.values}{ -%% ~~Describe \code{inf.values} here~~ -} - \item{print}{ -%% ~~Describe \code{print} here~~ -} - \item{data.name}{ -%% ~~Describe \code{data.name} here~~ -} - \item{fun.name}{ -%% ~~Describe \code{fun.name} here~~ -} -} -\details{ -%% ~~ If necessary, more details than the description above ~~ -} -\value{ -%% ~Describe the value returned -%% If it is a LIST, use -%% \item{comp1 }{Description of 'comp1'} -%% \item{comp2 }{Description of 'comp2'} -%% ... -} -\references{ -%% ~put references to the literature/web site here ~ -} -\author{ -%% ~~who you are~~ -} -\note{ -%% ~~further notes~~ -} - -%% ~Make other sections like Warning with \section{Warning }{....} ~ - -\seealso{ -%% ~~objects to See Also as \code{\link{help}}, ~~~ -} -\examples{ -##---- Should be DIRECTLY executable !! ---- -##-- ==> Define data, use random, -##-- or do help(data=index) for the standard data sets. - -## The function is currently defined as -function (data, class = NULL, 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) -{ - if (!is.null(fun.name)) { - if (all(base::class(fun.name) == "character")) { - if (base::length(fun.name) != 1) { - tempo.cat <- paste0("ERROR IN fun_check(): THE fun.name ARGUMENT MUST BE A CHARACTER VECTOR OF LENGTH 1: ", - paste(fun.name, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - else if (any(is.na(fun.name))) { - tempo.cat <- paste0("ERROR IN fun_check(): NO ARGUMENT EXCEPT data AND options CAN HAVE NA VALUES\nPROBLEMATIC ARGUMENT IS fun.name") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - } - else { - tempo.cat <- paste0("ERROR IN fun_check(): THE fun.name ARGUMENT MUST BE A CHARACTER VECTOR OF LENGTH 1") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - } - mandat.args <- c("data") - tempo <- eval(parse(text = paste0("c(missing(", paste0(mandat.args, - collapse = "), missing("), "))"))) - if (any(tempo)) { - tempo.cat <- paste0("ERROR IN ", function.name, "\nFOLLOWING ARGUMENT", - ifelse(sum(tempo, na.rm = TRUE) > 1, "S HAVE", " HAS"), - " NO DEFAULT VALUE AND REQUIRE ONE:\n", paste0(mandat.args[tempo], - collapse = "\n")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - basic.class <- c("NULL", "logical", "integer", "numeric", - "character") - tempo.arg.base <- c("class", "typeof", "mode", "length", - "prop", "double.as.integer.allowed", "options", "all.options.in.data", - "na.contain", "neg.values", "inf.values", "print", "data.name", - "fun.name") - tempo.class <- list(base::class(class), base::class(typeof), - base::class(mode), base::class(length), base::class(prop), - base::class(double.as.integer.allowed), base::class(options), - base::class(all.options.in.data), base::class(na.contain), - base::class(neg.values), base::class(inf.values), base::class(print), - base::class(data.name), base::class(fun.name)) - tempo <- !sapply(lapply(tempo.class, FUN = "\%in\%", basic.class), - FUN = all) - if (any(tempo)) { - tempo.cat1 <- tempo.arg.base[tempo] - tempo.cat2 <- sapply(tempo.class[tempo], FUN = paste0, - collapse = " ") - tempo.sep <- sapply(mapply(" ", max(nchar(tempo.cat1)) - - nchar(tempo.cat1) + 3, FUN = rep, SIMPLIFY = FALSE), - FUN = paste0, collapse = "") - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": ANY ARGUMENT EXCEPT data MUST HAVE A BASIC CLASS\nPROBLEMATIC ARGUMENT", - ifelse(base::length(tempo.cat1) > 1, "S", ""), " AND ASSOCIATED CLASS", - ifelse(base::length(tempo.cat1) > 1, "ES ARE", " IS"), - ":\n", paste0(tempo.cat1, tempo.sep, tempo.cat2, - collapse = "\n")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - if (any(is.na(data.name)) | any(is.na(class)) | any(is.na(typeof)) | - any(is.na(mode)) | any(is.na(length)) | any(is.na(prop)) | - any(is.na(double.as.integer.allowed)) | any(is.na(all.options.in.data)) | - any(is.na(na.contain)) | any(is.na(neg.values)) | any(is.na(inf.values)) | - any(is.na(print)) | any(is.na(fun.name))) { - tempo <- c("data.name", "class", "typeof", "mode", "length", - "prop", "double.as.integer.allowed", "all.options.in.data", - "na.contain", "neg.values", "inf.values", "print", - "fun.name")[c(any(is.na(data.name)), any(is.na(class)), - any(is.na(typeof)), any(is.na(mode)), any(is.na(length)), - any(is.na(prop)), any(is.na(double.as.integer.allowed)), - any(is.na(all.options.in.data)), any(is.na(na.contain)), - any(is.na(neg.values)), any(is.na(inf.values)), any(is.na(print)), - any(is.na(fun.name)))] - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": NO ARGUMENT EXCEPT data AND options CAN HAVE NA VALUES\nPROBLEMATIC ARGUMENT", - ifelse(length(tempo) > 1, "S ARE", " IS"), ":\n", - paste(tempo, collapse = "\n")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - tempo.arg <- c("prop", "double.as.integer.allowed", "all.options.in.data", - "na.contain", "neg.values", "inf.values", "print") - tempo.log <- sapply(lapply(tempo.arg, FUN = get, env = sys.nframe(), - inherit = FALSE), FUN = is.null) - if (any(tempo.log) == TRUE) { - tempo.cat <- paste0("ERROR IN fun.check():\n", ifelse(sum(tempo.log, - na.rm = TRUE) > 1, "THESE ARGUMENTS", "THIS ARGUMENT"), - " CANNOT BE NULL:\n", paste0(tempo.arg[tempo.log], - collapse = "\n")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - if (!is.null(data.name)) { - if (!(base::length(data.name) == 1L & all(base::class(data.name) == - "character"))) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": data.name ARGUMENT MUST BE A SINGLE CHARACTER ELEMENT AND NOT ", - paste(data.name, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - } - if (is.null(options) & is.null(class) & is.null(typeof) & - is.null(mode) & prop == FALSE & is.null(length)) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": AT LEAST ONE OF THE options, class, typeof, mode, prop, OR length ARGUMENT MUST BE SPECIFIED (I.E, TRUE FOR prop)") - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - if (!is.null(options) & (!is.null(class) | !is.null(typeof) | - !is.null(mode) | prop == TRUE)) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": THE class, typeof, mode ARGUMENTS MUST BE NULL, AND prop FALSE, IF THE options ARGUMENT IS SPECIFIED\nTHE options ARGUMENT MUST BE NULL IF THE class AND/OR typeof AND/OR mode AND/OR prop ARGUMENT IS SPECIFIED") - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - if (!(all(base::class(neg.values) == "logical") & base::length(neg.values) == - 1L)) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": THE neg.values ARGUMENT MUST BE TRUE OR FALSE ONLY") - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - if (neg.values == FALSE & is.null(class) & is.null(typeof) & - is.null(mode)) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": THE neg.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE NULL") - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - if (!(all(base::class(inf.values) == "logical") & base::length(inf.values) == - 1L)) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": THE inf.values ARGUMENT MUST BE TRUE OR FALSE ONLY") - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - if (inf.values == FALSE & is.null(class) & is.null(typeof) & - is.null(mode)) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": THE inf.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE NULL") - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - if (!is.null(class)) { - if (!all(class \%in\% c("vector", "logical", "integer", - "numeric", "complex", "character", "matrix", "array", - "data.frame", "list", "factor", "table", "expression", - "name", "symbol", "function", "uneval", "environment", - "ggplot2", "ggplot_built", "call") & base::length(class) == - 1L)) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT MUST BE ONE OF THESE VALUE:\n\"vector\", \"logical\", \"integer\", \"numeric\", \"complex\", \"character\", \"matrix\", \"array\", \"data.frame\", \"list\", \"factor\", \"table\", \"expression\", \"name\", \"symbol\", \"function\", \"environment\", \"ggplot2\", \"ggplot_built\", \"call\"") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - if (neg.values == FALSE & !any(class \%in\% c("vector", - "numeric", "integer", "matrix", "array", "data.frame", - "table"))) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"integer\", \"matrix\", \"array\", \"data.frame\", \"table\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - if (inf.values == FALSE & !any(class \%in\% c("vector", - "numeric", "matrix", "array", "data.frame", "table"))) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF inf.values ARGUMENT IS SWITCHED TO FALSE. \"integer IS NOT ALLOWED BECAUSE IFINITE VALUES ARE NOT INTEGERS\"") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - } - if (!is.null(typeof)) { - if (!(all(typeof \%in\% c("logical", "integer", "double", - "complex", "character", "list", "expression", "symbol", - "closure", "special", "builtin", "environment", "S4", - "language")) & base::length(typeof) == 1L)) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"integer\", \"double\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"closure\", \"special\", \"builtin\", \"environment\", \"S4\", \"language\"") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - if (neg.values == FALSE & !typeof \%in\% c("double", "integer")) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN \"double\" OR \"integer\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - if (inf.values == FALSE & typeof != "double") { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN \"double\" IF inf.values ARGUMENT IS SWITCHED TO FALSE. \"integer IS NOT ALLOWED BECAUSE IFINITE VALUES ARE NOT INTEGERS\"") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - } - if (!is.null(mode)) { - if (!(all(mode \%in\% c("logical", "numeric", "complex", - "character", "list", "expression", "name", "symbol", - "function", "environment", "S4", "call")) & base::length(mode) == - 1L)) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"numeric\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"function\", \"environment\", \"S4\", \"call\"") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - if (neg.values == FALSE & mode != "numeric") { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF neg.values ARGUMENT IS SWITCHED TO FALSE") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - if (inf.values == FALSE & mode != "numeric") { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF inf.values ARGUMENT IS SWITCHED TO FALSE") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - } - if (!is.null(length)) { - if (!(is.numeric(length) & base::length(length) == 1L & - all(!grepl(length, pattern = "\\.")))) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": length ARGUMENT MUST BE A SINGLE INTEGER VALUE") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - } - if (!(is.logical(prop) & base::length(prop) == 1L)) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": prop ARGUMENT MUST BE TRUE OR FALSE ONLY") - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - else if (prop == TRUE) { - if (!is.null(class)) { - if (!any(class \%in\% c("vector", "numeric", "matrix", - "array", "data.frame", "table"))) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN NULL, \"vector\", \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF prop ARGUMENT IS TRUE") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - } - if (!is.null(mode)) { - if (mode != "numeric") { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN NULL OR \"numeric\" IF prop ARGUMENT IS TRUE") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - } - if (!is.null(typeof)) { - if (typeof != "double") { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN NULL OR \"double\" IF prop ARGUMENT IS TRUE") - stop(paste0("\n\n================\n\n", tempo.cat, - "\n\n================\n\n"), call. = FALSE) - } - } - } - if (!(all(base::class(double.as.integer.allowed) == "logical") & - base::length(double.as.integer.allowed) == 1L)) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": THE double.as.integer.allowed ARGUMENT MUST BE TRUE OR FALSE ONLY: ", - paste(double.as.integer.allowed, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - if (!(is.logical(all.options.in.data) & base::length(all.options.in.data) == - 1L)) { - tempo.cat <- paste0("ERROR IN fun_check()", ifelse(is.null(fun.name), - "", paste0(" INSIDE ", fun.name)), ": all.options.in.data ARGUMENT MUST BE A SINGLE LOGICAL VALUE (TRUE OR FALSE ONLY): ", - paste(all.options.in.data, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - if (!(all(base::class(na.contain) == "logical") & base::length(na.contain) == - 1L)) { - tempo.cat <- paste0("ERROR IN fun_check(): THE na.contain ARGUMENT MUST BE TRUE OR FALSE ONLY: ", - paste(na.contain, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - if (!(all(base::class(print) == "logical") & base::length(print) == - 1L)) { - tempo.cat <- paste0("ERROR IN fun_check(): THE print ARGUMENT MUST BE TRUE OR FALSE ONLY: ", - paste(print, collapse = " ")) - stop(paste0("\n\n================\n\n", tempo.cat, "\n\n================\n\n"), - call. = FALSE) - } - if (is.null(data.name)) { - data.name <- deparse(substitute(data)) - } - problem <- FALSE - text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", - fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, - " OBJECT") - if ((!is.null(options)) & (all(base::typeof(data) == "character") | - all(base::typeof(data) == "integer") | all(base::typeof(data) == - "double"))) { - if (all(base::typeof(data) == "double")) { - if (!all(data\%\%1 == 0L, na.rm = TRUE)) { - problem <- TRUE - text <- paste0(ifelse(is.null(fun.name), "ERROR", - paste0("ERROR IN ", fun.name)), ": THE ", data.name, - " OBJECT MUST BE SOME OF THESE OPTIONS: ", - paste(options, collapse = " "), "\nBUT IS NOT EVEN TYPE CHARACTER OR INTEGER") - } - } - else { - text <- "" - if (!all(data \%in\% options)) { - problem <- TRUE - text <- paste0(ifelse(is.null(fun.name), "ERROR", - paste0("ERROR IN ", fun.name)), ": THE ", data.name, - " OBJECT MUST BE SOME OF THESE OPTIONS: ", - paste(options, collapse = " "), "\nTHE PROBLEMATIC ELEMENTS OF ", - data.name, " ARE: ", paste(unique(data[!(data \%in\% - options)]), collapse = " ")) - } - if (all.options.in.data == TRUE) { - if (!all(options \%in\% data)) { - problem <- TRUE - text <- paste0(ifelse(text == "", "", paste0(text, - "\n")), ifelse(is.null(fun.name), "ERROR", - paste0("ERROR IN ", fun.name)), ": THE ", - data.name, " OBJECT MUST BE MADE OF ALL THESE OPTIONS: ", - paste(options, collapse = " "), "\nTHE MISSING ELEMENTS OF THE options ARGUMENT ARE: ", - paste(unique(options[!(options \%in\% data)]), - collapse = " ")) - } - } - if (!is.null(length)) { - if (base::length(data) != length) { - problem <- TRUE - text <- paste0(ifelse(text == "", "", paste0(text, - "\n")), ifelse(is.null(fun.name), "ERROR", - paste0("ERROR IN ", fun.name)), ": THE LENGTH OF ", - data.name, " MUST BE ", length, " AND NOT ", - base::length(data)) - } - } - if (text == "") { - text <- paste0(ifelse(is.null(fun.name), "", - paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", - data.name, " OBJECT") - } - } - } - else if (!is.null(options)) { - problem <- TRUE - text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", - fun.name)), ": THE ", data.name, " OBJECT MUST BE SOME OF THESE OPTIONS: ", - paste(options, collapse = " "), "\nBUT IS NOT EVEN TYPE CHARACTER OR INTEGER") - } - arg.names <- c("class", "typeof", "mode", "length") - if (!is.null(class)) { - if (class == "matrix") { - class <- c("matrix", "array") - } - else if (class == "factor" & all(base::class(data) \%in\% - c("factor", "ordered"))) { - class <- c("factor", "ordered") - } - } - if (is.null(options)) { - for (i2 in 1:base::length(arg.names)) { - if (!is.null(get(arg.names[i2], env = sys.nframe(), - inherit = FALSE))) { - tempo.script <- "\nproblem <- TRUE ;\nif(identical(text, paste0(ifelse(is.null(fun.name), \"\", paste0(\"IN \", fun.name, \": \")), \"NO PROBLEM DETECTED FOR THE \", data.name, \" OBJECT\"))){\ntext <- paste0(ifelse(is.null(fun.name), \"ERROR\", paste0(\"ERROR IN \", fun.name)), \": THE \", data.name, \" OBJECT MUST BE \") ;\n}else{\ntext <- paste0(text, \" AND \") ; \n}\ntext <- paste0(text, toupper(arg.names[i2]), \" \", if(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) \%in\% c(\"matrix\", \"array\"))){\"matrix\"}else if(all(get(arg.names[i2], env = sys.nframe(), inherit = FALSE) \%in\% c(\"factor\", \"ordered\"))){\"factor\"}else{get(arg.names[i2], env = sys.nframe(), inherit = FALSE)})\n" - if (base::typeof(data) == "double" & double.as.integer.allowed == - TRUE & ((arg.names[i2] == "class" & all(get(arg.names[i2], - env = sys.nframe(), inherit = FALSE) == "integer")) | - (arg.names[i2] == "typeof" & all(get(arg.names[i2], - env = sys.nframe(), inherit = FALSE) == "integer")))) { - if (!all(data\%\%1 == 0L, na.rm = TRUE)) { - eval(parse(text = tempo.script)) - } - } - else if (!any(all(get(arg.names[i2], env = sys.nframe(), - inherit = FALSE) \%in\% c("vector", "ggplot2"))) & - !all(eval(parse(text = paste0(arg.names[i2], - "(data)"))) \%in\% get(arg.names[i2], env = sys.nframe(), - inherit = FALSE))) { - eval(parse(text = tempo.script)) - } - else if (arg.names[i2] == "class" & all(get(arg.names[i2], - env = sys.nframe(), inherit = FALSE) == "vector") & - !(all(base::class(data) \%in\% "numeric") | all(base::class(data) \%in\% - "integer") | all(base::class(data) \%in\% "character") | - all(base::class(data) \%in\% "logical"))) { - eval(parse(text = tempo.script)) - } - else if (arg.names[i2] == "class" & all(get(arg.names[i2], - env = sys.nframe(), inherit = FALSE) == "ggplot2") & - !all(base::class(data) \%in\% c("gg", "ggplot"))) { - eval(parse(text = tempo.script)) - } - } - } - } - if (prop == TRUE & all(base::typeof(data) == "double")) { - if (is.null(data) | any(data < 0 | data > 1, na.rm = TRUE)) { - problem <- TRUE - if (identical(text, paste0(ifelse(is.null(fun.name), - "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", - data.name, " OBJECT"))) { - text <- paste0(ifelse(is.null(fun.name), "ERROR", - paste0("ERROR IN ", fun.name)), ": ") - } - else { - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE DECIMAL VALUES BETWEEN 0 AND 1") - } - } - else if (prop == TRUE) { - problem <- TRUE - if (identical(text, paste0(ifelse(is.null(fun.name), - "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", - data.name, " OBJECT"))) { - text <- paste0(ifelse(is.null(fun.name), "ERROR", - paste0("ERROR IN ", fun.name)), ": ") - } - else { - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE DECIMAL VALUES BETWEEN 0 AND 1") - } - if (all(base::class(data) \%in\% "expression")) { - data <- as.character(data) - } - if (na.contain == FALSE & (base::mode(data) \%in\% c("logical", - "numeric", "complex", "character", "list"))) { - if (any(is.na(data)) == TRUE) { - problem <- TRUE - if (identical(text, paste0(ifelse(is.null(fun.name), - "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", - data.name, " OBJECT"))) { - text <- paste0(ifelse(is.null(fun.name), "ERROR", - paste0("ERROR IN ", fun.name)), ": ") - } - else { - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT CONTAINS NA WHILE NOT AUTHORIZED") - } - } - if (neg.values == FALSE & all(base::mode(data) \%in\% "numeric") & - !any(base::class(data) \%in\% "factor")) { - if (any(data < 0, na.rm = TRUE)) { - problem <- TRUE - if (identical(text, paste0(ifelse(is.null(fun.name), - "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", - data.name, " OBJECT"))) { - text <- paste0(ifelse(is.null(fun.name), "ERROR", - paste0("ERROR IN ", fun.name)), ": ") - } - else { - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON NEGATIVE NUMERIC VALUES") - } - } - else if (neg.values == FALSE) { - problem <- TRUE - if (identical(text, paste0(ifelse(is.null(fun.name), - "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", - data.name, " OBJECT"))) { - text <- paste0(ifelse(is.null(fun.name), "ERROR", - paste0("ERROR IN ", fun.name)), ": ") - } - else { - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON NEGATIVE VALUES BUT IS ", - ifelse(any(base::class(data) \%in\% "factor"), "A FACTOR", - "NOT EVEN MODE NUMERIC")) - } - if (inf.values == FALSE & all(base::typeof(data) \%in\% "double") & - !any(base::class(data) \%in\% "factor")) { - if (any(is.infinite(data), na.rm = TRUE)) { - problem <- TRUE - if (identical(text, paste0(ifelse(is.null(fun.name), - "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", - data.name, " OBJECT"))) { - text <- paste0(ifelse(is.null(fun.name), "ERROR", - paste0("ERROR IN ", fun.name)), ": ") - } - else { - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON INFINITE NUMERIC VALUES") - } - } - else if (inf.values == FALSE) { - problem <- TRUE - if (identical(text, paste0(ifelse(is.null(fun.name), - "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", - data.name, " OBJECT"))) { - text <- paste0(ifelse(is.null(fun.name), "ERROR", - paste0("ERROR IN ", fun.name)), ": ") - } - else { - text <- paste0(text, " AND ") - } - text <- paste0(text, "THE ", data.name, " OBJECT MUST BE MADE OF NON INFINITE VALUES BUT IS ", - ifelse(any(base::class(data) \%in\% "factor"), "A FACTOR", - "NOT EVEN TYPE DOUBLE")) - } - if (print == TRUE & problem == TRUE) { - cat(paste0("\n\n================\n\n", text, "\n\n================\n\n")) - } - output <- list(problem = problem, text = text, object.name = data.name) - return(output) - } -} -% Add one or more standard keywords, see file 'KEYWORDS' in the -% R documentation directory (show via RShowDoc("KEYWORDS")): -% \keyword{ ~kwd1 } -% \keyword{ ~kwd2 } -% Use only one keyword per line. -% For non-standard keywords, use \concept instead of \keyword: -% \concept{ ~cpt1 } -% \concept{ ~cpt2 } -% Use only one concept per line. diff --git a/cute.Rproj b/cute.Rproj new file mode 100644 index 0000000000000000000000000000000000000000..b9255bc95985d76a64e5ae8bafaf855619b07790 --- /dev/null +++ b/cute.Rproj @@ -0,0 +1,20 @@ +Version: 1.0 + +RestoreWorkspace: Default +SaveWorkspace: Default +AlwaysSaveHistory: Default + +EnableCodeIndexing: Yes +UseSpacesForTab: Yes +NumSpacesForTab: 2 +Encoding: UTF-8 + +RnwWeave: Sweave +LaTeX: pdfLaTeX + +AutoAppendNewline: Yes +StripTrailingWhitespace: Yes + +BuildType: Package +PackageUseDevtools: Yes +PackageInstallArgs: --no-multiarch --with-keep.source diff --git a/man/fun_check.Rd b/man/fun_check.Rd new file mode 100644 index 0000000000000000000000000000000000000000..7ea65096776f5bd98c63ee21cc4d0c9a68a2a846 --- /dev/null +++ b/man/fun_check.Rd @@ -0,0 +1,69 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/check.R +\name{fun_check} +\alias{fun_check} +\title{fun_check} +\usage{ +fun_check( + data, + class = NULL, + 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 +) +} +\arguments{ +\item{data}{Object to test} + +\item{class}{Character string. Either one of the class() result (But see the warning section above) or "vector" or "ggplot2" (i.e., objects of class c("gg", "ggplot")) or NULL} + +\item{typeof}{Character string. Either one of the typeof() result or NULL} + +\item{mode}{Character string. Either one of the mode() result (for non-vector object) or NULL} + +\item{length}{Numeric value indicating the length of the object. Not considered if NULL} + +\item{prop}{Logical. Are the numeric values between 0 and 1 (proportion)? If TRUE, can be used alone, without considering class, etc.} + +\item{double.as.integer.allowed}{Logical. If TRUE, no error is reported in the cheking message if argument is set to typeof == "integer" or class == "integer", while the reality is typeof == "double" or class == "numeric" but the numbers strictly have zero as modulo (remainder of a division). This means that i <- 1, which is typeof(i) -> "double" is considered as integer with double.as.integer.allowed = TRUE. WARNING: data%%1 == 0L but not isTRUE(all.equal(data%%1, 0)) is used here because the argument checks for integers stored as double (does not check for decimal numbers that are approximate integers)} + +\item{options}{A vector of character strings or integers indicating all the possible option values for the data argument, or NULL. Numbers of type "double" are accepted if they have a 0 modulo} + +\item{all.options.in.data}{Logical. If TRUE, all of the options must be present at least once in the data argument, and nothing else. If FALSE, some or all of the options must be present in the data argument, and nothing else. Ignored if options is NULL} + +\item{na.contain}{Logical. Can the data argument contain NA?} + +\item{neg.values}{Logical. Are negative numeric values authorized? Warning: the default setting is TRUE, meaning that, in that case, no check is performed for the presence of negative values. The neg.values argument is activated only when set to FALSE. In addition, (1) neg.values = FALSE can only be used when class, typeof or mode arguments are not NULL, otherwise return an error message, (2) the presence of negative values is not checked with neg.values = FALSE if the tested object is a factor and the following checking message is returned "OBJECT MUST BE MADE OF NON NEGATIVE VALUES BUT IS A FACTOR"} + +\item{inf.values}{Logical. Are infinite numeric values authorized (Inf or -Inf)? Identical remarks as for the neg.values argument} + +\item{print}{Logical. Print the message if $problem is TRUE? Warning: set by default to FALSE, which facilitates the control of the checking message output when using fun_check() inside functions. See the example section} + +\item{data.name}{Character string indicating the name of the object to test. If NULL, use what is assigned to the data argument for the returned message} + +\item{fun.name}{Character string indicating the name of the function checked (i.e., when fun_check() is used to check the arguments of this function). If non-null, the value of fun.name will be added into the message returned by fun_check()} +} +\value{ +A list containing: +$problem: logical. Is there any problem detected? +$text: message indicating the details of the problem, or the absence of problem +$object.name: value of the data.name argument (i.e., name of the checked object if provided, NULL otherwise) +} +\description{ +Check the class, type, mode and length of the data argument +Mainly used to check the arguments of other functions +Check also other kind of data parameters, is it a proportion? Is it type double but numbers without decimal part? +} +\examples{ +test <- matrix(1:3) ; fun_check(data = test, print = TRUE, class = "vector", mode = "numeric") +}