cute_little_R_functions.R

################################################################
##                                                            ##
##     CUTE FUNCTIONS                                         ##
##                                                            ##
##     Gael A. Millot                                         ##
##                                                            ##
##                                                            ##
################################################################


# https://usethis.r-lib.org/ and usethat also
# change everywhere: if( ! is.null(arg.check)){
# BEWARE: do not forget to save the modifications in the .R file (through RSTUDIO for indentation)
# update graphic examples with good comment, as in barplot
# Make a "first round" check for each function if required
# Update all argument description, saying, character vector, etc.
# check all the functions using fun_test
# check all(, na.rm = TRUE) and any(, na.rm = TRUE)
# fun_mat_fill does not recognize half matrix anymore
# Templates: https://prettydoc.statr.me/themes.html
# # package: http://r-pkgs.had.co.nz/
# https://pkgdown.r-lib.org/
# https://rdrr.io/github/gastonstat/cointoss/
# doc:https://www.sphinx-doc.org/en/master/man/sphinx-autogen.html considering that https://www.ericholscher.com/blog/2014/feb/11/sphinx-isnt-just-for-python/
# https://docs.readthedocs.io/en/stable/intro/getting-started-with-sphinx.html
# https://docs.gitlab.com/ee/user/project/pages/
# also register into biotools
# For heatmap: see https://bioinfo-fr.net/creer-des-heatmaps-a-partir-de-grosses-matrices-en-r


################################ OUTLINE ################################


################ Object analysis    2
######## fun_check() #### check class, type, length, etc., of objects   2
######## fun_secu() #### verif that local variables are not present in other envs   10
######## fun_info() #### recover object information 12
######## fun_head() #### head of the left or right of big 2D objects    14
######## fun_tail() #### tail of the left or right of big 2D objects    15
######## fun_comp_1d() #### comparison of two 1D datasets (vectors, factors, 1D tables) 16
######## fun_comp_2d() #### comparison of two 2D datasets (row & col names, dimensions, etc.)   20
######## fun_comp_list() #### comparison of two lists   26
######## fun_test() #### test combinations of argument values of a function and return errors (and graphs)  29
################ Object modification    43
######## fun_name_change() #### check a vector of character strings and modify any string if present in another vector  43
######## fun_df_remod() #### remodeling a data frame to have column name as a qualitative values and vice-versa 45
######## fun_round() #### rounding number if decimal present    47
######## fun_mat_rotate() #### 90° clockwise matrix rotation    49
######## fun_mat_num2color() #### convert a numeric matrix into hexadecimal color matrix    50
######## fun_mat_op() #### assemble several matrices with operation 53
######## fun_mat_inv() #### return the inverse of a square matrix   56
######## fun_mat_fill() #### fill the empty half part of a symmetric square matrix  57
######## fun_permut() #### progressively breaks a vector order  61
######## fun_slide() #### return a computation made on a vector using a sliding window  71
################ Graphics management    78
######## fun_width() #### window width depending on classes to plot 78
######## fun_open() #### open a GUI or pdf graphic window   80
######## fun_prior_plot() #### set graph param before plotting (erase axes for instance)    84
######## fun_scale() #### select nice label numbers when setting number of ticks on an axis 88
######## fun_inter_ticks() #### define coordinates of secondary ticks   93
######## fun_post_plot() #### set graph param after plotting (axes redesign for instance)   97
######## fun_close() #### close specific graphic windows    108
################ Standard graphics  110
######## fun_empty_graph() #### text to display for empty graphs    110
################ gg graphics    112
######## fun_gg_palette() #### ggplot2 default color palette    112
######## fun_gg_just() #### ggplot2 justification of the axis labeling, depending on angle  113
######## fun_gg_get_legend() #### get the legend of ggplot objects  116
######## fun_gg_point_rast() #### ggplot2 raster scatterplot layer  118
######## fun_gg_boxplot() #### ggplot2 boxplot + background dots if required    121
######## fun_gg_scatter() #### ggplot2 scatterplot + lines (up to 6 overlays totally)   121
######## fun_gg_heatmap() #### ggplot2 heatmap + overlaid mask if required  122
######## fun_gg_empty_graph() #### text to display for empty graphs 135
################ Graphic extraction 137
######## fun_trim() #### display values from a quantitative variable and trim according to defined cut-offs 137
######## fun_segmentation() #### segment a dot cloud on a scatterplot and define the dots from another cloud outside the segmentation   146
################ Import 178
######## fun_pack() #### check if R packages are present and import into the working environment    178
######## fun_python_pack() #### check if python packages are present    180
################ Print / Exporting results (text & tables)  182
######## fun_report() #### print string or data object into output file 182
######## fun_get_message() #### return error/warning/other messages of an expression (that can be exported) 185


################################ FUNCTIONS ################################


################ Object analysis


######## fun_check() #### check class, type, length, etc., of objects


# Check r_debugging_tools-v1.2.R OK
# Check fun_test() (see cute_checks.docx) Ok
# check manual: example to scan again
# clear to go Apollo
fun_check <- function(data, data.name = NULL, 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, print = FALSE, 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 arguments, even if what is written in incoherent. For instance, fun_check(data = factor(1), class = "factor", mode = "character") will return a problem, and this, what ever the object tested in the data argument, because no object can be class "factor" and mode "character" (factors are class "factor" and mode "numeric")
# 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 FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# none
# ARGUMENTS
# data: object to test
# data.name: character string indicating the name of the object to test. If NULL, use the name of the object assigned to the data argument
# 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 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 == 0 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 indicating all the possible option values for data
# all.options.in.data: logical. If TRUE, all of the options must be present at least once in data, and nothing else. If FALSE, some or all of the options must be present in data, and nothing else. Ignored if options is NULL
# na.contain: logical. Can data contain NA?
# neg.values: logical. Are negative numeric values authorized? BEWARE: only considered if set to FALSE, to check for non negative values when class is set to "vector", "numeric", "matrix", "array", "data.frame", "table", or typeof is set to "double", "integer", or mode is set to "numeric". Ignored in other cases, notably with prop argument
# print: logical. Print the error message if $problem is TRUE? WARNING: set by default to FALSE, which facilitates the control of the error message output when using fun_check() inside functions. See the example section
# fun.name: character string indicating the name of the function checked (i.e., when fun_check() is used to check its argument). If non NULL, name will be added into the error message returned by fun_check()
# RETURN
# a list containing:
# $problem: logical. Is there any problem detected?
# $text: the problem detected
# $fun.name: name of the checked parameter
# EXAMPLES
# test <- 1:3 ; fun_check(data = test, data.name = NULL, print = TRUE, options = NULL, all.options.in.data = FALSE, class = NULL, typeof = NULL, mode = NULL, prop = TRUE, double.as.integer.allowed = FALSE, length = NULL)
# test <- 1:3 ; fun_check(data = test, print = TRUE, class = "numeric", typeof = NULL, double.as.integer.allowed = FALSE)
# test <- 1:3 ; fun_check(data = test, print = TRUE, class = "vector", mode = "numeric")
# argument print with and without assignation
# test <- 1:3 ; tempo <- fun_check(data = test, print = TRUE, class = "vector", mode = "character")
# test <- 1:3 ; tempo <- fun_check(data = test, print = FALSE, class = "vector", mode = "character") # the assignation allows to recover a problem without printing it
# if(tempo$problem == TRUE){cat(paste0("\n\n================\n\n", tempo$text, "\n\n================\n\n"))}
# test <- 1:3 ; fun_check(data = test, print = TRUE, class = "vector", mode = "character")
# test <- matrix(1:3) ; fun_check(data = test, print = TRUE, class = "vector", mode = "numeric")
# DEBUGGING
# data = expression(TEST) ; data.name = NULL ; class = "vector" ; typeof = NULL ; mode = NULL ; length = 1 ; prop = FALSE ; double.as.integer.allowed = FALSE ; options = NULL ; all.options.in.data = FALSE ; na.contain = FALSE ; neg.values = TRUE ; print = TRUE ; fun.name = NULL
# function name: no used in this function for the error message, to avoid env colliding
# argument checking
# fun.name checked first because required next
if( ! is.null(fun.name)){
if( ! (all(class(fun.name) == "character") & length(fun.name) == 1)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): THE fun.name ARGUMENT MUST BE A CHARACTER VECTOR OF LENGTH 1: ", paste(fun.name, collapse = " "), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
}
# end fun.name checked first because required next
# arg with no default values
if(missing(data)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": ARGUMENT data HAS NO DEFAULT VALUE AND REQUIRES ONE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# end arg with no default values
# dealing with NA
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(print)) | any(is.na(fun.name))){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": NO ARGUMENT EXCEPT data AND options CAN HAVE NA VALUES\nPROBLEMATIC ARGUMENTS ARE: ", paste(c("data.name", "class", "typeof", "mode", "length", "prop", "double.as.integer.allowed", "all.options.in.data", "na.contain", "neg.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(print)), any(is.na(fun.name)))], collapse = " "), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# end dealing with NA
# dealing with NULL
if(is.null(prop) | is.null(double.as.integer.allowed) | is.null(all.options.in.data) | is.null(na.contain) | is.null(neg.values) | is.null(print)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": THESE ARGUMENTS\nprop\ndouble.as.integer.allowed\nall.options.in.data\nna.contain\nneg.values\nprint\nCANNOT BE NULL\nPROBLEMATIC ARGUMENTS ARE: ", paste(c("prop", "double.as.integer.allowed", "all.options.in.data", "na.contain", "neg.values", "print")[c(is.null(prop), is.null(double.as.integer.allowed), is.null(all.options.in.data), is.null(na.contain), is.null(neg.values), is.null(print))], collapse = " "), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# end dealing with NULL
# dealing with logical
# tested below
# end dealing with logical
if( ! is.null(data.name)){
if( ! (length(data.name) == 1 & all(class(data.name) == "character"))){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": data.name ARGUMENT MUST BE A SINGLE CHARACTER ELEMENT AND NOT ", paste(data.name, collapse = " "), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
}
if(is.null(options) & is.null(class) & is.null(typeof) & is.null(mode) &  prop == FALSE & is.null(length)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": AT LEAST ONE OF THE options, class, typeof, mode, prop, OR length ARGUMENT MUST BE SPECIFIED (I.E, TRUE FOR prop)\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if( ! is.null(options) & ( ! is.null(class) | ! is.null(typeof) | ! is.null(mode) | prop == TRUE)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", 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\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if( ! (all(class(neg.values) == "logical") & length(neg.values) == 1 & any(is.na(neg.values)) != TRUE)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": THE neg.values ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if(neg.values == FALSE & is.null(class) & is.null(typeof) & is.null(mode)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": THE neg.values ARGUMENT CANNOT BE SWITCHED TO FALSE IF class, typeof AND mode ARGUMENTS ARE NULL\n\n================\n\n")
stop(tempo.cat, 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") & any(is.na(class)) != TRUE & length(class) == 1)){ # length == 1 here because of class(matrix()) since R4.0.0
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", 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\"\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if(neg.values == FALSE & ! any(class %in% c("vector", "numeric", "integer", "matrix", "array", "data.frame", "table"))){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN \"vector\", \"numeric\", \"integer\", \"matrix\", \"array\", \"data.frame\", \"table\" IF neg.values ARGUMENT IS SWITCHED TO FALSE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
}
if( ! is.null(typeof)){
if( ! (all(typeof %in% c("logical", "integer", "double", "complex", "character", "list", "expression", "name", "symbol", "closure", "special", "builtin", "environment", "S4")) & length(typeof) == 1 & any(is.na(typeof)) != TRUE)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", 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\"\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if(neg.values == FALSE & ! typeof %in% c("double", "integer")){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN \"double\" OR \"integer\" IF neg.values ARGUMENT IS SWITCHED TO FALSE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
}
if( ! is.null(mode)){
if( ! (all(mode %in% c("logical", "numeric", "complex", "character", "list", "expression", "name", "symbol", "function", "environment", "S4")) & length(mode) == 1 & any(is.na(mode)) != TRUE)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": mode ARGUMENT MUST BE ONE OF THESE VALUE:\n\"logical\", \"numeric\", \"complex\", \"character\", \"list\", \"expression\", \"name\", \"symbol\", \"function\", \"environment\", \"S4\"\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if(neg.values == FALSE & mode != "numeric"){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN \"numeric\" IF neg.values ARGUMENT IS SWITCHED TO FALSE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
}
if( ! is.null(length)){
if( ! (is.numeric(length) & length(length) == 1 & ! grepl(length, pattern = "\\.") & any(is.na(length)) != TRUE)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": length ARGUMENT MUST BE A SINGLE INTEGER VALUE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
}
if( ! (is.logical(prop) | (length(prop) == 1 & any(is.na(prop)) != TRUE))){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": prop ARGUMENT MUST BE TRUE OR FALSE ONLY\n\n================\n\n")
stop(tempo.cat, 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("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": class ARGUMENT CANNOT BE OTHER THAN NULL, \"vector\", \"numeric\", \"matrix\", \"array\", \"data.frame\", \"table\" IF prop ARGUMENT IS TRUE\n\n================\n\n") # not integer because prop
stop(tempo.cat, call. = FALSE)
}
}
if( ! is.null(mode)){
if(mode != "numeric"){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": mode ARGUMENT CANNOT BE OTHER THAN NULL OR \"numeric\" IF prop ARGUMENT IS TRUE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
}
if( ! is.null(typeof)){
if(typeof != "double"){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": typeof ARGUMENT CANNOT BE OTHER THAN NULL OR \"double\" IF prop ARGUMENT IS TRUE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
}
}
if( ! (all(class(double.as.integer.allowed) == "logical") & length(double.as.integer.allowed) == 1 & any(is.na(double.as.integer.allowed)) != TRUE)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": THE double.as.integer.allowed ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(double.as.integer.allowed, collapse = " "), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if( ! (is.logical(all.options.in.data) & length(all.options.in.data) == 1 & any(is.na(all.options.in.data)) != TRUE)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check()", ifelse(is.null(fun.name), "", paste0(" IN ", fun.name)), ": all.options.in.data ARGUMENT MUST BE A SINGLE LOGICAL VALUE (TRUE OR FALSE ONLY): ", paste(all.options.in.data, collapse = " "), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if( ! (all(class(na.contain) == "logical") & length(na.contain) == 1 & any(is.na(na.contain)) != TRUE)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): THE na.contain ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(na.contain, collapse = " "), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if( ! (all(class(print) == "logical") & length(print) == 1 & any(is.na(print)) != TRUE)){
tempo.cat <- paste0("\n\n================\n\nERROR IN fun_check(): THE print ARGUMENT MUST BE TRUE OR FALSE ONLY: ", paste(print, collapse = " "), "\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# fun.name tested at the beginning
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status
# end argument 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, " PARAMETER")
if( ! is.null(options)){
text <- ""
if( ! all(data %in% options, na.rm = TRUE)){
problem <- TRUE
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " PARAMETER MUST BE SOME OF THESE OPTIONS: ", paste(options, collapse = " "), "\nTHE PROBLEMATIC ELEMENTS OF data 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, " PARAMETER 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(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 ", length(data))
}
}
if(text == ""){
text <- paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER")
}
}
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(class(data) %in% c("factor", "ordered"))){ # to deal with ordered factors
class <- c("factor", "ordered")
}
}
if(is.null(options)){
for(i2 in 1:length(arg.names)){
if( ! is.null(get(arg.names[i2]))){
# 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, " PARAMETER"))){
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": THE ", data.name, " PARAMETER MUST BE ") ;
}else{
text <- paste0(text, " AND ") ; 
}
text <- paste0(text, toupper(arg.names[i2]), " ", if(all(get(arg.names[i2]) %in% c("matrix", "array"))){"matrix"}else if(all(get(arg.names[i2]) %in% c("factor", "ordered"))){"factor"}else{get(arg.names[i2])})
'
# end script to execute
if(typeof(data) == "double" & double.as.integer.allowed == TRUE & ((arg.names[i2] == "class" & all(get(arg.names[i2]) == "integer")) | (arg.names[i2] == "typeof" & all(get(arg.names[i2]) == "integer")))){
if( ! all(data %% 1 == 0, 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
eval(parse(text = tempo.script)) # execute tempo.script
}
}else if( ! any(all(get(arg.names[i2]) %in% c("vector", "ggplot2"))) & ! all(eval(parse(text = paste0(arg.names[i2], "(data)"))) %in% get(arg.names[i2]))){ # 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
eval(parse(text = tempo.script)) # execute tempo.script
}else if(arg.names[i2] == "class" & all(get(arg.names[i2]) == "vector") & ! (all(class(data) %in% "numeric") | all(class(data) %in% "integer") | all(class(data) %in% "character") | all(class(data) %in% "logical"))){ # test class == "vector". No need of na.rm = TRUE for all because %in% does not output NA
eval(parse(text = tempo.script)) # execute tempo.script
}else if(arg.names[i2] == "class" & all(get(arg.names[i2]) == "ggplot2") & ! all(class(data) %in% c("gg", "ggplot"))){ # test ggplot object
eval(parse(text = tempo.script)) # execute tempo.script
}
}
}
}
if(prop == TRUE){
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, " PARAMETER"))){
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ")
}else{
text <- paste0(text, " AND ")
}
text <- paste0(text, "THE ", data.name, " PARAMETER MUST BE DECIMAL VALUES BETWEEN 0 AND 1")
}
}
if(all(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 & (mode(data) %in% c("logical", "numeric", "complex", "character", "list", "expression", "name", "symbol"))){ # 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
problem <- TRUE
if(identical(text, paste0(ifelse(is.null(fun.name), "", paste0("IN ", fun.name, ": ")), "NO PROBLEM DETECTED FOR THE ", data.name, " PARAMETER"))){
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ")
}else{
text <- paste0(text, " AND ")
}
text <- paste0(text, "THE ", data.name, " PARAMETER CONTAINS NA WHILE NOT AUTHORIZED")
}
}
if(neg.values == FALSE){
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, " PARAMETER"))){
text <- paste0(ifelse(is.null(fun.name), "ERROR", paste0("ERROR IN ", fun.name)), ": ")
}else{
text <- paste0(text, " AND ")
}
text <- paste0(text, "THE ", data.name, " PARAMETER MUST BE NON NEGATIVE NUMERIC VALUES")
}
}
if(print == TRUE & problem == TRUE){
cat(paste0("\n\n================\n\n", text, "\n\n================\n\n"))
}
output <- list(problem = problem, text = text, fun.name = data.name)
return(output)
}

######## fun_secu() #### verif that local variables are not present in other envs


fun_secu <- function(pos = 1, name = NULL){
# AIM
# verif that local variables are not present in other environments, in order to avoid scope preference usage. The fun_secu() function checks by default the parent environment. This means that when used inside a function, it checks the local environment of this function. When used in the Global environment, it would check this environment
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# ARGUMENTS
# pos: single integer indicating the position of the environment checked (argument n of parent.frame()). VaLue 1 means one step above the fun_secu() local environment. Thus, if fun_secu() is used in the working environment, with pos ==1, variables of this env will be checked in the above envs. If fun_secu() is used in a function, with pos ==1, variables presents in the local env of the functions will be checked in the above envs (which includes the working environment (Global env)
# name: single character string indicating the name of the function checked
# RETURN
# a character string of the local variables that match variables in the different environments of the R scope, or NULL if no match
# EXAMPLES
# fun_secu()
# fun_secu(pos = 2)
# mean <- 0 ; fun1 <- function(){sd <- 1 ; fun_secu(name = as.character(sys.calls()[[length(sys.calls())]]))} ; fun2 <- function(){cor <- 2 ; fun1()} ; fun1() ; fun2() ; rm(mean) # sys.calls() gives the the function name at top stack of the imbricated functions, sys.calls()[[length(sys.calls())]] the name of the just above function. This can also been used for the above function: as.character(sys.call(1))
# test.pos <- 2 ; mean <- 0 ; fun1 <- function(){sd <- 1 ; fun_secu(pos = test.pos, name = if(length(sys.calls()) >= test.pos){as.character(sys.calls()[[length(sys.calls()) + 1 - test.pos]])}else{search()[ (1:length(search()))[test.pos - length(sys.calls())]]})} ; fun2 <- function(){cor <- 2 ; fun1()} ; fun1() ; fun2() ; rm(mean) # for argument name, here is a way to have the name of the tested environment according to test.pos value
# DEBUGGING
# pos = 1 ; name = NULL # for function debugging
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# end required function checking
# argument checking
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = pos, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, length = 1, fun.name = function.name) ; eval(ee)
if( ! is.null(name)){
tempo <- fun_check(data = name, class = "vector", typeof = "character", length = 1, fun.name = function.name) ; eval(ee)
}
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
# end argument checking
# main code
# match.list <- vector("list", length = (length(sys.calls()) - 1 + length(search()) + ifelse(length(sys.calls()) == 1, -1, 0))) # match.list is a list of all the environment tested (local of functions and R envs), length(sys.calls()) - 1 to remove the level of the fun_secu() function, sys.calls() giving all the names of the imbricated functions, including fun_secu, ifelse(length(sys.calls()) == 1, -1, 0) to remove Global env if this one is tested
tempo.name <- rev(as.character(unlist(sys.calls()))) # get names of frames (i.e., enclosed env)
tempo.frame <- rev(sys.frames())  # get frames (i.e., enclosed env)
# dealing with source()
# source() used in the Global env creates three frames above the Global env, which should be removed because not very interesting for variable duplications. Add a <<-(sys.frames()) in this code and source anova_contrasts code to see this. With ls(a[[4]]), we can see the content of each env, which are probably elements of source()
if(any(sapply(tempo.frame, FUN = environmentName) %in% "R_GlobalEnv")){
global.pos <- which(sapply(tempo.frame, FUN = environmentName) %in% "R_GlobalEnv")
# remove the global env (because already in search(), and all the oabove env
tempo.name <- tempo.name[-c(global.pos:length(tempo.frame))]
tempo.frame <- tempo.frame[-c(global.pos:length(tempo.frame))]
}
# end dealing with source()
# might have a problem if(length(tempo.name) == 0){
match.list <- vector("list", length = length(tempo.name) + length(search())) # match.list is a list of all the environment tested (local of functions and R envs), length(sys.calls()) - 1 to remove the level of the fun_secu() function, sys.calls() giving all the names of the imbricated functions, including fun_secu, ifelse(length(sys.calls()) == 1, -1, 0) to remove Global env if this one is tested
ls.names <- c(tempo.name, search()) # names of the functions + names of the search() environments
ls.input <- c(tempo.frame, as.list(search())) # environements of the functions + names of the search() environments
names(match.list) <- ls.names # 
match.list <- match.list[-c(1:(pos + 1))] # because we check only above pos
ls.tested <- ls.input[[pos + 1]]
ls.input <- ls.input[-c(1:(pos + 1))]
for(i1 in 1:length(match.list)){
if(any(ls(name = ls.input[[i1]], all.names = TRUE) %in% ls(name = ls.tested, all.names = TRUE))){
match.list[i1] <- list(ls(name = ls.input[[i1]], all.names = TRUE)[ls(name = ls.input[[i1]], all.names = TRUE) %in% ls(name = ls.tested, all.names = TRUE)])
}
}
if( ! all(sapply(match.list, FUN = is.null))){
output <- paste0("SOME VARIABLES ", ifelse(is.null(name), "OF THE CHECKED ENVIRONMENT", paste0("OF ", name)), " ARE ALSO PRESENT IN :\n", paste0(names(match.list[ ! sapply(match.list, FUN = is.null)]), ": ", sapply(match.list[ ! sapply(match.list, FUN = is.null)], FUN = paste0, collapse = " "), collapse = "\n"))
}else{
output <- NULL
}
return(output)
}


######## fun_info() #### recover object information


# Check OK: clear to go Apollo
fun_info <- function(data){
# AIM
# provide a full description of an object
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# none
# ARGUMENTS
# data: object to test
# RETURN
# a list containing information, depending on the class and type of data
# if data is made of numerics, provide range, sum, mean, number of NA and number of Inf
# please, use names(fun_info()) and remove what can be too big for easy analysis
# EXAMPLES
# fun_info(data = 1:3)
# fun_info(data.frame(a = 1:2, b = ordered(factor(c("A", "B")))))
# fun_info(list(a = 1:3, b = ordered(factor(c("A", "B")))))
# DEBUGGING
# data = NULL # for function debugging
# data = 1:3 # for function debugging
# data = matrix(1:3) # for function debugging
# data = data.frame(a = 1:2, b = c("A", "B")) # for function debugging
# data = factor(c("b", "a")) # for function debugging
# data = ordered(factor(c("b", "a"))) # for function debugging
# data = list(a = 1:3, b = factor(c("A", "B"))) # for function debugging
# data = list(a = 1:3, b = ordered(factor(c("A", "B")))) # for function debugging
# function name: no need because no check and no message
# argument checking
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status
# end argument checking
# main code
data.name <- deparse(substitute(data))
output <- list("NAME" = data.name)
tempo <- list("CLASS" = class(data))
output <- c(output, tempo)
tempo <- list("TYPE" = typeof(data))
output <- c(output, tempo)
tempo <- list("LENGTH" = length(data))
output <- c(output, tempo)
if(all(typeof(data) %in% c("integer", "numeric", "double"))){
tempo <- list("RANGE" = range(data[ ! is.infinite(data)], na.rm = TRUE))
output <- c(output, tempo)
tempo <- list("SUM" = sum(data[ ! is.infinite(data)], na.rm = TRUE))
output <- c(output, tempo)
tempo <- list("MEAN" = mean(data[ ! is.infinite(data)], na.rm = TRUE))
output <- c(output, tempo)
tempo <- list("NA.NB" = sum(is.na(data)))
output <- c(output, tempo)
tempo <- list("INF.NB" = sum(is.infinite(data)))
output <- c(output, tempo)
}
tempo <- list("HEAD" = head(data))
output <- c(output, tempo)
if( ! is.null(data)){
tempo <- list("TAIL" = tail(data))
output <- c(output, tempo)
if( ! is.null(dim(data))){
tempo <- list("DIMENSION" = dim(data))
names(tempo[[1]]) <- c("NROW", "NCOL")
output <- c(output, tempo)
}
tempo <- list("SUMMARY" = summary(data))
output <- c(output, tempo)
}
if(all(class(data) == "data.frame" | all(class(data) %in% c("matrix", "array")))){
tempo <- list("ROW_NAMES" = dimnames(data)[[1]])
output <- c(output, tempo)
tempo <- list("COLUM_NAMES" = dimnames(data)[[2]])
output <- c(output, tempo)
}
if(all(class(data) == "data.frame")){
tempo <- list("STRUCTURE" = ls.str(data)) # str() print automatically, ls.str() not but does not give the order of the data.frame
output <- c(output, tempo)
tempo <- list("COLUMN_TYPE" = sapply(data, FUN = "typeof"))
if(any(sapply(data, FUN = "class") %in% "factor")){ # if an ordered factor is present, then sapply(data, FUN = "class") return a list but works with any(sapply(data, FUN = "class") %in% "factor") 
tempo.class <- sapply(data, FUN = "class")
if(any(unlist(tempo.class) %in% "ordered")){
tempo2 <- sapply(tempo.class, paste, collapse = " ") # paste the "ordered" factor" in "ordered factor"
}else{
tempo2 <- unlist(tempo.class)
}
tempo[["COLUMN_TYPE"]][grepl(x = tempo2, pattern = "factor")] <- tempo2[grepl(x = tempo2, pattern = "factor")]
}
output <- c(output, tempo)
}
if(all(class(data) == "list")){
tempo <- list("COMPARTMENT_NAMES" = names(data))
output <- c(output, tempo)
tempo <- list("COMPARTMENT_TYPE" = sapply(data, FUN = "typeof"))
if(any(unlist(sapply(data, FUN = "class")) %in% "factor")){ # if an ordered factor is present, then sapply(data, FUN = "class") return a list but works with any(sapply(data, FUN = "class") %in% "factor") 
tempo.class <- sapply(data, FUN = "class")
if(any(unlist(tempo.class) %in% "ordered")){
tempo2 <- sapply(tempo.class, paste, collapse = " ") # paste the "ordered" factor" in "ordered factor"
}else{
tempo2 <- unlist(tempo.class)
}
tempo[["COMPARTMENT_TYPE"]][grepl(x = tempo2, pattern = "factor")] <- tempo2[grepl(x = tempo2, pattern = "factor")]
}
output <- c(output, tempo)
}
return(output)
}


######## fun_head() #### head of the left or right of big 2D objects


# Check OK: clear to go Apollo
fun_head <- function(data1, n = 6, side = "l"){
# AIM
# as head() but display the left or right head of big 2D objects
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# ARGUMENTS
# data1: any object but more dedicated for matrix, data frame or table
# n: as in head() but for for matrix, data frame or table, number of dimension to print (10 means 10 rows and columns)
# side: either "l" or "r" for the left or right side of the 2D object (only for matrix, data frame or table)
# BEWARE: other arguments of head() not used
# RETURN
# the head
# EXAMPLES
# obs1 = matrix(1:30, ncol = 5, dimnames = list(letters[1:6], LETTERS[1:5])) ; obs1 ; fun_head(obs1, 3)
# obs1 = matrix(1:30, ncol = 5, dimnames = list(letters[1:6], LETTERS[1:5])) ; obs1 ; fun_head(obs1, 3, "right")
# DEBUGGING
# data1 = matrix(1:30, ncol = 5) # for function debugging
# data1 = matrix(1:30, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# end required function checking
# argument checking
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = n, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = side, options = c("l", "r"), length = 1, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
# end argument checking
# main code
if( ! (any(class(data1) %in% c("data.frame", "table")) | all(class(data1) %in% c("matrix", "array")))){ # before R4.0.0, it was  ! any(class(data1) %in% c("matrix", "data.frame", "table"))
return(head(data1, n))
}else{
obs.dim <- dim(data1)
row <- 1:ifelse(obs.dim[1] < n, obs.dim[1], n)
if(side == "l"){
col <- 1:ifelse(obs.dim[2] < n, obs.dim[2], n)
}
if(side == "r"){
col <- ifelse(obs.dim[2] < n, 1, obs.dim[2] - n + 1):obs.dim[2]
}
return(data1[row, col])
}
}


######## fun_tail() #### tail of the left or right of big 2D objects


# Check OK: clear to go Apollo
fun_tail <- function(data1, n = 10, side = "l"){
# AIM
# as tail() but display the left or right head of big 2D objects
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# fun_check()
# ARGUMENTS
# data1: any object but more dedicated for matrix, data frame or table
# n: as in tail() but for for matrix, data frame or table, number of dimension to print (10 means 10 rows and columns)
# side: either "l" or "r" for the left or right side of the 2D object (only for matrix, data frame or table)
# BEWARE: other arguments of tail() not used
# RETURN
# the tail
# EXAMPLES
# obs1 = matrix(1:30, ncol = 5, dimnames = list(letters[1:6], LETTERS[1:5])) ; obs1 ; fun_tail(obs1, 3)
# obs1 = matrix(1:30, ncol = 5, dimnames = list(letters[1:6], LETTERS[1:5])) ; obs1 ; fun_tail(obs1, 3, "r")
# DEBUGGING
# data1 = matrix(1:10, ncol = 5) # for function debugging
# data1 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# required function checking
if(length(utils::find("fun_check", mode = "function")) == 0){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": REQUIRED fun_check() FUNCTION IS MISSING IN THE R ENVIRONMENT\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# end required function checking
# argument checking
arg.check <- NULL #
text.check <- NULL #
checked.arg.names <- NULL # for function debbuging: used by r_debugging_tools
ee <- expression(arg.check <- c(arg.check, tempo$problem) , text.check <- c(text.check, tempo$text) , checked.arg.names <- c(checked.arg.names, tempo$fun.name))
tempo <- fun_check(data = n, class = "vector", typeof = "integer", double.as.integer.allowed = TRUE, length = 1, fun.name = function.name) ; eval(ee)
tempo <- fun_check(data = side, options = c("l", "r"), length = 1, fun.name = function.name) ; eval(ee)
if(any(arg.check) == TRUE){
stop(paste0("\n\n================\n\n", paste(text.check[arg.check], collapse = "\n"), "\n\n================\n\n"), call. = FALSE) #
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) ; eval(parse(text = str_arg_check_with_fun_check_dev)) # activate this line and use the function (with no arguments left as NULL) to check arguments status and if they have been checked using fun_check()
# end argument checking
# main code
if( ! (any(class(data1) %in% c("data.frame", "table")) | all(class(data1) %in% c("matrix", "array")))){ # before R4.0.0, it was  ! any(class(data1) %in% c("matrix", "data.frame", "table"))
return(tail(data1, n))
}else{
obs.dim <- dim(data1)
row <- ifelse(obs.dim[1] < n, 1, obs.dim[1] - n + 1):obs.dim[1]
if(side == "l"){
col <- 1:ifelse(obs.dim[2] < n, obs.dim[2], n)
}
if(side == "r"){
col <- ifelse(obs.dim[2] < n, 1, obs.dim[2] - n + 1):obs.dim[2]
}
return(data1[row, col])
}
}


######## fun_comp_1d() #### comparison of two 1D datasets (vectors, factors, 1D tables)


# Check OK: clear to go Apollo
fun_comp_1d <- function(data1, data2){
# AIM
# compare two 1D datasets (vector or factor or 1D table, or 1D matrix or 1D array) of the same class or not. Check and report in a list if the 2 datasets have:
# same class
# common elements
# common element names (except factors)
# common levels (factors only)
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# none
# ARGUMENTS
# data1: vector or factor or 1D table, or 1D matrix or 1D array
# data2: vector or factor or 1D table, or 1D matrix or 1D array
# RETURN
# a list containing:
# $same.class: logical. Are class identical?
# $class: class of the 2 datasets (NULL otherwise)
# $same.length: logical. Are number of elements identical?
# $length: number of elements in the 2 datasets (NULL otherwise)
# $same.levels: logical. Are levels identical? NULL if data1 and data2 are not factors
# $levels: levels of the 2 datasets if identical (NULL otherwise or NULL if data1 and data2 are not factors)
# $any.id.levels: logical. Is there any identical levels? (NULL if data1 and data2 are not factors)
# $same.levels.pos1: position, in data1, of the levels identical in data2 (NULL if data1 and data2 are not factors)
# $same.levels.pos2: position, in data2, of the levels identical in data1 (NULL if data1 and data2 are not factors)
# $common.levels: common levels between data1 and data2 (can be a subset of $levels or not). NULL if no common levels or if data1 and data2 are not factors
# $same.name: logical. Are element names identical? NULL if data1 and data2 have no names
# $name: name of elements of the 2 datasets if identical (NULL otherwise)
# $any.id.name: logical. Is there any element names identical ?
# $same.name.pos1: position, in data1, of the element names identical in data2. NULL if no identical names
# $same.name.pos2: position, in data2, of the elements names identical in data1. NULL if no identical names
# $common.names: common element names between data1 and data2 (can be a subset of $name or not). NULL if no common element names
# $any.id.element: logical. is there any identical elements ?
# $same.element.pos1: position, in data1, of the elements identical in data2. NULL if no identical elements
# $same.element.pos2: position, in data2, of the elements identical in data1. NULL if no identical elements
# $common.elements: common elements between data1 and data2. NULL if no common elements
# $same.order: logical. Are all elements in the same order? TRUE or FALSE if elements of data1 and data2 are identical but not necessary in the same order. NULL otherwise (different length for instance)
# $order1: order of all elements of data1. NULL if $same.order is FALSE
# $order2: order of all elements of data2. NULL if $same.order is FALSE
# $identical.object: logical. Are objects identical (kind of object, element names, content, including content order)?
# $identical.content: logical. Are content objects identical (identical elements, including order, excluding kind of object and element names)?
# EXAMPLES
# obs1 = 1:5 ; obs2 = 1:5 ; names(obs1) <- LETTERS[1:5] ; names(obs2) <- LETTERS[1:5] ; fun_comp_1d(obs1, obs2)
# obs1 = 1:5 ; obs2 = 1:5 ; names(obs1) <- LETTERS[1:5] ; fun_comp_1d(obs1, obs2)
# obs1 = 1:5 ; obs2 = 3:6 ; names(obs1) <- LETTERS[1:5] ; names(obs2) <- LETTERS[1:4] ; fun_comp_1d(obs1, obs2)
# obs1 = factor(LETTERS[1:5]) ; obs2 = factor(LETTERS[1:5]) ; fun_comp_1d(obs1, obs2)
# obs1 = factor(LETTERS[1:5]) ; obs2 = factor(LETTERS[10:11]) ; fun_comp_1d(obs1, obs2)
# obs1 = factor(LETTERS[1:5]) ; obs2 = factor(LETTERS[4:7]) ; fun_comp_1d(obs1, obs2)
# obs1 = factor(c(LETTERS[1:4], "E")) ; obs2 = factor(c(LETTERS[1:4], "F")) ; fun_comp_1d(obs1, obs2)
# obs1 = 1:5 ; obs2 = factor(LETTERS[1:5]) ; fun_comp_1d(obs1, obs2)
# obs1 = 1:5 ; obs2 = 1.1:6.1 ; fun_comp_1d(obs1, obs2)
# obs1 = as.table(1:5); obs2 = as.table(1:5) ; fun_comp_1d(obs1, obs2)
# obs1 = as.table(1:5); obs2 = 1:5 ; fun_comp_1d(obs1, obs2)
# DEBUGGING
# data1 = 1:5 ; data2 = 1:5 ; names(data1) <- LETTERS[1:5] ; names(data2) <- LETTERS[1:5] # for function debugging
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# argument checking
if( ! any(class(data1) %in% c("logical", "integer", "numeric", "character", "factor", "table"))){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data1 ARGUMENT MUST BE A NON NULL VECTOR, FACTOR OR 1D TABLE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}else if(all(class(data1) %in% "table")){
if(length(dim(data1)) > 1){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data1 ARGUMENT MUST BE A 1D TABLE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
}
if( ! any(class(data2) %in% c("logical", "integer", "numeric", "character", "factor", "table"))){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data2 ARGUMENT MUST BE A NON NULL VECTOR, FACTOR OR 1D TABLE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}else if(all(class(data2) %in% "table")){
if(length(dim(data2)) > 1){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data2 ARGUMENT MUST BE A 1D TABLE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status
# end argument checking
# main code
same.class <- FALSE
class <- NULL
same.length <- FALSE
length <- NULL
same.levels <- NULL # not FALSE to deal with no factors
levels <- NULL
any.id.levels <- NULL
same.levels.pos1 <- NULL
same.levels.pos2 <- NULL
common.levels <- NULL
same.name <- NULL # not FALSE to deal with absence of name
name <- NULL
any.id.name <- FALSE
same.name.pos1 <- NULL
same.name.pos2 <- NULL
common.names <- NULL
any.id.element <- FALSE
same.element.pos1 <- NULL
same.element.pos2 <- NULL
common.elements <- NULL
same.order <- NULL
order1 <- NULL
order2 <- NULL
identical.object <- FALSE
identical.content <- FALSE
if(identical(data1, data2)){
same.class <- TRUE
class <- class(data1)
same.length <- TRUE
length <- length(data1)
if(any(class(data1) %in% "factor")){
same.levels <- TRUE
levels <- levels(data1)
any.id.levels <- TRUE
same.levels.pos1 <- 1:length(levels(data1))
same.levels.pos2 <- 1:length(levels(data2))
common.levels <- levels(data1)
}
if( ! is.null(names(data1))){
same.name <- TRUE
name <- names(data1)
any.id.name <- TRUE
same.name.pos1 <- 1:length(data1)
same.name.pos2 <- 1:length(data2)
common.names <- names(data1)
}
any.id.element <- TRUE
same.element.pos1 <- 1:length(data1)
same.element.pos2 <- 1:length(data2)
common.elements <- data1
same.order <- TRUE
order1 <- order(data1)
order2 <- order(data2)
identical.object <- TRUE
identical.content <- TRUE
}else{
if(identical(class(data1), class(data2))){
same.class <- TRUE
class <- class(data1)
}
if(identical(length(data1), length(data2))){
same.length<- TRUE
length <- length(data1)
}
if(any(class(data1) %in% "factor") & any(class(data2) %in% "factor")){
if(identical(levels(data1), levels(data2))){
same.levels <- TRUE
levels <- levels(data1)
}else{
same.levels <- FALSE
}
if(any(levels(data1) %in% levels(data2))){
any.id.levels <- TRUE
same.levels.pos1 <- which(levels(data1) %in% levels(data2))
}
if(any(levels(data2) %in% levels(data1))){
any.id.levels <- TRUE
same.levels.pos2 <- which(levels(data2) %in% levels(data1))
}
if(any.id.levels == TRUE){
common.levels <- unique(c(levels(data1)[same.levels.pos1], levels(data2)[same.levels.pos2]))
}
}
if(any(class(data1) %in% "factor")){ # to compare content
data1 <- as.character(data1)
}
if(any(class(data2) %in% "factor")){ # to compare content
data2 <- as.character(data2)
}
if( ! (is.null(names(data1)) & is.null(names(data2)))){
if(identical(names(data1), names(data2))){
same.name <- TRUE
name <- names(data1)
}else{
same.name <- FALSE
}
if(any(names(data1) %in% names(data2))){
any.id.name <- TRUE
same.name.pos1 <- which(names(data1) %in% names(data2))
}
if(any(names(data2) %in% names(data1))){
any.id.name <- TRUE
same.name.pos2 <- which(names(data2) %in% names(data1))
}
if(any.id.name == TRUE){
common.names <- unique(c(names(data1)[same.name.pos1], names(data2)[same.name.pos2]))
}
}
names(data1) <- NULL # names solved -> to do not be disturbed by names
names(data2) <- NULL # names solved -> to do not be disturbed by names
if(any(data1 %in% data2)){
any.id.element <- TRUE
same.element.pos1 <- which(data1 %in% data2)
}
if(any(data2 %in% data1)){
any.id.element <- TRUE
same.element.pos2 <- which(data2 %in% data1)
}
if(any.id.element == TRUE){
common.elements <- unique(c(data1[same.element.pos1], data2[same.element.pos2]))
}
if(identical(data1, data2)){
identical.content <- TRUE
same.order <- TRUE
}else if(identical(sort(data1), sort(data2))){
same.order <- FALSE
order1 <- order(data1)
order2 <- order(data2)
}
}
output <- list(same.class = same.class, class = class, same.length = same.length, length = length, same.levels = same.levels, levels = levels, any.id.levels = any.id.levels, same.levels.pos1 = same.levels.pos1, same.levels.pos2 = same.levels.pos2, common.levels = common.levels, same.name = same.name, name = name, any.id.name = any.id.name, same.name.pos1 = same.name.pos1, same.name.pos2 = same.name.pos2, common.names = common.names, any.id.element = any.id.element, same.element.pos1 = same.element.pos1, same.element.pos2 = same.element.pos2, common.elements = common.elements, same.order = same.order, order1 = order1, order2 = order2, identical.object = identical.object, identical.content = identical.content)
return(output)
}


######## fun_comp_2d() #### comparison of two 2D datasets (row & col names, dimensions, etc.)


# Check OK: clear to go Apollo
fun_comp_2d <- function(data1, data2){
# AIM
# compare two 2D datasets of the same class or not. Check and report in a list if the 2 datasets have:
# same class
# common row names
# common column names
# same row number
# same column number
# potential identical rows between the 2 datasets
# potential identical columns between the 2 datasets
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# none
# ARGUMENTS
# data1: matrix, data frame or table
# data2: matrix, data frame or table
# RETURN
# a list containing:
# $same.class: logical. Are class identical ?
# $class: classes of the 2 datasets (NULL otherwise)
# $same.dim: logical. Are dimension identical ?
# $dim: dimension of the 2 datasets (NULL otherwise)
# $same.row.nb: logical. Are number of rows identical ?
# $row.nb: nb of rows of the 2 datasets if identical (NULL otherwise)
# $same.col.nb: logical. Are number of columns identical ?
# $col.nb: nb of columns of the 2 datasets if identical (NULL otherwise)
# $same.row.name: logical. Are row names identical ? NULL if no row names in the two 2D datasets
# $row.name: name of rows of the 2 datasets if identical (NULL otherwise)
# $any.id.row.name: logical. Is there any row names identical ? NULL if no row names in the two 2D datasets
# $same.row.name.pos1: position, in data1, of the row names identical in data2
# $same.row.name.pos2: position, in data2, of the row names identical in data1
# $common.row.names: common row names between data1 and data2 (can be a subset of $name or not). NULL if no common row names
# $same.col.name: logical. Are column names identical ? NULL if no col names in the two 2D datasets
# $col.name: name of columns of the 2 datasets if identical (NULL otherwise)
# $any.id.col.name: logical. Is there any column names identical ? NULL if no col names in the two 2D datasets
# $same.col.name.pos1: position, in data1, of the column names identical in data2
# $same.col.name.pos2: position, in data2, of the column names identical in data1
# $common.col.names: common column names between data1 and data2 (can be a subset of $name or not). NULL if no common column names
# $any.id.row: logical. is there identical rows (not considering row names)? NULL if nrow(data1) * nrow(data2) > 1e10
# $same.row.pos1: position, in data1, of the rows identical in data2 (not considering row names). Return "TOO BIG FOR EVALUATION" if nrow(data1) * nrow(data2) > 1e10
# $same.row.pos2: position, in data2, of the rows identical in data1 (not considering row names). Return "TOO BIG FOR EVALUATION" if nrow(data1) * nrow(data2) > 1e10
# $any.id.col: logical. is there identical columns (not considering column names)? NULL if ncol(data1) * ncol(data2) > 1e10
# $same.col.pos1: position in data1 of the cols identical in data2 (not considering column names). Return "TOO BIG FOR EVALUATION" if ncol(data1) * ncol(data2) > 1e10
# $same.col.pos2: position in data2 of the cols identical in data1 (not considering column names). Return "TOO BIG FOR EVALUATION" if ncol(data1) * ncol(data2) > 1e10
# $identical.object: logical. Are objects identical (including row & column names)?
# $identical.content: logical. Are content objects identical (identical excluding row & column names)?
# EXAMPLES
# obs1 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; obs2 = as.data.frame(matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5]))) ; obs1 ; obs2 ; fun_comp_2d(obs1, obs2)
# obs1 = matrix(101:110, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; obs2 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; obs1 ; obs2 ; fun_comp_2d(obs1, obs2)
# large matrices
# obs1 = matrix(1:1e6, ncol = 5, dimnames = list(NULL, LETTERS[1:5])) ; obs2 = matrix(as.integer((1:1e6)+1e6/5), ncol = 5, dimnames = list(NULL, LETTERS[1:5])) ; head(obs1) ; head(obs2) ; fun_comp_2d(obs1, obs2)
# WARNING: when comparing content (rows, columns, or total), double and integer data are considered as different -> double(1) != integer(1)
# obs1 = matrix(1:1e6, ncol = 5, dimnames = list(NULL, LETTERS[1:5])) ; obs2 = matrix((1:1e6)+1e6/5, ncol = 5, dimnames = list(NULL, LETTERS[1:5])) ; head(obs1) ; head(obs2) ; fun_comp_2d(obs1, obs2)
# obs1 = matrix(1:10, byrow = TRUE, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; obs2 = matrix(c(1:5, 101:105, 6:10), byrow = TRUE, ncol = 5, dimnames = list(c("a", "z", "b"), c(LETTERS[1:2], "k", LETTERS[5:4]))) ; obs1 ; obs2 ; fun_comp_2d(obs1, obs2)
# obs1 = t(matrix(1:10, byrow = TRUE, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5]))) ; obs2 = t(matrix(c(1:5, 101:105, 6:10), byrow = TRUE, ncol = 5, dimnames = list(c("a", "z", "b"), c(LETTERS[1:2], "k", LETTERS[5:4])))) ; obs1 ; obs2 ; fun_comp_2d(obs1, obs2)
# DEBUGGING
# data1 = matrix(1:10, ncol = 5) ; data2 = matrix(1:10, ncol = 5) # for function debugging
# data1 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; data2 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# data1 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; data2 = matrix(1:10, ncol = 5) # for function debugging
# data1 = matrix(1:15, byrow = TRUE, ncol = 5, dimnames = list(letters[1:3], LETTERS[1:5])) ; data2 = matrix(1:10, byrow = TRUE, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# data1 = matrix(1:15, ncol = 5, dimnames = list(letters[1:3], LETTERS[1:5])) ; data2 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# data1 = matrix(1:15, ncol = 5, dimnames = list(paste0("A", letters[1:3]), LETTERS[1:5])) ; data2 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# data1 = matrix(1:15, ncol = 5, dimnames = list(letters[1:3], LETTERS[1:5])) ; data2 = matrix(1:12, ncol = 4, dimnames = list(letters[1:3], LETTERS[1:4])) # for function debugging
# data1 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; data2 = matrix(101:110, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) # for function debugging
# data1 = data.frame(a = 1:3, b= letters[1:3], row.names = LETTERS[1:3]) ; data2 = data.frame(A = 1:3, B= letters[1:3]) # for function debugging
# data1 = matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; data2 = as.data.frame(matrix(1:10, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5]))) # for function debugging
# data1 = matrix(1:10, byrow = TRUE, ncol = 5, dimnames = list(letters[1:2], LETTERS[1:5])) ; data2 = matrix(c(1:5, 101:105, 6:10), byrow = TRUE, ncol = 5, dimnames = list(c("a", "z", "b"), c(LETTERS[1:2], "k", LETTERS[5:4]))) # for function debugging
# data1 = table(Exp1 = c("A", "A", "A", "B", "B", "B"), Exp2 = c("A1", "B1", "A1", "C1", "C1", "B1")) ; data2 = data.frame(A = 1:3, B= letters[1:3]) # for function debugging
# data1 = matrix(1:1e6, ncol = 5, dimnames = list(NULL, LETTERS[1:5])) ; data2 = matrix((1:1e6)+1e6/5, ncol = 5, dimnames = list(NULL, LETTERS[1:5]))
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# argument checking
if( ! (any(class(data1) %in% c("data.frame", "table")) | all(class(data1) %in% c("matrix", "array")))){ # before R4.0.0, it was  ! any(class(data1) %in% c("matrix", "data.frame", "table"))
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data1 ARGUMENT MUST BE A MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if( ! (any(class(data2) %in% c("data.frame", "table")) | all(class(data2) %in% c("matrix", "array")))){ # before R4.0.0, it was  ! any(class(data2) %in% c("matrix", "data.frame", "table"))
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data2 ARGUMENT MUST BE A MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status
# end argument checking
# main code
same.class <- NULL
class <- NULL
same.dim <- NULL
dim <- NULL
same.row.nb <- NULL
row.nb <- NULL
same.col.nb <- NULL
col.nb <- NULL
same.row.name <- NULL
row.name <- NULL
any.id.row.name <- NULL
same.row.name.pos1 <- NULL
same.row.name.pos2 <- NULL
common.row.names <- NULL
same.col.name <- NULL
any.id.col.name <- NULL
same.col.name.pos1 <- NULL
same.col.name.pos2 <- NULL
common.col.names <- NULL
col.name <- NULL
any.id.row <- NULL
same.row.pos1 <- NULL
same.row.pos2 <- NULL
any.id.col <- NULL
same.col.pos1 <- NULL
same.col.pos2 <- NULL
identical.object <- NULL
identical.content <- NULL
if(identical(data1, data2) & (any(class(data1) %in% c("data.frame", "table")) | all(class(data1) %in% c("matrix", "array")))){ # before R4.0.0, it was  ! any(class(data1) %in% c("matrix", "data.frame", "table"))
same.class <- TRUE
class <- class(data1)
same.dim <- TRUE
dim <- dim(data1)
same.row.nb <- TRUE
row.nb <- nrow(data1)
same.col.nb <- TRUE
col.nb <- ncol(data1)
same.row.name <- TRUE
row.name <- dimnames(data1)[[1]]
any.id.row.name <- TRUE
same.row.name.pos1 <- 1:row.nb
same.row.name.pos2 <- 1:row.nb
common.row.names <- dimnames(data1)[[1]]
same.col.name <- TRUE
col.name <- dimnames(data1)[[2]]
any.id.col.name <- TRUE
same.col.name.pos1 <- 1:col.nb
same.col.name.pos2 <- 1:col.nb
common.col.names <- dimnames(data1)[[2]]
any.id.row <- TRUE
same.row.pos1 <- 1:row.nb
same.row.pos2 <- 1:row.nb
any.id.col <- TRUE
same.col.pos1 <- 1:col.nb
same.col.pos2 <- 1:col.nb
identical.object <- TRUE
identical.content <- TRUE
}else{
identical.object <- FALSE
if(all(class(data1) == "table") & length(dim(data1)) == 1){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data1 ARGUMENT IS A 1D TABLE. USE THE fun_comp_1d FUNCTION\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if(all(class(data2) == "table") & length(dim(data2)) == 1){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data2 ARGUMENT IS A 1D TABLE. USE THE fun_comp_1d FUNCTION\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if( ! identical(class(data1), class(data2))){
same.class <- FALSE
}else if( ! (any(class(data1) %in% c("data.frame", "table")) | all(class(data1) %in% c("matrix", "array")))){ # before R4.0.0, it was  ! any(class(data1) %in% c("matrix", "data.frame", "table"))
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data1 AND data2 ARGUMENTS MUST BE EITHER MATRIX, DATA FRAME OR TABLE\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}else{
same.class <- TRUE
class <- class(data1)
}
if( ! identical(dim(data1), dim(data2))){
same.dim <- FALSE
}else{
same.dim <- TRUE
dim <- dim(data1)
}
if( ! identical(nrow(data1), nrow(data2))){
same.row.nb <- FALSE
}else{
same.row.nb <- TRUE
row.nb <- nrow(data1)
}
if( ! identical(ncol(data1), ncol(data2))){
same.col.nb <- FALSE
}else{
same.col.nb <- TRUE
col.nb <- ncol(data1)
}
# row and col names
if(is.null(dimnames(data1)) & is.null(dimnames(data2))){
same.row.name <- NULL
same.col.name <- NULL
# row and col names remain NULL
}else if((is.null(dimnames(data1)) & ! is.null(dimnames(data2))) | ( ! is.null(dimnames(data1)) & is.null(dimnames(data2)))){
same.row.name <- FALSE
same.col.name <- FALSE
# row and col names remain NULL
}else{
if( ! identical(dimnames(data1)[[1]], dimnames(data2)[[1]])){
same.row.name <- FALSE
# row names remain NULL
}else{
same.row.name <- TRUE
row.name <- dimnames(data1)[[1]]
}
# row names
any.id.row.name <- FALSE
if(any(dimnames(data1)[[1]] %in% dimnames(data2)[[1]])){
any.id.row.name <- TRUE
same.row.name.pos1 <- which(dimnames(data1)[[1]] %in% dimnames(data2)[[1]])
}
if(any(dimnames(data2)[[1]] %in% dimnames(data1)[[1]])){
any.id.row.name <- TRUE
same.row.name.pos2 <- which(dimnames(data2)[[1]] %in% dimnames(data1)[[1]])
}
if(any.id.row.name == TRUE){
common.row.names <- unique(c(dimnames(data1)[[1]][same.row.name.pos1], dimnames(data2)[[1]][same.row.name.pos2]))
}
# col names
any.id.col.name <- FALSE
if(any(dimnames(data1)[[2]] %in% dimnames(data2)[[2]])){
any.id.col.name <- TRUE
same.col.name.pos1 <- which(dimnames(data1)[[2]] %in% dimnames(data2)[[2]])
}
if(any(dimnames(data2)[[2]] %in% dimnames(data1)[[2]])){
any.id.col.name <- TRUE
same.col.name.pos2 <- which(dimnames(data2)[[2]] %in% dimnames(data1)[[2]])
}
if(any.id.col.name == TRUE){
common.col.names <- unique(c(dimnames(data1)[[2]][same.col.name.pos1], dimnames(data2)[[2]][same.col.name.pos2]))
}
if( ! identical(dimnames(data1)[[2]], dimnames(data2)[[2]])){
same.col.name <- FALSE
# col names remain NULL
}else{
same.col.name <- TRUE
col.name <- dimnames(data1)[[2]]
}
}
# identical row and col content
if(all(class(data1) == "table")){
as.data.frame(matrix(data1, ncol = ncol(data1)), stringsAsFactors = FALSE)
}else if(all(class(data1) %in% c("matrix", "array"))){
data1 <- as.data.frame(data1, stringsAsFactors = FALSE)
}else if(all(class(data1) == "data.frame")){
data1 <- data.frame(lapply(data1, as.character), stringsAsFactors=FALSE)
}
if(all(class(data2) == "table")){
as.data.frame(matrix(data2, ncol = ncol(data2)), stringsAsFactors = FALSE)
}else if(all(class(data2) %in% c("matrix", "array"))){
data2 <- as.data.frame(data2, stringsAsFactors = FALSE)
}else if(all(class(data2) == "data.frame")){
data2 <- data.frame(lapply(data2, as.character), stringsAsFactors=FALSE)
}
row.names(data1) <- paste0("A", 1:nrow(data1))
row.names(data2) <- paste0("A", 1:nrow(data2))
if(same.col.nb == TRUE){ # because if not the same col nb, the row cannot be identical
if(all(sapply(data1, FUN = typeof) == "integer") & all(sapply(data2, FUN = typeof) == "integer") & as.double(nrow(data1)) * nrow(data2) <= 1e10){ # as.double(nrow(data1)) to prevent integer overflow because R is 32 bits for integers
same.row.pos1 <- which(c(as.data.frame(t(data1), stringsAsFactors = FALSE)) %in% c(as.data.frame(t(data2), stringsAsFactors = FALSE))) # this work fast with only integers (because 32 bits)
same.row.pos2 <- which(c(as.data.frame(t(data2), stringsAsFactors = FALSE)) %in% c(as.data.frame(t(data1), stringsAsFactors = FALSE)))
}else if(as.double(nrow(data1)) * nrow(data2) <= 1e6){ # as.double(nrow(data1)) to prevent integer overflow because R is 32 bits for integers
same.row.pos1 <- logical(length = nrow(data1)) # FALSE by default
same.row.pos1[] <- FALSE # security
for(i3 in 1:nrow(data1)){
for(i4 in 1:nrow(data2)){
same.row.pos1[i3] <- identical(data1[i3, ], data2[i4, ])
}
}
same.row.pos1 <- which(same.row.pos1)

same.row.pos2 <- logical(length = nrow(data2)) # FALSE by default
same.row.pos2[] <- FALSE # security
for(i3 in 1:nrow(data2)){
for(i4 in 1:nrow(data1)){
same.row.pos2[i3] <- identical(data2[i3, ], data1[i4, ])
}
}
same.row.pos2 <- which(same.row.pos2)
}else{
same.row.pos1 <- "TOO BIG FOR EVALUATION"
same.row.pos2 <- "TOO BIG FOR EVALUATION"
}

names(same.row.pos1) <- NULL
names(same.row.pos2) <- NULL
if(all(is.na(same.row.pos1))){
same.row.pos1 <- NULL
}else{
same.row.pos1 <- same.row.pos1[ ! is.na(same.row.pos1)]
any.id.row <- TRUE
}
if(all(is.na(same.row.pos2))){
same.row.pos2 <- NULL
}else{
same.row.pos2 <- same.row.pos2[ ! is.na(same.row.pos2)]
any.id.row <- TRUE
}
if(is.null(same.row.pos1) & is.null(same.row.pos2)){
any.id.row <- FALSE
}else if(length(same.row.pos1) == 0 & length(same.row.pos2) == 0){
any.id.row <- FALSE
}else if(all(same.row.pos1 == "TOO BIG FOR EVALUATION") & all(same.row.pos2 == "TOO BIG FOR EVALUATION")){
any.id.row <- NULL
}
}else{
any.id.row <- FALSE
# same.row.pos1 and 2 remain NULL
}
if(same.row.nb == TRUE){ # because if not the same row nb, the col cannot be identical
if(all(sapply(data1, FUN = typeof) == "integer") & all(sapply(data2, FUN = typeof) == "integer") & as.double(ncol(data1)) * ncol(data2) <= 1e10){ # as.double(ncol(data1)) to prevent integer overflow because R is 32 bits for integers
same.col.pos1 <- which(c(data1) %in% c(data2))
same.col.pos2 <- which(c(data2) %in% c(data1))
}else if(as.double(ncol(data1)) * ncol(data2) <= 1e6){ # as.double(ncol(data1)) to prevent integer overflow because R is 32 bits for integers
same.col.pos1 <- logical(length = ncol(data1)) # FALSE by default
same.col.pos1[] <- FALSE # security
for(i3 in 1:ncol(data1)){
for(i4 in 1:ncol(data2)){
same.col.pos1[i3] <- identical(data1[ , i3], data2[ ,i4])
}
}
same.col.pos1 <- which(same.col.pos1)

same.col.pos2 <- logical(length = ncol(data2)) # FALSE by default
same.col.pos2[] <- FALSE # security
for(i3 in 1:ncol(data2)){
for(i4 in 1:ncol(data1)){
same.col.pos2[i3] <- identical(data2[ , i3], data1[ , i4])
}
}
same.col.pos2 <- which(same.col.pos2)
}else{
same.col.pos1 <- "TOO BIG FOR EVALUATION"
same.col.pos2 <- "TOO BIG FOR EVALUATION"
}
names(same.col.pos1) <- NULL
names(same.col.pos2) <- NULL
if(all(is.na(same.col.pos1))){
same.col.pos1 <- NULL
}else{
same.col.pos1 <- same.col.pos1[ ! is.na(same.col.pos1)]
any.id.col <- TRUE
}
if(all(is.na(same.col.pos2))){
same.col.pos2 <- NULL
}else{
same.col.pos2 <- same.col.pos2[ ! is.na(same.col.pos2)]
any.id.col <- TRUE
}
if(is.null(same.col.pos1) & is.null(same.col.pos2)){
any.id.col <- FALSE
}else if(length(same.col.pos1) == 0 & length(same.col.pos2) == 0){
any.id.col <- FALSE
}else if(all(same.col.pos1 == "TOO BIG FOR EVALUATION") & all(same.col.pos2 == "TOO BIG FOR EVALUATION")){
any.id.col <- NULL
}
}else{
any.id.col <- FALSE
# same.col.pos1 and 2 remain NULL
}
if(same.dim == TRUE){
names(data1) <- NULL
row.names(data1) <- NULL
names(data2) <- NULL
row.names(data2) <- NULL
if(identical(data1, data2)){
identical.content <- TRUE
}else{
identical.content <- FALSE
}
}else{
identical.content <- FALSE
}
}
output <- list(same.class = same.class, class = class, same.dim = same.dim, dim = dim, same.row.nb = same.row.nb, row.nb = row.nb, same.col.nb = same.col.nb , col.nb = col.nb, same.row.name = same.row.name, row.name = row.name, any.id.row.name = any.id.row.name, same.row.name.pos1 = same.row.name.pos1, same.row.name.pos2 = same.row.name.pos2, common.row.names = common.row.names, same.col.name = same.col.name, col.name = col.name,any.id.col.name = any.id.col.name, same.col.name.pos1 = same.col.name.pos1, same.col.name.pos2 = same.col.name.pos2, common.col.names = common.col.names, any.id.row = any.id.row, same.row.pos1 = same.row.pos1, same.row.pos2 = same.row.pos2, any.id.col = any.id.col, same.col.pos1 = same.col.pos1, same.col.pos2 = same.col.pos2, identical.object = identical.object, identical.content = identical.content)
return(output)
}


######## fun_comp_list() #### comparison of two lists


# Check OK: clear to go Apollo
fun_comp_list <- function(data1, data2){
# AIM
# compare two lists. Check and report in a list if the 2 datasets have:
# same length
# common names
# common compartments
# REQUIRED FUNCTIONS FROM CUTE_LITTLE_R_FUNCTION
# none
# ARGUMENTS
# data1: list
# data2: list
# RETURN
# a list containing:
# $same.length: logical. Are number of elements identical?
# $length: number of elements in the 2 datasets (NULL otherwise)
# $same.name: logical. Are element names identical ?
# $name: name of elements of the 2 datasets if identical (NULL otherwise)
# $any.id.name: logical. Is there any element names identical ?
# $same.name.pos1: position, in data1, of the element names identical in data2
# $same.name.pos2: position, in data2, of the compartment names identical in data1
# $any.id.compartment: logical. is there any identical compartments ?
# $same.compartment.pos1: position, in data1, of the compartments identical in data2
# $same.compartment.pos2: position, in data2, of the compartments identical in data1
# $identical.object: logical. Are objects identical (kind of object, compartment names and content)?
# $identical.content: logical. Are content objects identical (identical compartments excluding compartment names)?
# EXAMPLES
# obs1 = list(a = 1:5, b = LETTERS[1:2], d = matrix(1:6)) ; obs2 = list(a = 1:5, b = LETTERS[1:2], d = matrix(1:6)) ; fun_comp_list(obs1, obs2)
# obs1 = list(1:5, LETTERS[1:2]) ; obs2 = list(a = 1:5, b = LETTERS[1:2]) ; fun_comp_list(obs1, obs2)
# obs1 = list(b = 1:5, c = LETTERS[1:2]) ; obs2 = list(a = 1:5, b = LETTERS[1:2], d = matrix(1:6)) ; fun_comp_list(obs1, obs2)
# obs1 = list(b = 1:5, c = LETTERS[1:2]) ; obs2 = list(LETTERS[5:9], matrix(1:6), 1:5) ; fun_comp_list(obs1, obs2)
# DEBUGGING
# data1 = list(a = 1:5, b = LETTERS[1:2], d = matrix(1:6)) ; data2 = list(a = 1:5, b = LETTERS[1:2], d = matrix(1:6)) # for function debugging
# data1 = list(a = 1:5, b = LETTERS[1:2]) ; data2 = list(a = 1:5, b = LETTERS[1:2], d = matrix(1:6)) # for function debugging
# function name
function.name <- paste0(as.list(match.call(expand.dots=FALSE))[[1]], "()")
# end function name
# argument checking
if( ! any(class(data1) %in% "list")){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data1 ARGUMENT MUST BE A LIST\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
if( ! any(class(data2) %in% "list")){
tempo.cat <- paste0("\n\n================\n\nERROR IN ", function.name, ": THE data2 ARGUMENT MUST BE A LIST\n\n================\n\n")
stop(tempo.cat, call. = FALSE)
}
# source("C:/Users/Gael/Documents/Git_versions_to_use/debugging_tools_for_r_dev-v1.2/r_debugging_tools-v1.2.R") ; eval(parse(text = str_basic_arg_check_dev)) # activate this line and use the function to check arguments status
# end argument checking
# main code
same.length <- NULL
length <- NULL
same.name <- NULL
name <- NULL
any.id.name <- NULL
same.name.pos1 <- NULL
same.name.pos2 <- NULL
any.id.compartment <- NULL
same.compartment.pos1 <- NULL
same.compartment.pos2 <- NULL
identical.object <- NULL
identical.content <- NULL
if(identical(data1, data2)){
same.length <- TRUE
length <- length(data1)
if( ! is.null(names(data1))){
same.name <- TRUE
name <- names(data1)
any.id.name <- TRUE
same.name.pos1 <- 1:length(data1)
same.name.pos2 <- 1:length(data2)
}
any.id.compartment <- TRUE
same.compartment.pos1 <- 1:length(data1)
same.compartment.pos2 <- 1:length(data2)
identical.object <- TRUE
identical.content <- TRUE
}else{
identical.object <- FALSE
if( ! identical(length(data1), length(data2))){
same.length<- FALSE
}else{
same.length<- TRUE
length <- length(data1)
}
if( ! (is.null(names(data1)) & is.null(names(data2)))){
if( ! identical(names(data1), names(data2))){
same.name <- FALSE
}else{
same.name <- TRUE
name <- names(data1)
}
any.id.name <- FALSE
if(any(names(data1) %in% names(data2))){
any.id.name <- TRUE
same.name.pos1 <- which(names(data1) %in% names(data2))
}
if(any(names(data2) %in% names(data1))){
any.id.name <- TRUE
same.name.pos2 <- which(names(data2) %in% names(data1))
}
}
names(data1) <- NULL
names(data2) <- NULL
any.id.compartment <- FALSE
if(any(data1 %in% data2)){
any.id.compartment <- TRUE
same.compartment.pos1 <- which(data1 %in% data2)
}
if(any(data2 %in% data1)){
any.id.compartment <- TRUE
same.compartment.pos2 <- which(data2 %in% data1)
}
if(same.length == TRUE & ! all(is.null(same.compartment.pos1), is.null(same.compartment.pos2))){
if(identical(same.compartment.pos1, same.compartment.pos2)){
identical.content <- TRUE
}else{
identical.content <- FALSE
}
}else{
identical.content <- FALSE
}
}
output <- list(same.length = same.length, length = length, same.name = same.name, name = name, any.id.name = any.id.name, same.name.pos1 = same.name.pos1, same.name.pos2 = same.name.pos2, any.id.compartment = any.id.compartment, same.compartment.pos1 = same.compartment.pos1, same.compartment.pos2 = same.compartment.pos2, identical.object = identical.object, identical.content = identical.content)
return(output)
}


######## fun_test() #### test combinations of argument values of a function and return errors (and graphs)


# add traceback https://stackoverflow.com/questions/47414119/how-to-read-a-traceback-in-r

# Check OK: clear to go Apollo
fun_test <- function(fun, arg, val, expect.error = NULL, thread.nb = NULL, print.count = 10, plot.fun = FALSE, export = FALSE, res.path = NULL, lib.path = NULL, cute.path = "C:\\Users\\Gael\\Documents\\Git_projects\\cute_little_R_functions\\cute_little_R_functions.R"){
# AIM
# test combinations of argument values of a function
# WARNING
# Limited to 43 arguments with at least 2 values each. The total number of arguments tested can be more if the additional arguments have a single value. The limit is due to nested "for" loops (https://stat.ethz.ch/pipermail/r-help/2008-March/157341.html), but it should not be a problem since the number of tests would be 2^43 > 8e12
# ARGUMENTS
# fun: character string indicating the name of the function tested (without brackets)
# arg: vector of character strings of arguments of fun. At least arguments that do not have default values must be present in this vector
# val: list with number of compartments equal to length of arg, each compartment containing values of the corresponding argument in arg. Each different value must be in a list or in a vector. For instance, argument 3 in arg is a logical argument (values accepted TRUE, FALSE, NA). Thus, compartment 3 of val can be either list(TRUE, FALSE, NA), or c(TRUE, FALSE, NA)
# expect.error: list of exactly the same structure as val argument, but containing FALSE or TRUE, depending on whether error is expected (TRUE) or not (FALSE) for each corresponding value of val. A message is returned depending on discrepancies between the expected and observed errors. BEWARE: not always possible to write the expected errors for all the combination of argument values. Ignored if NULL
# thread.nb: numeric value indicating the number of available threads. Write NULL if no parallelization wanted